From 0b1ce12913e3d8146f762e31b76bcf4bf31d823f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 30 Oct 2023 16:40:49 +0100 Subject: [PATCH 001/152] initial support for list-based JoinKeys --- NAMESPACE | 16 ++ R/JoinKeys.R | 178 ++++-------------- R/new_join_keys.R | 337 ++++++++++++++++++++++++++++++++++ R/parents.R | 83 +++++++++ inst/WORDLIST | 15 +- man/assert_compatible_keys.Rd | 12 ++ man/get_join_key.Rd | 26 +++ man/get_keys.Rd | 16 +- man/join_pair.Rd | 21 +++ man/merge_join_keys.Rd | 26 +++ man/mutate_join_keys.Rd | 8 +- man/new_join_keys.Rd | 15 ++ man/parents.Rd | 48 +++++ man/print.Placeholder.Rd | 17 ++ man/split_join_keys.Rd | 22 +++ man/sub-.Placeholder.Rd | 35 ++++ 16 files changed, 722 insertions(+), 153 deletions(-) create mode 100644 R/new_join_keys.R create mode 100644 R/parents.R create mode 100644 man/assert_compatible_keys.Rd create mode 100644 man/get_join_key.Rd create mode 100644 man/join_pair.Rd create mode 100644 man/merge_join_keys.Rd create mode 100644 man/new_join_keys.Rd create mode 100644 man/parents.Rd create mode 100644 man/print.Placeholder.Rd create mode 100644 man/split_join_keys.Rd create mode 100644 man/sub-.Placeholder.Rd diff --git a/NAMESPACE b/NAMESPACE index 52a6ca514..7f3980cd9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,9 +1,15 @@ # Generated by roxygen2: do not edit by hand S3method("[",JoinKeys) +S3method("[",Placeholder) S3method("[<-",JoinKeys) +S3method("[<-",Placeholder) S3method("get_join_keys<-",JoinKeys) S3method("get_join_keys<-",teal_data) +S3method("join_keys<-",Placeholder) +S3method("parents<-",Placeholder) +S3method("parents[",Placeholder) +S3method("parents[<-",Placeholder) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(dataset,MultiAssayExperiment) @@ -52,7 +58,10 @@ S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) S3method(mutate_join_keys,JoinKeys) +S3method(mutate_join_keys,Placeholder) S3method(mutate_join_keys,TealData) +S3method(parents,Placeholder) +S3method(print,Placeholder) S3method(set_args,CallableCode) S3method(set_args,CallableFunction) S3method(set_args,TealDatasetConnector) @@ -68,6 +77,10 @@ export("col_labels<-") export("data_label<-") export("datanames<-") export("get_join_keys<-") +export("parents<-") +export("parents[") +export("parents[<-") +export("parents[[<-") export(as_cdisc) export(callable_code) export(callable_function) @@ -113,9 +126,11 @@ export(join_keys) export(load_dataset) export(load_datasets) export(mae_dataset) +export(merge_join_keys) export(mutate_data) export(mutate_dataset) export(mutate_join_keys) +export(parents) export(python_cdisc_dataset_connector) export(python_code) export(python_dataset_connector) @@ -127,6 +142,7 @@ export(script_cdisc_dataset_connector) export(script_dataset_connector) export(set_args) export(set_keys) +export(split_join_keys) export(teal_data) export(teal_data_file) export(to_relational_data) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 0b9255fb2..44604a46a 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -37,43 +37,16 @@ JoinKeys <- R6::R6Class( # nolint #' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset #' @return (`list`) a list of `JoinKeys` object split = function() { - list_of_list_of_join_key_set <- lapply( - names(self$get()), - function(dataset_1) { - lapply( - names(self$get()[[dataset_1]]), - function(dataset_2) join_key(dataset_1, dataset_2, self$get()[[dataset_1]][[dataset_2]]) - ) - } - ) - res <- lapply( - list_of_list_of_join_key_set, - function(x) { - y <- JoinKeys$new() - y$set(x) - } - ) - names(res) <- names(self$get()) - - logger::log_trace("JoinKeys$split keys split.") - return(res) + split_join_keys(self) }, #' @description #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object #' @param x `list` of `JoinKeys` objects or single `JoinKeys` object #' @return (`self`) invisibly for chaining merge = function(x) { - if (inherits(x, "JoinKeys")) x <- list(x) - checkmate::assert_list(x, types = "JoinKeys", min.len = 1) - for (jk in x) { - for (dataset_1 in names(jk$get())) { - for (dataset_2 in names(jk$get()[[dataset_1]])) { - self$mutate(dataset_1, dataset_2, jk$get()[[dataset_1]][[dataset_2]]) - } - } - } - logger::log_trace("JoinKeys$merge keys merged.") - return(invisible(self)) + result <- merge_join_keys(self, x) + class(result) <- "list" + private$.keys <- result }, #' @description #' Get join keys between two datasets. @@ -83,19 +56,11 @@ JoinKeys <- R6::R6Class( # nolint #' @details if one or both of `dataset_1` and `dataset_2` are missing then #' underlying keys structure is returned for further processing get = function(dataset_1, dataset_2) { - if (missing(dataset_1) && missing(dataset_2)) { - return(private$.keys) - } - if (missing(dataset_2)) { - return(private$.keys[[dataset_1]]) - } - if (missing(dataset_1)) { - return(private$.keys[[dataset_2]]) - } - if (is.null(private$.keys[[dataset_1]][[dataset_2]])) { - return(character(0)) - } - return(private$.keys[[dataset_1]][[dataset_2]]) + new_keys <- private$.keys + class(new_keys) <- "Placeholder" + res <- get_join_key(new_keys, dataset_1, dataset_2) + if (checkmate::test_class(res, "Placeholder")) class(res) <- "list" + res }, #' @description #' Change join_keys for a given pair of dataset names (or @@ -103,20 +68,12 @@ JoinKeys <- R6::R6Class( # nolint #' @param val (named `character`) column names used to join #' @return (`self`) invisibly for chaining mutate = function(dataset_1, dataset_2, val) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2) - checkmate::assert_character(val, any.missing = FALSE) - - private$join_pair(join_key(dataset_1, dataset_2, val)) + new_keys <- private$.keys + class(new_keys) <- "Placeholder" + res <- mutate_join_keys(new_keys, dataset_1, dataset_2, val) + class(res) <- "list" - logger::log_trace( - sprintf( - "JoinKeys$mutate updated the keys between %s and %s to %s", - dataset_1, - dataset_2, - paste(val, collapse = ", ") - ) - ) + private$.keys <- res return(invisible(self)) }, #' @description @@ -127,24 +84,11 @@ JoinKeys <- R6::R6Class( # nolint #' to be specified once #' @return (`self`) invisibly for chaining set = function(x) { - if (length(private$.keys) > 0) { - stop("Keys already set, please use JoinKeys$mutate() to change them") - } - if (inherits(x, "JoinKeySet")) { - x <- list(x) - } - - # check if any JoinKeySets share the same datasets but different values - for (idx_1 in seq_along(x)) { - for (idx_2 in seq_len(idx_1)) { - private$check_compatible_keys(x[[idx_1]], x[[idx_2]]) - } - } - - checkmate::assert_list(x, types = "JoinKeySet", min.len = 1) - lapply(x, private$join_pair) - - logger::log_trace("JoinKeys$set keys are set.") + jk <- private$.keys + class(jk) <- c("Placeholder", "list") + join_keys(jk) <- x + class(jk) <- "list" + private$.keys <- jk return(invisible(self)) }, #' @description @@ -153,18 +97,7 @@ JoinKeys <- R6::R6Class( # nolint #' @param ... additional arguments to the printing method #' @return invisibly self print = function(...) { - check_ellipsis(...) - keys_list <- self$get() - if (length(keys_list) > 0) { - cat(sprintf( - "A JoinKeys object containing foreign keys between %s datasets:\n", - length(keys_list) - )) - print(keys_list) - } else { - cat("An empty JoinKeys object.") - } - invisible(self) + print.Placeholder(private$.keys) }, #' @description #' Sets the parents of the datasets. @@ -254,63 +187,9 @@ JoinKeys <- R6::R6Class( # nolint .keys = list(), parents = list(), join_pair = function(join_key) { - dataset_1 <- join_key$dataset_1 - dataset_2 <- join_key$dataset_2 - keys <- join_key$keys - - if (is.null(private$.keys[[dataset_1]])) { - private$.keys[[dataset_1]] <- list() - } - private$.keys[[dataset_1]][[dataset_2]] <- keys - - if (dataset_2 != dataset_1) { - if (is.null(private$.keys[[dataset_2]])) { - private$.keys[[dataset_2]] <- list() - } - - if (length(keys) > 0) { - keys <- setNames(names(keys), keys) - } - private$.keys[[dataset_2]][[dataset_1]] <- keys - } - }, - # helper function to deterimine if two key sets contain incompatible keys - # return TRUE if compatible, throw error otherwise - check_compatible_keys = function(join_key_1, join_key_2) { - error_message <- function(dataset_1, dataset_2) { - stop( - paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2) - ) - } - - - # if first datasets and the second datasets match and keys - # must contain the same named elements - if (join_key_1$dataset_1 == join_key_2$dataset_1 && join_key_1$dataset_2 == join_key_2$dataset_2) { - if (!identical(sort(join_key_1$keys), sort(join_key_2$keys))) { - error_message(join_key_1$dataset_1, join_key_1$dataset_2) - } - } - - # if first dataset of join_key_1 matches second dataset of join_key_2 - # and the first dataset of join_key_2 must match second dataset of join_key_1 - # and keys must contain the same elements but with names and values swapped - if (join_key_1$dataset_1 == join_key_2$dataset_2 && join_key_1$dataset_2 == join_key_2$dataset_1) { - # have to handle empty case differently as names(character(0)) is NULL - if (length(join_key_1$keys) == 0 && length(join_key_2$keys) == 0) { - return(TRUE) - } - - if ( - xor(length(join_key_1$keys) == 0, length(join_key_2$keys) == 0) || - !identical(sort(join_key_1$keys), sort(setNames(names(join_key_2$keys), join_key_2$keys))) - ) { - error_message(join_key_1$dataset_1, join_key_1$dataset_2) - } - } - - # otherwise they are compatible - return(TRUE) + res <- join_pair(self, join_key) + class(res) <- "list" + private$.keys <- res }, # checks the parent child relations are valid check_parent_child = function() { @@ -365,6 +244,17 @@ JoinKeys <- R6::R6Class( # nolint #' join_keys <- function(...) { x <- rlang::list2(...) + + # Getter + if (checkmate::test_list(x, len = 1, types = c("Placeholder", "JoinKeys"))) { + return(x[[1]]) + } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { + return(x[[1]]@join_keys) + } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { + return(x[[1]]$get_join_keys()) + } + + # Constructor res <- JoinKeys$new() if (length(x) > 0) { res$set(x) diff --git a/R/new_join_keys.R b/R/new_join_keys.R new file mode 100644 index 000000000..b20e45ba6 --- /dev/null +++ b/R/new_join_keys.R @@ -0,0 +1,337 @@ +#' Setter for join keys +#' +#' @param data (`JoinKeys`) empty object to set the new relationship pairs. +#' @param value (`JoinKeySet` or list of `JoinKeySet`) relationship pairs to add +#' to `JoinKeys` list. +#' +#' @rdname get_keys +`join_keys<-` <- function(join_keys_obj, value) { + UseMethod("join_keys<-", join_keys_obj) +} + +#' @rdname get_keys +#' @export +#' @examples +#' jk <- new_join_keys() +#' join_keys(jk) +#' join_keys(jk) <- join_key("ds1", "ds2", "some_col2") +`join_keys<-.Placeholder` <- function(join_keys_obj, value) { + if (missing(value)) { + return(join_keys_obj) + } + + if (length(join_keys_obj) > 0) { + stop("Keys already set, please use mutate_join_keys() or to change them") + } + + if (inherits(value, "JoinKeySet")) value <- list(value) + + checkmate::assert_list(value, types = "JoinKeySet", min.len = 1) + + # check if any JoinKeySets share the same datasets but different values + for (idx_1 in seq_along(value)) { + for (idx_2 in seq_along(value[idx_1])) { + assert_compatible_keys(value[[idx_1]], value[[idx_2]]) + } + join_keys_obj <- join_pair(join_keys_obj, value[[idx_1]]) + } + + logger::log_trace("JoinKeys keys are set.") + + join_keys_obj +} + +#' @title Getter for JoinKeys that returns the relationship between pairs of datasets +#' @param x JoinKeys object to extract the join keys +#' @param dataset_1 (`character`) name of first dataset. +#' @param dataset_2 (`character`) name of second dataset. +#' +#' @export +#' +#' @examples +#' jk <- new_join_keys() +#' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +#' jk["ds1", "ds2"] +`[.Placeholder` <- function(x, dataset_1, dataset_2 = dataset_1) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2, null.ok = TRUE) + + x[[dataset_1]][[dataset_2]] +} + +#' @rdname sub-.Placeholder +#' @param keys value to assign +#' @export +#' @keywords internal +#' @examples +#' jk <- new_join_keys() +#' jk["ds1", "ds2"] +#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") +#' jk["ds1", "ds2"] +#' jk["ds1", "ds2"] <- "new_col" +#' jk["ds1", "ds2"] +`[<-.Placeholder` <- function(data, dataset_1, dataset_2 = dataset_1, value) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2, null.ok = TRUE) + + if (is.null(data[[dataset_1]])) data[[dataset_1]] <- list() + + data[[dataset_1]][[dataset_2]] <- value + + if (identical(dataset_1, dataset_2)) { + return(data) + } + + if (is.null(data[[dataset_2]])) data[[dataset_2]] <- list() + + if ( + checkmate::test_character(value, min.len = 1) && + !checkmate::test_names(names(value)) + ) { + value <- setNames(value, value) + } else if ( + checkmate::test_character(value, min.len = 1) + ) { + # Invert key + value <- setNames(names(value), value) + } + + data[[dataset_2]][[dataset_1]] <- value + + data +} + +#' @rdname mutate_join_keys +#' @export +#' @examples +#' jk <- new_join_keys() +#' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +#' mutate_join_keys(jk, "ds2", "ds3", "another") +mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2) + checkmate::assert_character(value, any.missing = FALSE) + + res <- join_pair(x, join_key(dataset_1, dataset_2, value)) + + logger::log_trace( + sprintf( + "JoinKeys updated the keys between %s and %s to %s", + dataset_1, + dataset_2, + paste(val, collapse = ", ") + ) + ) + + res +} + +#' Split the `JoinKeys` object into a named list of join keys objects with an +#' element for each dataset +#' +#' @return (`list`) a list of `JoinKeys` object +#' @export +#' @examples +#' jk <- new_join_keys() +#' jk["ds1", "ds2"] <- "some_col" +#' jk["ds1", "ds3"] <- "new_col" +#' split_join_keys(jk) +split_join_keys <- function(keys) { + checkmate::assert_multi_class(keys, classes = c("JoinKeys", "Placeholder")) + + if (checkmate::test_class(keys, "JoinKeys")) { + keys <- keys$get() + class(keys) <- "Placeholder" + } + + list_of_list_of_join_key_set <- lapply( + names(keys), + function(dataset_1) { + lapply( + names(keys[[dataset_1]]), + function(dataset_2) join_key(dataset_1, dataset_2, get_join_key(keys, dataset_1, dataset_2)) + ) + } + ) + res <- lapply(list_of_list_of_join_key_set, function(.x) do.call(join_keys, .x)) + names(res) <- names(keys) + + logger::log_trace("JoinKeys keys split.") + return(res) +} + +#' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object +#' +#' @param keys_1 `JoinKeys` object +#' @param keys_2 `list` of `JoinKeys` objects or single `JoinKeys` object +#' +#' @return (`JoinKeys`) a new object with the resulting merge +#' +#' @export +#' +#' @examples +#' jk1 <- new_join_keys() +#' jk1["ds1", "ds2"] <- "some_col" +#' jk2 <- new_join_keys() +#' jk2["ds1", "ds3"] <- "new_col" +#' merge_join_keys(jk1, jk2) +merge_join_keys <- function(keys_1, keys_2) { + if (checkmate::test_class(keys_1, "JoinKeys")) { + keys_1 <- keys_1$get() + class(keys_1) <- "Placeholder" + } + checkmate::assert_multi_class(keys_1, c("JoinKeys", "Placeholder")) + + if (inherits(keys_2, c("JoinKeys", "Placeholder"))) keys_2 <- list(keys_2) + checkmate::assert_list(keys_2, types = c("JoinKeys", "Placeholder"), min.len = 1) + + new_keys <- keys_1 + + for (jk in keys_2) { + if (checkmate::test_class(jk, "JoinKeys")) jk <- jk$get() + for (dataset_1 in names(jk)) { + for (dataset_2 in names(jk[[dataset_1]])) { + new_keys[dataset_1, dataset_2] <- jk[[dataset_1]][[dataset_2]] + } + } + } + logger::log_trace("JoinKeys keys merged.") + return(new_keys) +} + +#' Prints `JoinKeys`. +#' +#' @param ... additional arguments to the printing method +#' @return the `x` parameter +#' +#' @export +print.Placeholder <- function(x, ...) { + check_ellipsis(...) + keys_list <- x + class(keys_list) <- "list" + if (length(keys_list) > 0) { + cat(sprintf( + "A JoinKeys object containing foreign keys between %s datasets:\n", + length(keys_list) + )) + print.default(keys_list) + } else { + cat("An empty JoinKeys object.") + } + invisible(x) +} + +# ----------------------------------------------------------------------------- +# +# +# Helpers (non-exported) +# + +#' Internal constructor +#' +#' @return an empty `JoinKeys` list +#' +#' @keywords internal +new_join_keys <- function() { + result <- list() + class(result) <- c("Placeholder", "list") + result +} + +#' Get value of a single relationship pair +#' +#' @param join_keys_obj (`JoinKeys`) object that holds the relationship keys. +#' @param dataset_1 (`character(1)`) one of the datasets to retrieve keys ( +#' order of the datasets is irrelevant). +#' @param dataset_2 (`character(1)`) the other dataset to retrieve keys (the +#' order of the datasets is irrelevant). +#' +#' @return Character vector with keys or (if one of the datasets is omitted) a +#' list of relationship pairs. If both datasets are omitted it returens the +#' `JoinKeys` object +#' +#' @keywords internal +get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { + checkmate::assert_multi_class(join_keys_obj, c("teal_data", "Placeholder")) + jk <- join_keys(join_keys_obj) + + if (missing(dataset_1) && missing(dataset_2)) { + return(jk) + } + if (missing(dataset_2)) { + return(jk[[dataset_1]]) + } + if (missing(dataset_1)) { + return(jk[[dataset_2]]) + } + if (is.null(jk[[dataset_1]][[dataset_2]])) { + return(character(0)) + } + return(jk[[dataset_1]][[dataset_2]]) +} + +#' Helper function to add a new pair to a `JoinKeys` object +#' +#' @param join_keys_obj (`JoinKeys`) Object with existing pairs. +#' @param join_key_obj (`JoinKeySet`) relationship pair to add. +#' +#' @examples +#' jk <- new_join_keys() +#' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) +#' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) +join_pair <- function(join_keys_obj, join_key_obj) { + checkmate::assert_multi_class(join_keys_obj, c("JoinKeys", "Placeholder")) + checkmate::assert_class(join_key_obj, "JoinKeySet") + + if (checkmate::test_class(join_keys_obj, "JoinKeys")) { + join_keys_obj <- join_keys_obj$get() + class(join_keys_obj) <- "Placeholder" + } + + dataset_1 <- join_key_obj$dataset_1 + dataset_2 <- join_key_obj$dataset_2 + keys <- join_key_obj$keys + + join_keys_obj[dataset_1, dataset_2] <- keys + join_keys_obj +} + +#' Helper function to assert if two key sets contain incompatible keys +#' +#' return TRUE if compatible, throw error otherwise +#' @keywords internal +assert_compatible_keys <- function(join_key_1, join_key_2) { + error_message <- function(dataset_1, dataset_2) { + stop( + paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2) + ) + } + + # if first datasets and the second datasets match and keys + # must contain the same named elements + if (join_key_1$dataset_1 == join_key_2$dataset_1 && join_key_1$dataset_2 == join_key_2$dataset_2) { + if (!identical(sort(join_key_1$keys), sort(join_key_2$keys))) { + error_message(join_key_1$dataset_1, join_key_1$dataset_2) + } + } + + # if first dataset of join_key_1 matches second dataset of join_key_2 + # and the first dataset of join_key_2 must match second dataset of join_key_1 + # and keys must contain the same elements but with names and values swapped + if (join_key_1$dataset_1 == join_key_2$dataset_2 && join_key_1$dataset_2 == join_key_2$dataset_1) { + # have to handle empty case differently as names(character(0)) is NULL + if (length(join_key_1$keys) == 0 && length(join_key_2$keys) == 0) { + return(TRUE) + } + + if ( + xor(length(join_key_1$keys) == 0, length(join_key_2$keys) == 0) || + !identical(sort(join_key_1$keys), sort(setNames(names(join_key_2$keys), join_key_2$keys))) + ) { + error_message(join_key_1$dataset_1, join_key_1$dataset_2) + } + } + + # otherwise they are compatible + return(TRUE) +} diff --git a/R/parents.R b/R/parents.R new file mode 100644 index 000000000..545b590a5 --- /dev/null +++ b/R/parents.R @@ -0,0 +1,83 @@ +#' A name +#' @export +parents <- function(join_keys_obj) { + UseMethod("parents", join_keys_obj) +} + +#' @rdname parents +#' @export +#' @examples +#' jk <- new_join_keys() +#' parents(jk) +parents.Placeholder <- function(join_keys_obj) { + rlang::`%||%`(attr(join_keys_obj, "__parents__"), list()) +} + +#' @rdname parents +#' @export +#' @examples +#' jk <- new_join_keys() +#' parents(jk) <- list(ADSL = "ADTTE") +`parents<-` <- function(join_keys_obj, value) { + UseMethod("parents<-", join_keys_obj) +} + +#' @rdname parents +#' @export +#' @examples +#' jk <- new_join_keys() +#' parents(jk)["ADTTE"] <- "ADSL" +`parents<-.Placeholder` <- function(join_keys_obj, value) { + checkmate::assert_list(value, types = "character", names = "named", min.len = 1) + attr(join_keys_obj, "__parents__") <- value + join_keys_obj +} + + +#' @rdname parents +#' @export +#' @examples +`parents[` <- function(join_keys_obj, dataset) { + UseMethod("parents[", join_keys_obj) +} + +#' @rdname parents +#' @export +#' @examples +#' jk <- new_join_keys() +#' parents(jk)["ADTTE"] <- "ADSL" +#' parents(jk)["YADA"] +`parents[.Placeholder` <- function(join_keys_obj, dataset) { + checkmate::assert_list(dataset, min.len = 1, names = "named") + res <- attr(join_keys_obj, "__parents__")[[dataset]] + if (is.null(res)) { + return(NULL) + } + res +} + +#' @rdname parents +#' @export +`parents[[<-` <- function(join_keys_obj, dataset, value) { + UseMethod("parent[<-", join_keys_obj) +} + +#' @rdname parents +#' @export +`parents[<-` <- function(join_keys_obj, dataset, value) { + UseMethod("parent[<-", join_keys_obj) +} + +#' @rdname parents +#' @export +#' @examples +#' jk <- new_join_keys() +#' parents(jk)["ADTTE"] <- "ADSL" +`parents[<-.Placeholder` <- function(join_keys_obj, dataset, value) { + checkmate::assert_character(dataset, min.len = 1) + if (is.null(attr(join_keys_obj, "__parents__"))) { + attr(join_keys_obj, "__parents__") <- list() + } + attr(join_keys_obj, "__parents__") <- dataset + join_keys_obj +} diff --git a/inst/WORDLIST b/inst/WORDLIST index bf67939a4..b1ea8634f 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,16 +1,17 @@ CDISC +cloneable Forkers +formatters +funder Getter Hoffmann +iteratively JoinKeys Pre -Reproducibility -SCDA -UI -cloneable -formatters -funder -iteratively pre repo +Reproducibility reproducibility +returens +SCDA +UI diff --git a/man/assert_compatible_keys.Rd b/man/assert_compatible_keys.Rd new file mode 100644 index 000000000..e7b9751bb --- /dev/null +++ b/man/assert_compatible_keys.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{assert_compatible_keys} +\alias{assert_compatible_keys} +\title{Helper function to assert if two key sets contain incompatible keys} +\usage{ +assert_compatible_keys(join_key_1, join_key_2) +} +\description{ +return TRUE if compatible, throw error otherwise +} +\keyword{internal} diff --git a/man/get_join_key.Rd b/man/get_join_key.Rd new file mode 100644 index 000000000..2b31c51a3 --- /dev/null +++ b/man/get_join_key.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{get_join_key} +\alias{get_join_key} +\title{Get value of a single relationship pair} +\usage{ +get_join_key(join_keys_obj, dataset_1, dataset_2) +} +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object that holds the relationship keys.} + +\item{dataset_1}{(\code{character(1)}) one of the datasets to retrieve keys ( +order of the datasets is irrelevant).} + +\item{dataset_2}{(\code{character(1)}) the other dataset to retrieve keys (the +order of the datasets is irrelevant).} +} +\value{ +Character vector with keys or (if one of the datasets is omitted) a +list of relationship pairs. If both datasets are omitted it returens the +\code{JoinKeys} object +} +\description{ +Get value of a single relationship pair +} +\keyword{internal} diff --git a/man/get_keys.Rd b/man/get_keys.Rd index 447871856..63996f7e8 100644 --- a/man/get_keys.Rd +++ b/man/get_keys.Rd @@ -1,10 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_keys.R +% Please edit documentation in R/get_keys.R, R/new_join_keys.R \name{get_keys} \alias{get_keys} \alias{get_keys.TealDataset} \alias{get_keys.TealDatasetConnector} \alias{get_keys.TealDataAbstract} +\alias{join_keys<-} +\alias{join_keys<-.Placeholder} \title{Get dataset primary keys} \usage{ get_keys(x, ...) @@ -14,6 +16,10 @@ get_keys(x, ...) \method{get_keys}{TealDatasetConnector}(x, ...) \method{get_keys}{TealDataAbstract}(x, dataname, ...) + +join_keys(join_keys_obj) <- value + +\method{join_keys}{Placeholder}(join_keys_obj) <- value } \arguments{ \item{x}{an object of \code{TealDataset} or \code{TealDatasetConnector} class} @@ -21,6 +27,11 @@ get_keys(x, ...) \item{...}{not used, only for support of S3} \item{dataname}{(\code{character}) name of dataset to return keys for} + +\item{value}{(\code{JoinKeySet} or list of \code{JoinKeySet}) relationship pairs to add +to \code{JoinKeys} list.} + +\item{data}{(\code{JoinKeys}) empty object to set the new relationship pairs.} } \value{ (\code{character}) vector of column names @@ -60,4 +71,7 @@ get_keys( ), "x" ) +jk <- new_join_keys() +join_keys(jk) +join_keys(jk) <- join_key("ds1", "ds2", "some_col2") } diff --git a/man/join_pair.Rd b/man/join_pair.Rd new file mode 100644 index 000000000..85a29e096 --- /dev/null +++ b/man/join_pair.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{join_pair} +\alias{join_pair} +\title{Helper function to add a new pair to a \code{JoinKeys} object} +\usage{ +join_pair(join_keys_obj, join_key_obj) +} +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) Object with existing pairs.} + +\item{join_key_obj}{(\code{JoinKeySet}) relationship pair to add.} +} +\description{ +Helper function to add a new pair to a \code{JoinKeys} object +} +\examples{ +jk <- new_join_keys() +jk <- join_pair(jk, join_key("ds1", "ds2", "value")) +jk <- join_pair(jk, join_key("ds3", "ds2", "value")) +} diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd new file mode 100644 index 000000000..97589295a --- /dev/null +++ b/man/merge_join_keys.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{merge_join_keys} +\alias{merge_join_keys} +\title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} +\usage{ +merge_join_keys(keys_1, keys_2) +} +\arguments{ +\item{keys_1}{\code{JoinKeys} object} + +\item{keys_2}{\code{list} of \code{JoinKeys} objects or single \code{JoinKeys} object} +} +\value{ +(\code{JoinKeys}) a new object with the resulting merge +} +\description{ +Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object +} +\examples{ +jk1 <- new_join_keys() +jk1["ds1", "ds2"] <- "some_col" +jk2 <- new_join_keys() +jk2["ds1", "ds3"] <- "new_col" +merge_join_keys(jk1, jk2) +} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 78a4ef57c..b075abce6 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -1,9 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R +% Please edit documentation in R/JoinKeys.R, R/new_join_keys.R \name{mutate_join_keys} \alias{mutate_join_keys} \alias{mutate_join_keys.JoinKeys} \alias{mutate_join_keys.TealData} +\alias{mutate_join_keys.Placeholder} \title{Mutate \code{JoinKeys} with a new values} \usage{ mutate_join_keys(x, dataset_1, dataset_2, val) @@ -11,6 +12,8 @@ mutate_join_keys(x, dataset_1, dataset_2, val) \method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, val) \method{mutate_join_keys}{TealData}(x, dataset_1, dataset_2, val) + +\method{mutate_join_keys}{Placeholder}(x, dataset_1, dataset_2, value) } \arguments{ \item{x}{(\code{JoinKeys}) object to be modified} @@ -52,4 +55,7 @@ x$get_join_keys()$get("ADSL", "ADRS") mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) x$get_join_keys()$get("ADSL", "ADRS") +jk <- new_join_keys() +join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +mutate_join_keys(jk, "ds2", "ds3", "another") } diff --git a/man/new_join_keys.Rd b/man/new_join_keys.Rd new file mode 100644 index 000000000..4fa64a9c8 --- /dev/null +++ b/man/new_join_keys.Rd @@ -0,0 +1,15 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{new_join_keys} +\alias{new_join_keys} +\title{Internal constructor} +\usage{ +new_join_keys() +} +\value{ +an empty \code{JoinKeys} list +} +\description{ +Internal constructor +} +\keyword{internal} diff --git a/man/parents.Rd b/man/parents.Rd new file mode 100644 index 000000000..8956145e8 --- /dev/null +++ b/man/parents.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parents.R +\name{parents} +\alias{parents} +\alias{parents.Placeholder} +\alias{parents<-} +\alias{parents<-.Placeholder} +\alias{parents[} +\alias{parents[.Placeholder} +\alias{parents[[<-} +\alias{parents[<-} +\alias{parents[<-.Placeholder} +\title{A name} +\usage{ +parents(join_keys_obj) + +\method{parents}{Placeholder}(join_keys_obj) + +parents(join_keys_obj) <- value + +\method{parents}{Placeholder}(join_keys_obj) <- value + +`parents[`(join_keys_obj, dataset) + +\method{parents[}{Placeholder}(join_keys_obj, dataset) + +`parents[[`(join_keys_obj, dataset) <- value + +`parents[`(join_keys_obj, dataset) <- value + +\method{parents[}{Placeholder}(join_keys_obj, dataset) <- value +} +\description{ +A name +} +\examples{ +jk <- new_join_keys() +parents(jk) +jk <- new_join_keys() +parents(jk) <- list(ADSL = "ADTTE") +jk <- new_join_keys() +parents(jk)["ADTTE"] <- "ADSL" +jk <- new_join_keys() +parents(jk)["ADTTE"] <- "ADSL" +parents(jk)[["YADA"]] +jk <- new_join_keys() +parents(jk)["ADTTE"] <- "ADSL" +} diff --git a/man/print.Placeholder.Rd b/man/print.Placeholder.Rd new file mode 100644 index 000000000..71ccad877 --- /dev/null +++ b/man/print.Placeholder.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{print.Placeholder} +\alias{print.Placeholder} +\title{Prints \code{JoinKeys}.} +\usage{ +\method{print}{Placeholder}(x, ...) +} +\arguments{ +\item{...}{additional arguments to the printing method} +} +\value{ +the \code{x} parameter +} +\description{ +Prints \code{JoinKeys}. +} diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd new file mode 100644 index 000000000..50af6fb5f --- /dev/null +++ b/man/split_join_keys.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{split_join_keys} +\alias{split_join_keys} +\title{Split the \code{JoinKeys} object into a named list of join keys objects with an +element for each dataset} +\usage{ +split_join_keys(keys) +} +\value{ +(\code{list}) a list of \code{JoinKeys} object +} +\description{ +Split the \code{JoinKeys} object into a named list of join keys objects with an +element for each dataset +} +\examples{ +jk <- new_join_keys() +jk["ds1", "ds2"] <- "some_col" +jk["ds1", "ds3"] <- "new_col" +split_join_keys(jk) +} diff --git a/man/sub-.Placeholder.Rd b/man/sub-.Placeholder.Rd new file mode 100644 index 000000000..f5052abea --- /dev/null +++ b/man/sub-.Placeholder.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/new_join_keys.R +\name{[.Placeholder} +\alias{[.Placeholder} +\alias{[<-.Placeholder} +\title{Getter for JoinKeys that returns the relationship between pairs of datasets} +\usage{ +\method{[}{Placeholder}(x, dataset_1, dataset_2 = NULL) + +\method{[}{Placeholder}(data, dataset_1, dataset_2 = NULL) <- value +} +\arguments{ +\item{x}{JoinKeys object to extract the join keys} + +\item{dataset_1}{(\code{character}) name of first dataset.} + +\item{dataset_2}{(\code{character}) name of second dataset.} + +\item{keys}{value to assign} +} +\description{ +Getter for JoinKeys that returns the relationship between pairs of datasets +} +\examples{ +jk <- new_join_keys() +join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +jk["ds1", "ds2"] +jk <- new_join_keys() +jk["ds1", "ds2"] +join_keys(jk) <- join_key("ds1", "ds2", "some_col") +jk["ds1", "ds2"] +jk["ds1", "ds2"] <- "new_col" +jk["ds1", "ds2"] +} +\keyword{internal} From 863933ec3085d28be91a51f30445750d933394ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 10:49:07 +0100 Subject: [PATCH 002/152] improves on parents and JoinKeys compatibility --- NAMESPACE | 5 --- R/JoinKeys.R | 23 +++-------- R/new_join_keys.R | 4 +- R/parents.R | 75 +++++++++++++++------------------- man/check_parent_child.Rd | 18 ++++++++ man/parents.Rd | 20 --------- man/sub-.Placeholder.Rd | 4 +- tests/testthat/test-JoinKeys.R | 4 +- tests/testthat/test-parents.R | 53 ++++++++++++++++++++++++ 9 files changed, 115 insertions(+), 91 deletions(-) create mode 100644 man/check_parent_child.Rd create mode 100644 tests/testthat/test-parents.R diff --git a/NAMESPACE b/NAMESPACE index 7f3980cd9..b40aedf96 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,8 +8,6 @@ S3method("get_join_keys<-",JoinKeys) S3method("get_join_keys<-",teal_data) S3method("join_keys<-",Placeholder) S3method("parents<-",Placeholder) -S3method("parents[",Placeholder) -S3method("parents[<-",Placeholder) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(dataset,MultiAssayExperiment) @@ -78,9 +76,6 @@ export("data_label<-") export("datanames<-") export("get_join_keys<-") export("parents<-") -export("parents[") -export("parents[<-") -export("parents[[<-") export(as_cdisc) export(callable_code) export(callable_function) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 44604a46a..f329f919c 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -31,13 +31,14 @@ JoinKeys <- R6::R6Class( # nolint #' @return empty (`JoinKeys`) initialize = function() { logger::log_trace("JoinKeys initialized.") + class(private$.keys) <- class(new_join_keys()) return(invisible(self)) }, #' @description #' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset #' @return (`list`) a list of `JoinKeys` object split = function() { - split_join_keys(self) + split_join_keys(self$get()) }, #' @description #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object @@ -45,7 +46,6 @@ JoinKeys <- R6::R6Class( # nolint #' @return (`self`) invisibly for chaining merge = function(x) { result <- merge_join_keys(self, x) - class(result) <- "list" private$.keys <- result }, #' @description @@ -56,11 +56,7 @@ JoinKeys <- R6::R6Class( # nolint #' @details if one or both of `dataset_1` and `dataset_2` are missing then #' underlying keys structure is returned for further processing get = function(dataset_1, dataset_2) { - new_keys <- private$.keys - class(new_keys) <- "Placeholder" - res <- get_join_key(new_keys, dataset_1, dataset_2) - if (checkmate::test_class(res, "Placeholder")) class(res) <- "list" - res + get_join_key(private$.keys, dataset_1, dataset_2) }, #' @description #' Change join_keys for a given pair of dataset names (or @@ -68,12 +64,7 @@ JoinKeys <- R6::R6Class( # nolint #' @param val (named `character`) column names used to join #' @return (`self`) invisibly for chaining mutate = function(dataset_1, dataset_2, val) { - new_keys <- private$.keys - class(new_keys) <- "Placeholder" - res <- mutate_join_keys(new_keys, dataset_1, dataset_2, val) - class(res) <- "list" - - private$.keys <- res + private$.keys <- mutate_join_keys(private$.keys, dataset_1, dataset_2, val) return(invisible(self)) }, #' @description @@ -84,11 +75,7 @@ JoinKeys <- R6::R6Class( # nolint #' to be specified once #' @return (`self`) invisibly for chaining set = function(x) { - jk <- private$.keys - class(jk) <- c("Placeholder", "list") - join_keys(jk) <- x - class(jk) <- "list" - private$.keys <- jk + join_keys(private$.keys) <- x return(invisible(self)) }, #' @description diff --git a/R/new_join_keys.R b/R/new_join_keys.R index b20e45ba6..a1334cf9a 100644 --- a/R/new_join_keys.R +++ b/R/new_join_keys.R @@ -141,7 +141,7 @@ split_join_keys <- function(keys) { if (checkmate::test_class(keys, "JoinKeys")) { keys <- keys$get() - class(keys) <- "Placeholder" + class(keys) <- c("Placeholder", "list") } list_of_list_of_join_key_set <- lapply( @@ -178,7 +178,7 @@ split_join_keys <- function(keys) { merge_join_keys <- function(keys_1, keys_2) { if (checkmate::test_class(keys_1, "JoinKeys")) { keys_1 <- keys_1$get() - class(keys_1) <- "Placeholder" + class(keys_1) <- c("Placeholder", "list") } checkmate::assert_multi_class(keys_1, c("JoinKeys", "Placeholder")) diff --git a/R/parents.R b/R/parents.R index 545b590a5..6b4d1db47 100644 --- a/R/parents.R +++ b/R/parents.R @@ -28,56 +28,45 @@ parents.Placeholder <- function(join_keys_obj) { #' jk <- new_join_keys() #' parents(jk)["ADTTE"] <- "ADSL" `parents<-.Placeholder` <- function(join_keys_obj, value) { + if (missing(value)) { + return(join_keys_obj) + } checkmate::assert_list(value, types = "character", names = "named", min.len = 1) attr(join_keys_obj, "__parents__") <- value join_keys_obj } +# ----------------------------------------------------------------------------- +# +# Helpers (non-exported) -#' @rdname parents -#' @export -#' @examples -`parents[` <- function(join_keys_obj, dataset) { - UseMethod("parents[", join_keys_obj) -} - -#' @rdname parents -#' @export -#' @examples -#' jk <- new_join_keys() -#' parents(jk)["ADTTE"] <- "ADSL" -#' parents(jk)["YADA"] -`parents[.Placeholder` <- function(join_keys_obj, dataset) { - checkmate::assert_list(dataset, min.len = 1, names = "named") - res <- attr(join_keys_obj, "__parents__")[[dataset]] - if (is.null(res)) { - return(NULL) - } - res -} - -#' @rdname parents -#' @export -`parents[[<-` <- function(join_keys_obj, dataset, value) { - UseMethod("parent[<-", join_keys_obj) -} - -#' @rdname parents -#' @export -`parents[<-` <- function(join_keys_obj, dataset, value) { - UseMethod("parent[<-", join_keys_obj) -} - -#' @rdname parents -#' @export +#' Check if parent/child are valid +#' +#' @keywords internal #' @examples #' jk <- new_join_keys() -#' parents(jk)["ADTTE"] <- "ADSL" -`parents[<-.Placeholder` <- function(join_keys_obj, dataset, value) { - checkmate::assert_character(dataset, min.len = 1) - if (is.null(attr(join_keys_obj, "__parents__"))) { - attr(join_keys_obj, "__parents__") <- list() +#' jk["ds1", "ds2"] <- character(0) +#' parents(jk) <- list(ds1 = "ds2") +#' check_parent_child(jk) +check_parent_child <- function(join_keys_obj) { + jk_parents <- parents(join_keys_obj) + if (length(jk_parents) > 0) { + for (idx1 in seq_along(jk_parents)) { + name_from <- names(jk_parents)[[idx1]] + for (idx2 in seq_along(jk_parents[[idx1]])) { + name_to <- jk_parents[[idx1]][[idx2]] + keys_from <- join_keys_obj[name_from, name_to] + keys_to <- join_keys_obj[name_to, name_from] + if (length(keys_from) == 0 && length(keys_to) == 0) { + stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) + } + if (length(keys_from) == 0) { + stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to)) + } + if (length(keys_to) == 0) { + stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from)) + } + } + } } - attr(join_keys_obj, "__parents__") <- dataset - join_keys_obj } diff --git a/man/check_parent_child.Rd b/man/check_parent_child.Rd new file mode 100644 index 000000000..b915aec2f --- /dev/null +++ b/man/check_parent_child.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parents.R +\name{check_parent_child} +\alias{check_parent_child} +\title{Check if parent/child are valid} +\usage{ +check_parent_child(join_keys_obj) +} +\description{ +Check if parent/child are valid +} +\examples{ +jk <- new_join_keys() +jk["ds1", "ds2"] <- character(0) +parents(jk) <- list(ds1 = "ds2") +check_parent_child(jk) +} +\keyword{internal} diff --git a/man/parents.Rd b/man/parents.Rd index 8956145e8..2afa12416 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -5,11 +5,6 @@ \alias{parents.Placeholder} \alias{parents<-} \alias{parents<-.Placeholder} -\alias{parents[} -\alias{parents[.Placeholder} -\alias{parents[[<-} -\alias{parents[<-} -\alias{parents[<-.Placeholder} \title{A name} \usage{ parents(join_keys_obj) @@ -19,16 +14,6 @@ parents(join_keys_obj) parents(join_keys_obj) <- value \method{parents}{Placeholder}(join_keys_obj) <- value - -`parents[`(join_keys_obj, dataset) - -\method{parents[}{Placeholder}(join_keys_obj, dataset) - -`parents[[`(join_keys_obj, dataset) <- value - -`parents[`(join_keys_obj, dataset) <- value - -\method{parents[}{Placeholder}(join_keys_obj, dataset) <- value } \description{ A name @@ -40,9 +25,4 @@ jk <- new_join_keys() parents(jk) <- list(ADSL = "ADTTE") jk <- new_join_keys() parents(jk)["ADTTE"] <- "ADSL" -jk <- new_join_keys() -parents(jk)["ADTTE"] <- "ADSL" -parents(jk)[["YADA"]] -jk <- new_join_keys() -parents(jk)["ADTTE"] <- "ADSL" } diff --git a/man/sub-.Placeholder.Rd b/man/sub-.Placeholder.Rd index f5052abea..3dd1c25b0 100644 --- a/man/sub-.Placeholder.Rd +++ b/man/sub-.Placeholder.Rd @@ -5,9 +5,9 @@ \alias{[<-.Placeholder} \title{Getter for JoinKeys that returns the relationship between pairs of datasets} \usage{ -\method{[}{Placeholder}(x, dataset_1, dataset_2 = NULL) +\method{[}{Placeholder}(x, dataset_1, dataset_2 = dataset_1) -\method{[}{Placeholder}(data, dataset_1, dataset_2 = NULL) <- value +\method{[}{Placeholder}(data, dataset_1, dataset_2 = dataset_1) <- value } \arguments{ \item{x}{JoinKeys object to extract the join keys} diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R index 72b300ae4..2ca70db44 100644 --- a/tests/testthat/test-JoinKeys.R +++ b/tests/testthat/test-JoinKeys.R @@ -513,7 +513,9 @@ testthat::test_that("JoinKeys$merge merges mutually exclusive data", { ) z <- JoinKeys$new() z$merge(list(x, y)) - testthat::expect_identical(c(x$get(), y$get()), z$get()) + manual_join <- c(x$get(), y$get()) + class(manual_join) <- class(new_join_keys()) + testthat::expect_identical(manual_join, z$get()) x$merge(y) y$merge(x) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R new file mode 100644 index 000000000..5fc1fa31c --- /dev/null +++ b/tests/testthat/test-parents.R @@ -0,0 +1,53 @@ +test_that("parents will return empty list when empty/not set", { + jk <- new_join_keys() + expect_identical(parents(jk), list()) +}) + +test_that("parents will return empty NULL when there is no parent", { + jk <- new_join_keys() + expect_null(parents(jk)[["ds1"]]) +}) + +test_that("parents<- will add to parents attribute using `[` notation", { + jk <- new_join_keys() + parents(jk)["ds1"] <- "ds2" + parents(jk)["ds3"] <- "ds4" + + expect_length(parents(jk), 2) + expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) +}) + +test_that("parents<- will add to parents attribute using `[[` notation", { + jk <- new_join_keys() + parents(jk)[["ds1"]] <- "ds2" + parents(jk)[["ds3"]] <- "ds4" + + expect_length(parents(jk), 2) + expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) +}) + +test_that("check_parent_child will detect empty keys", { + jk <- new_join_keys() + jk["ds1", "ds2"] <- character(0) + parents(jk) <- list(ds1 = "ds2") + expect_error(check_parent_child(jk)) +}) + +test_that("check_parent_child will detect invalid key pairs", { + jk <- new_join_keys() + jk[["ds1"]][["ds2"]] <- "key1" + jk[["ds2"]][["ds1"]] <- character(0) + parents(jk) <- list(ds1 = "ds2") + expect_error(check_parent_child(jk)) + + jk <- new_join_keys() + jk[["ds2"]][["ds1"]] <- "key1" + jk[["ds1"]][["ds2"]] <- character(0) + parents(jk) <- list(ds1 = "ds2") + expect_error(check_parent_child(jk)) +}) + +test_that("check_parent_child will skip empty JoinKeys", { + jk <- new_join_keys() + expect_silent(check_parent_child(jk)) +}) From 71f4ecaa8a2fd2c5360c56e2935922b72dac0cde Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 11:44:11 +0100 Subject: [PATCH 003/152] JoinKeys fully migrated to list-based joinkeys --- R/JoinKeys.R | 82 +++--------------------------- R/new_join_keys.R | 94 +++++++++++++++++++++++++++++++++++ R/parents.R | 21 +++++++- tests/testthat/test-parents.R | 18 +++++++ 4 files changed, 138 insertions(+), 77 deletions(-) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index f329f919c..fdfc36ef3 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -93,20 +93,7 @@ JoinKeys <- R6::R6Class( # nolint #' #' @return (`self`) invisibly for chaining set_parents = function(named_list) { - for (dataset in names(named_list)) { - checkmate::assert( - checkmate::check_null(self$get_parent(dataset)), - checkmate::check_true( - length(self$get_parent(dataset)) == 0 && - length(named_list[[dataset]]) == 0 - ), - checkmate::check_true(self$get_parent(dataset) == named_list[[dataset]]), - "Please check the difference between provided datasets parents and provided join_keys parents." - ) - if (is.null(self$get_parent(dataset))) { - private$parents[[dataset]] <- named_list[[dataset]] - } - } + parents(private$.keys) <- named_list invisible(self) }, #' @description @@ -118,53 +105,21 @@ JoinKeys <- R6::R6Class( # nolint if (missing(dataname)) { return(NULL) } - private$parents[[dataname]] + parents(private$.keys)[[dataname]] }, #' @description #' Gets the parents of the datasets. #' #' @return (`list`) A named list of the parents of all datasets get_parents = function() { - private$parents + parents(private$.keys) }, #' @description #' Updates the keys of the datasets based on the parents. #' #' @return (`self`) invisibly for chaining update_keys_given_parents = function() { - datanames <- names(self$get()) - duplicate_pairs <- list() - for (d1 in datanames) { - d1_pk <- self$get(d1, d1) - d1_parent <- self$get_parent(d1) - for (d2 in datanames) { - if (paste(d2, d1) %in% duplicate_pairs) { - next - } - if (length(self$get(d1, d2)) == 0) { - d2_parent <- self$get_parent(d2) - d2_pk <- self$get(d2, d2) - - fk <- if (identical(d1, d2_parent)) { - # first is parent of second -> parent keys -> first keys - d1_pk - } else if (identical(d1_parent, d2)) { - # second is parent of first -> parent keys -> second keys - d2_pk - } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { - # both has the same parent -> parent keys - self$get(d1_parent, d1_parent) - } else { - # cant find connection - leave empty - next - } - self$mutate(d1, d2, fk) - duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) - } - } - } - # check parent child relation - private$check_parent_child() + private$.keys <- update_keys_given_parents(private$.keys) invisible(self) } @@ -172,34 +127,9 @@ JoinKeys <- R6::R6Class( # nolint ## __Private Fields ==== private = list( .keys = list(), - parents = list(), - join_pair = function(join_key) { - res <- join_pair(self, join_key) - class(res) <- "list" - private$.keys <- res - }, - # checks the parent child relations are valid check_parent_child = function() { - if (!is.null(self$get_parents())) { - parents <- self$get_parents() - for (idx1 in seq_along(parents)) { - name_from <- names(parents)[[idx1]] - for (idx2 in seq_along(parents[[idx1]])) { - name_to <- parents[[idx1]][[idx2]] - keys_from <- self$get(name_from, name_to) - keys_to <- self$get(name_to, name_from) - if (length(keys_from) == 0 && length(keys_to) == 0) { - stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) - } - if (length(keys_from) == 0) { - stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to)) - } - if (length(keys_to) == 0) { - stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from)) - } - } - } - } + # Needed for a single test + assert_parent_child(private$.keys) } ) ) diff --git a/R/new_join_keys.R b/R/new_join_keys.R index a1334cf9a..30c3f0df9 100644 --- a/R/new_join_keys.R +++ b/R/new_join_keys.R @@ -199,6 +199,55 @@ merge_join_keys <- function(keys_1, keys_2) { return(new_keys) } +#' Updates the keys of the datasets based on the parents. +#' +#' @return (`self`) invisibly for chaining +#' +#' @export +#' +#' @examples +update_keys_given_parents <- function(join_keys_obj) { + jk <- join_keys(join_keys_obj) + + checkmate::assert_class(jk, "Placeholder", .var.name = vname(join_keys_obj)) + + datanames <- names(jk) + duplicate_pairs <- list() + for (d1 in datanames) { + d1_pk <- jk[d1, d1] + d1_parent <- parents(jk)[[d1]] + for (d2 in datanames) { + if (paste(d2, d1) %in% duplicate_pairs) { + next + } + if (length(jk[d1, d2]) == 0) { + d2_parent <- parents(jk)[[d2]] + d2_pk <- jk[d2, d2] + + fk <- if (identical(d1, d2_parent)) { + # first is parent of second -> parent keys -> first keys + d1_pk + } else if (identical(d1_parent, d2)) { + # second is parent of first -> parent keys -> second keys + d2_pk + } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { + # both has the same parent -> parent keys + jk[d1_parent, d1_parent] + } else { + # cant find connection - leave empty + next + } + jk <- mutate_join_keys(jk, d1, d2, fk) + duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) + } + } + } + # check parent child relation + assert_parent_child(join_keys_obj = jk) + + jk +} + #' Prints `JoinKeys`. #' #' @param ... additional arguments to the printing method @@ -296,6 +345,17 @@ join_pair <- function(join_keys_obj, join_key_obj) { join_keys_obj } +#' Check the JoinKeys class membership of an argument +#' @inheritParams checkmate::assert_class +#' @param extra_classes (`character` vector) with extra classes to check. Can be used +#' +#' @return `x` invisibly +#' +#' @keywords internal +assert_join_keys <- function(x, .var.name = checkmate::vname(x)) { + checkmate::assert_class(x, classes = c("Placeholder"), .var.name = .var.name) +} + #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise @@ -335,3 +395,37 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { # otherwise they are compatible return(TRUE) } + +#' Helper function checks the parent-child relations are valid +#' +#' @param join_keys_obj (`JoinKeys`) object to assert validity of relations +#' +#' @return `join_keys_obj` invisibly +#' +assert_parent_child <- function(join_keys_obj) { + jk <- join_keys(join_keys_obj) + jk_parents <- parents(jk) + + assert_join_keys(jk) + + if (!is.null(jk_parents)) { + for (idx1 in seq_along(jk_parents)) { + name_from <- names(jk_parents)[[idx1]] + for (idx2 in seq_along(jk_parents[[idx1]])) { + name_to <- jk_parents[[idx1]][[idx2]] + keys_from <- jk[name_from, name_to] + keys_to <- jk[name_to, name_from] + if (length(keys_from) == 0 && length(keys_to) == 0) { + stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) + } + if (length(keys_from) == 0) { + stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to)) + } + if (length(keys_to) == 0) { + stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from)) + } + } + } + } + invisible(join_keys_obj) +} diff --git a/R/parents.R b/R/parents.R index 6b4d1db47..ec0c43d91 100644 --- a/R/parents.R +++ b/R/parents.R @@ -26,13 +26,32 @@ parents.Placeholder <- function(join_keys_obj) { #' @export #' @examples #' jk <- new_join_keys() +#' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") #' parents(jk)["ADTTE"] <- "ADSL" +#' parents(jk)["ADTTE"] <- "ADSL2" `parents<-.Placeholder` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } checkmate::assert_list(value, types = "character", names = "named", min.len = 1) - attr(join_keys_obj, "__parents__") <- value + new_parents <- attr(join_keys_obj, "__parents__") + + for (dataset in names(value)) { + parent <- new_parents[[dataset]] + checkmate::assert( + checkmate::check_null(parent), + checkmate::check_true( + length(parent) == 0 && + length(value[[dataset]]) == 0 + ), + checkmate::check_true(parent == value[[dataset]]), + "Please check the difference between provided datasets parents and provided join_keys parents." + ) + if (is.null(parent)) { + new_parents[[dataset]] <- value[[dataset]] + } + } + attr(join_keys_obj, "__parents__") <- new_parents join_keys_obj } diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 5fc1fa31c..6bdbfc399 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -26,6 +26,24 @@ test_that("parents<- will add to parents attribute using `[[` notation", { expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) }) +test_that("parents<- will add to parents attribute using list", { + jk <- new_join_keys() + parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") + + expect_length(parents(jk), 2) + expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) +}) + +test_that("parents<- will add to parents attribute using list, `[` and `[[` notation", { + jk <- new_join_keys() + parents(jk)[["ds1"]] <- "ds2" + parents(jk) <- list(ds3 = "ds4", "ds5" = "ds6") + parents(jk)["ds7"] <- "ds8" + + expect_length(parents(jk), 4) + expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4", ds5 = "ds6", ds7 = "ds8")) +}) + test_that("check_parent_child will detect empty keys", { jk <- new_join_keys() jk["ds1", "ds2"] <- character(0) From a65cbc5bd8b95976af84b0144d7069d8dcc19844 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 12:41:24 +0100 Subject: [PATCH 004/152] docs: rename file and improves docs --- NAMESPACE | 1 + R/{new_join_keys.R => join_keys.R} | 76 ++++++++++++++++++++---------- man/assert_compatible_keys.Rd | 2 +- man/assert_join_keys.Rd | 25 ++++++++++ man/assert_parent_child.Rd | 17 +++++++ man/get_join_key.Rd | 2 +- man/get_keys.Rd | 16 +------ man/join_keys.Rd | 51 +++++++++++++++++++- man/join_pair.Rd | 2 +- man/merge_join_keys.Rd | 2 +- man/mutate_join_keys.Rd | 2 +- man/new_join_keys.Rd | 2 +- man/parents.Rd | 2 + man/print.Placeholder.Rd | 2 +- man/split_join_keys.Rd | 2 +- man/sub-.Placeholder.Rd | 35 -------------- man/update_keys_given_parents.Rd | 14 ++++++ 17 files changed, 168 insertions(+), 85 deletions(-) rename R/{new_join_keys.R => join_keys.R} (86%) create mode 100644 man/assert_join_keys.Rd create mode 100644 man/assert_parent_child.Rd delete mode 100644 man/sub-.Placeholder.Rd create mode 100644 man/update_keys_given_parents.Rd diff --git a/NAMESPACE b/NAMESPACE index b40aedf96..373c84cfa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -141,6 +141,7 @@ export(split_join_keys) export(teal_data) export(teal_data_file) export(to_relational_data) +export(update_keys_given_parents) export(validate_metadata) import(shiny) import(teal.code) diff --git a/R/new_join_keys.R b/R/join_keys.R similarity index 86% rename from R/new_join_keys.R rename to R/join_keys.R index 30c3f0df9..705dcf6be 100644 --- a/R/new_join_keys.R +++ b/R/join_keys.R @@ -1,17 +1,23 @@ -#' Setter for join keys +#' @details +#' The setter assignment `join_keys() <- ...` will only work for an empty +#' `JoinKey` object, otherwise `mutate_join_keys()` must be used. +#' @rdname join_keys #' -#' @param data (`JoinKeys`) empty object to set the new relationship pairs. +#' @param join_keys_obj (`JoinKeys`) empty object to set the new relationship pairs. #' @param value (`JoinKeySet` or list of `JoinKeySet`) relationship pairs to add #' to `JoinKeys` list. -#' -#' @rdname get_keys `join_keys<-` <- function(join_keys_obj, value) { UseMethod("join_keys<-", join_keys_obj) } -#' @rdname get_keys +#' @details +#' The setter assignment `join_keys() <- ...` will only work for an empty +#' `JoinKey` object, otherwise `mutate_join_keys()` must be used. +#' +#' @rdname join_keys #' @export #' @examples +#' # Using the setter (assignment) #' jk <- new_join_keys() #' join_keys(jk) #' join_keys(jk) <- join_key("ds1", "ds2", "some_col2") @@ -41,48 +47,66 @@ join_keys_obj } -#' @title Getter for JoinKeys that returns the relationship between pairs of datasets -#' @param x JoinKeys object to extract the join keys +#' @details +#' Getter for JoinKeys that returns the relationship between pairs of datasets. +#' +#' @rdname join_keys +#' +#' @param join_keys_obj (`JoinKeys`) object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. #' @param dataset_2 (`character`) name of second dataset. #' #' @export #' #' @examples +#' # Getter for JoinKeys #' jk <- new_join_keys() -#' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' jk["ds1", "ds2"] -`[.Placeholder` <- function(x, dataset_1, dataset_2 = dataset_1) { +#' jk["ds1"] +#' jk[["ds1"]] +`[.Placeholder` <- function(join_keys_obj, dataset_1, dataset_2 = NULL) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2, null.ok = TRUE) - x[[dataset_1]][[dataset_2]] + if (is.null(dataset_2)) { + return(join_keys_obj[[dataset_1]]) + } + join_keys_obj[[dataset_1]][[dataset_2]] } -#' @rdname sub-.Placeholder -#' @param keys value to assign +#' @details +#' Setter via index directly (bypassing the need to use `join_key()`). +#' When `dataset_2` is omitted, it will create a primary key with `dataset_2 = dataset_1`. +#' +#' @rdname join_keys +#' +#' @param value (`character` vector) value to assign. +#' #' @export -#' @keywords internal +#' #' @examples +#' # Setter via index #' jk <- new_join_keys() -#' jk["ds1", "ds2"] -#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") -#' jk["ds1", "ds2"] -#' jk["ds1", "ds2"] <- "new_col" -#' jk["ds1", "ds2"] -`[<-.Placeholder` <- function(data, dataset_1, dataset_2 = dataset_1, value) { +#' join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") +#' # overwrites previously defined key +#' jk["ds1", "ds2"] <- "(new) pair key" +#' # Creates primary key by only defining `dataset_1` +#' jk["ds1"] <- "primary_key" +#' jk +`[<-.Placeholder` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2, null.ok = TRUE) - if (is.null(data[[dataset_1]])) data[[dataset_1]] <- list() + if (is.null(join_keys_obj[[dataset_1]])) join_keys_obj[[dataset_1]] <- list() - data[[dataset_1]][[dataset_2]] <- value + join_keys_obj[[dataset_1]][[dataset_2]] <- value if (identical(dataset_1, dataset_2)) { - return(data) + return(join_keys_obj) } - if (is.null(data[[dataset_2]])) data[[dataset_2]] <- list() + if (is.null(join_keys_obj[[dataset_2]])) join_keys_obj[[dataset_2]] <- list() if ( checkmate::test_character(value, min.len = 1) && @@ -96,9 +120,9 @@ value <- setNames(names(value), value) } - data[[dataset_2]][[dataset_1]] <- value + join_keys_obj[[dataset_2]][[dataset_1]] <- value - data + join_keys_obj } #' @rdname mutate_join_keys @@ -162,7 +186,7 @@ split_join_keys <- function(keys) { #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object #' -#' @param keys_1 `JoinKeys` object +#' @param keys_1 (`JoinKeys`) object to merge keys_1 #' @param keys_2 `list` of `JoinKeys` objects or single `JoinKeys` object #' #' @return (`JoinKeys`) a new object with the resulting merge diff --git a/man/assert_compatible_keys.Rd b/man/assert_compatible_keys.Rd index e7b9751bb..2502996d2 100644 --- a/man/assert_compatible_keys.Rd +++ b/man/assert_compatible_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{assert_compatible_keys} \alias{assert_compatible_keys} \title{Helper function to assert if two key sets contain incompatible keys} diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd new file mode 100644 index 000000000..d4dffaa3d --- /dev/null +++ b/man/assert_join_keys.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{assert_join_keys} +\alias{assert_join_keys} +\title{Check the JoinKeys class membership of an argument} +\usage{ +assert_join_keys(x, .var.name = checkmate::vname(x)) +} +\arguments{ +\item{x}{[any]\cr +Object to check.} + +\item{.var.name}{[\code{character(1)}]\cr +Name of the checked object to print in assertions. Defaults to +the heuristic implemented in \code{\link[checkmate]{vname}}.} + +\item{extra_classes}{(\code{character} vector) with extra classes to check. Can be used} +} +\value{ +\code{x} invisibly +} +\description{ +Check the JoinKeys class membership of an argument +} +\keyword{internal} diff --git a/man/assert_parent_child.Rd b/man/assert_parent_child.Rd new file mode 100644 index 000000000..6200b646b --- /dev/null +++ b/man/assert_parent_child.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{assert_parent_child} +\alias{assert_parent_child} +\title{Helper function checks the parent-child relations are valid} +\usage{ +assert_parent_child(join_keys_obj) +} +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object to assert validity of relations} +} +\value{ +\code{join_keys_obj} invisibly +} +\description{ +Helper function checks the parent-child relations are valid +} diff --git a/man/get_join_key.Rd b/man/get_join_key.Rd index 2b31c51a3..3c842ce73 100644 --- a/man/get_join_key.Rd +++ b/man/get_join_key.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{get_join_key} \alias{get_join_key} \title{Get value of a single relationship pair} diff --git a/man/get_keys.Rd b/man/get_keys.Rd index 63996f7e8..447871856 100644 --- a/man/get_keys.Rd +++ b/man/get_keys.Rd @@ -1,12 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_keys.R, R/new_join_keys.R +% Please edit documentation in R/get_keys.R \name{get_keys} \alias{get_keys} \alias{get_keys.TealDataset} \alias{get_keys.TealDatasetConnector} \alias{get_keys.TealDataAbstract} -\alias{join_keys<-} -\alias{join_keys<-.Placeholder} \title{Get dataset primary keys} \usage{ get_keys(x, ...) @@ -16,10 +14,6 @@ get_keys(x, ...) \method{get_keys}{TealDatasetConnector}(x, ...) \method{get_keys}{TealDataAbstract}(x, dataname, ...) - -join_keys(join_keys_obj) <- value - -\method{join_keys}{Placeholder}(join_keys_obj) <- value } \arguments{ \item{x}{an object of \code{TealDataset} or \code{TealDatasetConnector} class} @@ -27,11 +21,6 @@ join_keys(join_keys_obj) <- value \item{...}{not used, only for support of S3} \item{dataname}{(\code{character}) name of dataset to return keys for} - -\item{value}{(\code{JoinKeySet} or list of \code{JoinKeySet}) relationship pairs to add -to \code{JoinKeys} list.} - -\item{data}{(\code{JoinKeys}) empty object to set the new relationship pairs.} } \value{ (\code{character}) vector of column names @@ -71,7 +60,4 @@ get_keys( ), "x" ) -jk <- new_join_keys() -join_keys(jk) -join_keys(jk) <- join_key("ds1", "ds2", "some_col2") } diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 535d8585f..ad9f27878 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -1,16 +1,36 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R +% Please edit documentation in R/JoinKeys.R, R/join_keys.R \name{join_keys} \alias{join_keys} \alias{cdisc_join_keys} +\alias{join_keys<-} +\alias{join_keys<-.Placeholder} +\alias{[.Placeholder} +\alias{[<-.Placeholder} \title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} \usage{ join_keys(...) cdisc_join_keys(...) + +join_keys(join_keys_obj) <- value + +\method{join_keys}{Placeholder}(join_keys_obj) <- value + +\method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = NULL) + +\method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value } \arguments{ \item{...}{optional, a \code{JoinKeySet} objects created using the \code{join_key} function.} + +\item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} + +\item{value}{(\code{character} vector) value to assign.} + +\item{dataset_1}{(\code{character}) name of first dataset.} + +\item{dataset_2}{(\code{character}) name of second dataset.} } \value{ \code{JoinKeys} @@ -25,6 +45,17 @@ to be specified once. \code{cdisc_join_keys} is a wrapper around \code{join_keys} that sets the default join keys for CDISC datasets. It is used internally by \code{cdisc_data} to set the default join keys for CDISC datasets. + +The setter assignment \code{join_keys() <- ...} will only work for an empty +\code{JoinKey} object, otherwise \code{mutate_join_keys()} must be used. + +The setter assignment \code{join_keys() <- ...} will only work for an empty +\code{JoinKey} object, otherwise \code{mutate_join_keys()} must be used. + +Getter for JoinKeys that returns the relationship between pairs of datasets. + +Setter via index directly (bypassing the need to use \code{join_key()}). +When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. } \examples{ # setting join keys @@ -41,4 +72,22 @@ jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") # default CDISC join keys cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") +# Using the setter (assignment) +jk <- new_join_keys() +join_keys(jk) +join_keys(jk) <- join_key("ds1", "ds2", "some_col2") +# Getter for JoinKeys +jk <- new_join_keys() +join_keys(jk) <- join_key("ds1", "ds2", "some_col") +jk["ds1", "ds2"] +jk["ds1"] +jk[["ds1"]] +# Setter via index +jk <- new_join_keys() +join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") +# overwrites previously defined key +jk["ds1", "ds2"] <- "(new) pair key" +# Creates primary key by only defining `dataset_1` +jk["ds1"] <- "primary_key" +jk } diff --git a/man/join_pair.Rd b/man/join_pair.Rd index 85a29e096..49f971c37 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{join_pair} \alias{join_pair} \title{Helper function to add a new pair to a \code{JoinKeys} object} diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index 97589295a..841c6e382 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{merge_join_keys} \alias{merge_join_keys} \title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index b075abce6..32e8cbc93 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R, R/new_join_keys.R +% Please edit documentation in R/JoinKeys.R, R/join_keys.R \name{mutate_join_keys} \alias{mutate_join_keys} \alias{mutate_join_keys.JoinKeys} diff --git a/man/new_join_keys.Rd b/man/new_join_keys.Rd index 4fa64a9c8..4d8317b19 100644 --- a/man/new_join_keys.Rd +++ b/man/new_join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{new_join_keys} \alias{new_join_keys} \title{Internal constructor} diff --git a/man/parents.Rd b/man/parents.Rd index 2afa12416..2df7da94c 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -24,5 +24,7 @@ parents(jk) jk <- new_join_keys() parents(jk) <- list(ADSL = "ADTTE") jk <- new_join_keys() +parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") parents(jk)["ADTTE"] <- "ADSL" +parents(jk)["ADTTE"] <- "ADSL2" } diff --git a/man/print.Placeholder.Rd b/man/print.Placeholder.Rd index 71ccad877..6a2656639 100644 --- a/man/print.Placeholder.Rd +++ b/man/print.Placeholder.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{print.Placeholder} \alias{print.Placeholder} \title{Prints \code{JoinKeys}.} diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd index 50af6fb5f..891adf1c7 100644 --- a/man/split_join_keys.Rd +++ b/man/split_join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R +% Please edit documentation in R/join_keys.R \name{split_join_keys} \alias{split_join_keys} \title{Split the \code{JoinKeys} object into a named list of join keys objects with an diff --git a/man/sub-.Placeholder.Rd b/man/sub-.Placeholder.Rd deleted file mode 100644 index 3dd1c25b0..000000000 --- a/man/sub-.Placeholder.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/new_join_keys.R -\name{[.Placeholder} -\alias{[.Placeholder} -\alias{[<-.Placeholder} -\title{Getter for JoinKeys that returns the relationship between pairs of datasets} -\usage{ -\method{[}{Placeholder}(x, dataset_1, dataset_2 = dataset_1) - -\method{[}{Placeholder}(data, dataset_1, dataset_2 = dataset_1) <- value -} -\arguments{ -\item{x}{JoinKeys object to extract the join keys} - -\item{dataset_1}{(\code{character}) name of first dataset.} - -\item{dataset_2}{(\code{character}) name of second dataset.} - -\item{keys}{value to assign} -} -\description{ -Getter for JoinKeys that returns the relationship between pairs of datasets -} -\examples{ -jk <- new_join_keys() -join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) -jk["ds1", "ds2"] -jk <- new_join_keys() -jk["ds1", "ds2"] -join_keys(jk) <- join_key("ds1", "ds2", "some_col") -jk["ds1", "ds2"] -jk["ds1", "ds2"] <- "new_col" -jk["ds1", "ds2"] -} -\keyword{internal} diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd new file mode 100644 index 000000000..78348cd90 --- /dev/null +++ b/man/update_keys_given_parents.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{update_keys_given_parents} +\alias{update_keys_given_parents} +\title{Updates the keys of the datasets based on the parents.} +\usage{ +update_keys_given_parents(join_keys_obj) +} +\value{ +(\code{self}) invisibly for chaining +} +\description{ +Updates the keys of the datasets based on the parents. +} From 01985f90646139ae6d30406f30bee3748581f102 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 13:01:55 +0100 Subject: [PATCH 005/152] docs: update docs to standardize use of join_keys_obj varname --- R/JoinKeys.R | 5 +-- R/join_keys.R | 67 +++++++++++++++++++------------- man/merge_join_keys.Rd | 10 +++-- man/split_join_keys.Rd | 2 +- man/update_keys_given_parents.Rd | 16 ++++++++ 5 files changed, 66 insertions(+), 34 deletions(-) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index fdfc36ef3..216e64e18 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -38,15 +38,14 @@ JoinKeys <- R6::R6Class( # nolint #' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset #' @return (`list`) a list of `JoinKeys` object split = function() { - split_join_keys(self$get()) + split_join_keys(private$.keys) }, #' @description #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object #' @param x `list` of `JoinKeys` objects or single `JoinKeys` object #' @return (`self`) invisibly for chaining merge = function(x) { - result <- merge_join_keys(self, x) - private$.keys <- result + private$.keys <- merge_join_keys(private$.keys, x) }, #' @description #' Get join keys between two datasets. diff --git a/R/join_keys.R b/R/join_keys.R index 705dcf6be..a940afe73 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -160,25 +160,20 @@ mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { #' jk["ds1", "ds2"] <- "some_col" #' jk["ds1", "ds3"] <- "new_col" #' split_join_keys(jk) -split_join_keys <- function(keys) { - checkmate::assert_multi_class(keys, classes = c("JoinKeys", "Placeholder")) - - if (checkmate::test_class(keys, "JoinKeys")) { - keys <- keys$get() - class(keys) <- c("Placeholder", "list") - } +split_join_keys <- function(join_keys_obj) { + assert_join_keys(join_keys_obj) list_of_list_of_join_key_set <- lapply( - names(keys), + names(join_keys_obj), function(dataset_1) { lapply( - names(keys[[dataset_1]]), - function(dataset_2) join_key(dataset_1, dataset_2, get_join_key(keys, dataset_1, dataset_2)) + names(join_keys_obj[[dataset_1]]), + function(dataset_2) join_key(dataset_1, dataset_2, get_join_key(join_keys_obj, dataset_1, dataset_2)) ) } ) res <- lapply(list_of_list_of_join_key_set, function(.x) do.call(join_keys, .x)) - names(res) <- names(keys) + names(res) <- names(join_keys_obj) logger::log_trace("JoinKeys keys split.") return(res) @@ -186,50 +181,67 @@ split_join_keys <- function(keys) { #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object #' -#' @param keys_1 (`JoinKeys`) object to merge keys_1 -#' @param keys_2 `list` of `JoinKeys` objects or single `JoinKeys` object +#' @param join_keys_obj (`JoinKeys`) object to merge the new_join_keys. +#' @param new_join_keys `list` of `JoinKeys` objects or single `JoinKeys` object #' -#' @return (`JoinKeys`) a new object with the resulting merge +#' @return a new `JoinKeys` object with the resulting merge. #' #' @export #' #' @examples #' jk1 <- new_join_keys() #' jk1["ds1", "ds2"] <- "some_col" +#' #' jk2 <- new_join_keys() #' jk2["ds1", "ds3"] <- "new_col" +#' #' merge_join_keys(jk1, jk2) -merge_join_keys <- function(keys_1, keys_2) { - if (checkmate::test_class(keys_1, "JoinKeys")) { - keys_1 <- keys_1$get() - class(keys_1) <- c("Placeholder", "list") +merge_join_keys <- function(join_keys_obj, new_join_keys) { + assert_join_keys(join_keys_obj) + + if (inherits(new_join_keys, c("JoinKeys", "Placeholder"))) { + new_join_keys <- list(new_join_keys) } - checkmate::assert_multi_class(keys_1, c("JoinKeys", "Placeholder")) - if (inherits(keys_2, c("JoinKeys", "Placeholder"))) keys_2 <- list(keys_2) - checkmate::assert_list(keys_2, types = c("JoinKeys", "Placeholder"), min.len = 1) + checkmate::assert_list(new_join_keys, types = c("JoinKeys", "Placeholder"), min.len = 1) - new_keys <- keys_1 + result <- join_keys_obj + + for (jk in new_join_keys) { + if (checkmate::test_class(jk, "JoinKeys")) { + jk <- jk$get() + } - for (jk in keys_2) { - if (checkmate::test_class(jk, "JoinKeys")) jk <- jk$get() for (dataset_1 in names(jk)) { for (dataset_2 in names(jk[[dataset_1]])) { - new_keys[dataset_1, dataset_2] <- jk[[dataset_1]][[dataset_2]] + result[dataset_1, dataset_2] <- jk[[dataset_1]][[dataset_2]] } } } logger::log_trace("JoinKeys keys merged.") - return(new_keys) + return(result) } #' Updates the keys of the datasets based on the parents. #' +#' @param join_keys_obj (`JoinKeys`) object to update the keys. +#' #' @return (`self`) invisibly for chaining #' #' @export #' #' @examples +#' jk <- new_join_keys() +#' join_keys(jk) <- list( +#' join_key("df1", "df1", c("id", "id2")), +#' join_key("df1", "df2", c("id" = "id")), +#' join_key("df1", "df3", c("id" = "id")) +#' ) +#' parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") +#' jk2 <- update_keys_given_parents(jk) +#' +#' jk[["df2"]] +#' jk2[["df2"]] update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) @@ -281,12 +293,15 @@ update_keys_given_parents <- function(join_keys_obj) { print.Placeholder <- function(x, ...) { check_ellipsis(...) keys_list <- x + my_parents <- parents(keys_list) class(keys_list) <- "list" if (length(keys_list) > 0) { cat(sprintf( "A JoinKeys object containing foreign keys between %s datasets:\n", length(keys_list) )) + # Hide parents + attr(keys_list, "__parents__") <- NULL print.default(keys_list) } else { cat("An empty JoinKeys object.") diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index 841c6e382..cbb42e9b4 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -4,15 +4,15 @@ \alias{merge_join_keys} \title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} \usage{ -merge_join_keys(keys_1, keys_2) +merge_join_keys(join_keys_obj, new_join_keys) } \arguments{ -\item{keys_1}{\code{JoinKeys} object} +\item{join_keys_obj}{(\code{JoinKeys}) object to merge the new_join_keys.} -\item{keys_2}{\code{list} of \code{JoinKeys} objects or single \code{JoinKeys} object} +\item{new_join_keys}{\code{list} of \code{JoinKeys} objects or single \code{JoinKeys} object} } \value{ -(\code{JoinKeys}) a new object with the resulting merge +a new \code{JoinKeys} object with the resulting merge. } \description{ Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object @@ -20,7 +20,9 @@ Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKe \examples{ jk1 <- new_join_keys() jk1["ds1", "ds2"] <- "some_col" + jk2 <- new_join_keys() jk2["ds1", "ds3"] <- "new_col" + merge_join_keys(jk1, jk2) } diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd index 891adf1c7..70af71a56 100644 --- a/man/split_join_keys.Rd +++ b/man/split_join_keys.Rd @@ -5,7 +5,7 @@ \title{Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset} \usage{ -split_join_keys(keys) +split_join_keys(join_keys_obj) } \value{ (\code{list}) a list of \code{JoinKeys} object diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 78348cd90..8c9fe2bda 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -6,9 +6,25 @@ \usage{ update_keys_given_parents(join_keys_obj) } +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object to update the keys.} +} \value{ (\code{self}) invisibly for chaining } \description{ Updates the keys of the datasets based on the parents. } +\examples{ +jk <- new_join_keys() +join_keys(jk) <- list( + join_key("df1", "df1", c("id", "id2")), + join_key("df1", "df2", c("id" = "id")), + join_key("df1", "df3", c("id" = "id")) +) +parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") +jk2 <- update_keys_given_parents(jk) + +jk[["df2"]] +jk2[["df2"]] +} From 6a1441a4c00013df94e51cdba6dca65f418c9b0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 13:16:50 +0100 Subject: [PATCH 006/152] docs: hard deprecate get_join_keys --- NAMESPACE | 8 +--- R/JoinKeys.R | 4 +- R/get_join_keys.R | 56 +++++---------------------- R/join_keys.R | 22 +++++++++++ R/teal_data-class.R | 2 +- man/get_join_keys.Rd | 22 +++-------- man/mutate_join_keys.Rd | 4 +- man/teal_data-class.Rd | 2 +- tests/testthat/helper-get_join_keys.R | 14 +++---- tests/testthat/test-JoinKeys.R | 8 ++-- tests/testthat/test-cdisc_data.R | 8 ++-- tests/testthat/test-get_join_keys.R | 20 +++++----- tests/testthat/test-teal_data.R | 6 +-- vignettes/join-keys.Rmd | 2 +- 14 files changed, 74 insertions(+), 104 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 373c84cfa..d47b58036 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,9 +4,9 @@ S3method("[",JoinKeys) S3method("[",Placeholder) S3method("[<-",JoinKeys) S3method("[<-",Placeholder) -S3method("get_join_keys<-",JoinKeys) -S3method("get_join_keys<-",teal_data) +S3method("join_keys<-",JoinKeys) S3method("join_keys<-",Placeholder) +S3method("join_keys<-",teal_data) S3method("parents<-",Placeholder) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) @@ -30,10 +30,6 @@ S3method(get_datasets,TealDataAbstract) S3method(get_datasets,TealDataset) S3method(get_datasets,TealDatasetConnector) S3method(get_datasets,teal_data) -S3method(get_join_keys,JoinKeys) -S3method(get_join_keys,TealData) -S3method(get_join_keys,default) -S3method(get_join_keys,teal_data) S3method(get_key_duplicates,TealDataset) S3method(get_key_duplicates,data.frame) S3method(get_keys,TealDataAbstract) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 216e64e18..34dd0c7f3 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -295,10 +295,10 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) { #' cdisc_dataset("ADSL", ADSL), #' cdisc_dataset("ADRS", ADRS) #' ) -#' x$get_join_keys()$get("ADSL", "ADRS") +#' join_keys(x)$get("ADSL", "ADRS") #' #' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -#' x$get_join_keys()$get("ADSL", "ADRS") +#' join_keys(x)$get("ADSL", "ADRS") mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, val) { # nolint x$mutate_join_keys(dataset_1, dataset_2, val) } diff --git a/R/get_join_keys.R b/R/get_join_keys.R index a73a3e12f..11ca23bcb 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -3,31 +3,11 @@ #' @return Either `JoinKeys` object or `NULL` if no join keys #' @export get_join_keys <- function(data) { - UseMethod("get_join_keys", data) -} - -#' @rdname get_join_keys -#' @export -get_join_keys.default <- function(data) { - stop("get_join_keys function not implemented for object of class ", toString(class(data))) -} - -#' @rdname get_join_keys -#' @export -get_join_keys.teal_data <- function(data) { - data@join_keys -} - -#' @rdname get_join_keys -#' @export -get_join_keys.JoinKeys <- function(data) { - data -} - -#' @rdname get_join_keys -#' @export -get_join_keys.TealData <- function(data) { - data$get_join_keys() + lifecycle::deprecate_stop( + when = " 0.3.1", + what = "get_join_keys(data)", + details = "Use `join_keys(data)` instead." + ) } #' @rdname get_join_keys @@ -35,25 +15,9 @@ get_join_keys.TealData <- function(data) { #' @param value value to assign #' @export `get_join_keys<-` <- function(data, dataset_1, dataset_2 = NULL, value) { - UseMethod("get_join_keys<-", data) -} - - -#' @rdname get_join_keys -#' @inheritParams mutate_join_keys -#' @export -`get_join_keys<-.JoinKeys` <- function(data, dataset_1, dataset_2 = NULL, value) { - # The reason this passthrough method is defined is to prevent a warning message - # The assignment is performed by `get_join_keys.JoinKeys` and `[<-.JoinKeys` combination - # as well as `JoinKeys` being an R6 class - data -} - -#' @rdname get_join_keys -#' @export -`get_join_keys<-.teal_data` <- function(data, dataset_1, dataset_2 = NULL, value) { - # The reason this passthrough method is defined is to prevent a warning message - # The assignment is performed by `get_join_keys.teal_data` and `[<-.JoinKeys` combination - # as well as `JoinKeys` being an R6 class - data + lifecycle::deprecate_stop( + when = " 0.3.1", + what = "get_join_keys(data) <- ...", + details = "Use `join_keys(data) <- ...`" + ) } diff --git a/R/join_keys.R b/R/join_keys.R index a940afe73..6f6599650 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -47,6 +47,28 @@ join_keys_obj } + +#' @rdname get_join_keys +#' @inheritParams mutate_join_keys +#' @export +`join_keys<-.JoinKeys` <- function(data, dataset_1, dataset_2 = NULL, value) { + if (missing(dataset_1) || missing(value)) { + return(data) + } + data$mutate(dataset_1, dataset_2, value) + data +} + +#' @rdname get_join_keys +#' @export +`join_keys<-.teal_data` <- function(data, dataset_1, dataset_2 = NULL, value) { + if (missing(dataset_1) || missing(value)) { + return(data) + } + data@join_keys <- mutate_join_keys(data@join_keys, dataset_1, dataset_2, value) + data +} + #' @details #' Getter for JoinKeys that returns the relationship between pairs of datasets. #' diff --git a/R/teal_data-class.R b/R/teal_data-class.R index 1506b1d7c..39efc1c21 100644 --- a/R/teal_data-class.R +++ b/R/teal_data-class.R @@ -26,7 +26,7 @@ setOldClass("JoinKeys") #' Access with [get_warnings()]. #' @slot messages (`character`) messages raised when evaluating code. #' @slot join_keys (`JoinKeys`) object specifying joining keys for data sets in `@env`. -#' Access or modify with [get_join_keys()]. +#' Access or modify with [join_keys()]. #' @slot datanames (`character`) vector of names of data sets in `@env`. #' Used internally to distinguish them from auxiliary variables. #' Access or modify with [datanames()]. diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 4ec725a21..3b97bc437 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -1,31 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_join_keys.R +% Please edit documentation in R/get_join_keys.R, R/join_keys.R \name{get_join_keys} \alias{get_join_keys} -\alias{get_join_keys.default} -\alias{get_join_keys.teal_data} -\alias{get_join_keys.JoinKeys} -\alias{get_join_keys.TealData} \alias{get_join_keys<-} -\alias{get_join_keys<-.JoinKeys} -\alias{get_join_keys<-.teal_data} +\alias{join_keys<-.JoinKeys} +\alias{join_keys<-.teal_data} \title{Function to get join keys from a `` object} \usage{ get_join_keys(data) -\method{get_join_keys}{default}(data) - -\method{get_join_keys}{teal_data}(data) - -\method{get_join_keys}{JoinKeys}(data) - -\method{get_join_keys}{TealData}(data) - get_join_keys(data, dataset_1, dataset_2 = NULL) <- value -\method{get_join_keys}{JoinKeys}(data, dataset_1, dataset_2 = NULL) <- value +\method{join_keys}{JoinKeys}(data, dataset_1, dataset_2 = NULL) <- value -\method{get_join_keys}{teal_data}(data, dataset_1, dataset_2 = NULL) <- value +\method{join_keys}{teal_data}(data, dataset_1, dataset_2 = NULL) <- value } \arguments{ \item{data}{`` - object to extract the join keys} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 32e8cbc93..5f5dcf49e 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -51,10 +51,10 @@ x <- cdisc_data( cdisc_dataset("ADSL", ADSL), cdisc_dataset("ADRS", ADRS) ) -x$get_join_keys()$get("ADSL", "ADRS") +join_keys(x)$get("ADSL", "ADRS") mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -x$get_join_keys()$get("ADSL", "ADRS") +join_keys(x)$get("ADSL", "ADRS") jk <- new_join_keys() join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) mutate_join_keys(jk, "ds2", "ds3", "another") diff --git a/man/teal_data-class.Rd b/man/teal_data-class.Rd index e3fcad4c5..3a56da95d 100644 --- a/man/teal_data-class.Rd +++ b/man/teal_data-class.Rd @@ -36,7 +36,7 @@ Access with \code{\link[=get_warnings]{get_warnings()}}.} \item{\code{messages}}{(\code{character}) messages raised when evaluating code.} \item{\code{join_keys}}{(\code{JoinKeys}) object specifying joining keys for data sets in \verb{@env}. -Access or modify with \code{\link[=get_join_keys]{get_join_keys()}}.} +Access or modify with \code{\link[=join_keys]{join_keys()}}.} \item{\code{datanames}}{(\code{character}) vector of names of data sets in \verb{@env}. Used internally to distinguish them from auxiliary variables. diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index 34bca8a9e..aaefcbf5b 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -20,9 +20,9 @@ helper_generator_JoinKeys <- function(dataset_1 = "ds1", keys = c("id")) { # nol ) } -#' Test suite for default get_join generated by helper -helper_test_get_join_keys <- function(obj, dataset_1 = "ds1") { - jk <- get_join_keys(obj) +#' Test suite for default join_keys generated by helper +helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { + jk <- join_keys(obj) expect_s3_class(jk, c("JoinKey", "R6")) expect_length(jk$get(), 1) @@ -32,11 +32,11 @@ helper_test_get_join_keys <- function(obj, dataset_1 = "ds1") { } #' Test suite for JoinKeys after manual adding a primary key -helper_test_get_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset_1 = "ds2", new_keys = c("id")) { - obj <- helper_test_get_join_keys(obj, dataset_1) - get_join_keys(obj)[new_dataset_1] <- c(new_keys) +helper_test_getter_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset_1 = "ds2", new_keys = c("id")) { + obj <- helper_test_getter_join_keys(obj, dataset_1) + join_keys(obj)[new_dataset_1] <- c(new_keys) - jk <- get_join_keys(obj) + jk <- join_keys(obj) checkmate::expect_r6(jk, c("JoinKeys")) expect_length(jk$get(), 2) diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R index 2ca70db44..c57a4c403 100644 --- a/tests/testthat/test-JoinKeys.R +++ b/tests/testthat/test-JoinKeys.R @@ -655,7 +655,7 @@ testthat::test_that("JoinKeys$check_parent_child throws error if no join_keys ex test_that("cdisc_join_keys will generate JoinKeys for named list with non-named elements", { new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) - jk <- get_join_keys(new_dataset) + jk <- join_keys(new_dataset) expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) @@ -666,7 +666,7 @@ test_that("cdisc_join_keys will generate JoinKeys for named list with non-named test_that("cdisc_join_keys will generate JoinKeys for character list", { new_dataset <- cdisc_join_keys("ADSL", "ADTTE") - jk <- get_join_keys(new_dataset) + jk <- join_keys(new_dataset) expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) @@ -677,7 +677,7 @@ test_that("cdisc_join_keys will generate JoinKeys for character list", { test_that("cdisc_join_keys will generate JoinKeys for named list", { new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) - jk <- get_join_keys(new_dataset) + jk <- join_keys(new_dataset) expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) @@ -738,7 +738,7 @@ test_that("cdisc_join_keys does nothing with TealDataset", { function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) ) adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - expect_length(get_join_keys(cdisc_join_keys(adae_cdc))$get(), 0) + expect_length(join_keys(cdisc_join_keys(adae_cdc))$get(), 0) }) test_that("[.JoinKeys returns the primary key if arguments only have 1 dataset", { diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index 50340eca9..7e687fbd4 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -57,7 +57,7 @@ testthat::test_that("cdisc_data sets the join_keys internally", { join_key("ADTTE", "ADAE", c("STUDYID", "USUBJID")) ) jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) - testthat::expect_equal(data$get_join_keys(), jks) + testthat::expect_equal(join_keys(data), jks) }) testthat::test_that( @@ -76,7 +76,7 @@ testthat::test_that( ) jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) testthat::expect_equal( - data$get_join_keys(), + join_keys(data), jks ) } @@ -96,7 +96,7 @@ testthat::test_that("cdisc_data sets primary keys as join_keys when no join_keys join_key("df2", "df2", "df2_id") ) jks$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(data$get_join_keys(), jks) + testthat::expect_equal(join_keys(data), jks) }) testthat::test_that("cdisc_data throws error when a parent/child graph is not correct", { @@ -182,7 +182,7 @@ testthat::test_that("List values", { test_relational_data_equal <- function(data1, data2) { testthat::expect_equal(data1$get_items(), data2$get_items()) - testthat::expect_equal(data1$get_join_keys(), data2$get_join_keys()) + testthat::expect_equal(join_keys(data1), join_keys(data2)) mapply(testthat::expect_equal, data1$get_ui("test"), data2$get_ui("test")) } diff --git a/tests/testthat/test-get_join_keys.R b/tests/testthat/test-get_join_keys.R index 7a693a5e9..c52e6f7e4 100644 --- a/tests/testthat/test-get_join_keys.R +++ b/tests/testthat/test-get_join_keys.R @@ -1,23 +1,23 @@ -test_that("get_join_keys.teal_data will successfully obtain object from teal_data", { +test_that("join_keys.teal_data will successfully obtain object from teal_data", { obj <- helper_generator_teal_data() - expect_identical(obj@join_keys, get_join_keys(obj)) - helper_test_get_join_keys(obj, "ds1") + expect_identical(obj@join_keys, join_keys(obj)) + helper_test_getter_join_keys(obj, "ds1") }) -test_that("get_join_keys.JoinKeys will return itself", { +test_that("join_keys.JoinKeys will return itself", { obj <- helper_generator_JoinKeys() - expect_identical(obj, get_join_keys(obj)) - helper_test_get_join_keys(obj, "ds1") + expect_identical(obj, join_keys(obj)) + helper_test_getter_join_keys(obj, "ds1") }) -test_that("get_join_keys<-.teal_data", { +test_that("join_keys<-.teal_data", { obj <- helper_generator_teal_data() - helper_test_get_join_keys_add(obj, "ds1", "ds2") + helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) -test_that("get_join_keys<-.JoinKeys", { +test_that("join_keys<-.JoinKeys", { obj <- helper_generator_JoinKeys() - helper_test_get_join_keys_add(obj, "ds1", "ds2") + helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) diff --git a/tests/testthat/test-teal_data.R b/tests/testthat/test-teal_data.R index 747d2378a..f84d354b6 100644 --- a/tests/testthat/test-teal_data.R +++ b/tests/testthat/test-teal_data.R @@ -146,7 +146,7 @@ testthat::test_that("teal_data sets passed join_keys to datasets correctly", { ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(data$get_join_keys(), jk_expected) + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when key names differ", { @@ -165,7 +165,7 @@ testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when k ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(data$get_join_keys(), jk_expected) + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when key names differ (multiple keys)", { @@ -182,7 +182,7 @@ testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when k join_key("df1", "df2", c(id = "fk", id2 = "fk2")) ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(data$get_join_keys(), jk_expected) + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data returns TealData object with cdisc_dataset input", { diff --git a/vignettes/join-keys.Rmd b/vignettes/join-keys.Rmd index 0ee134bc2..dac2b06c6 100644 --- a/vignettes/join-keys.Rmd +++ b/vignettes/join-keys.Rmd @@ -57,7 +57,7 @@ data <- teal_data( # join_key("D2", "D2", keys = c("V", "W")), # equivalent to using primary_key ) ) -data$get_join_keys() +join_keys(data) ``` ### Merge keys From aba1aa054f8197a7f8f571baca943f76061acf7c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 31 Oct 2023 17:10:38 +0100 Subject: [PATCH 007/152] tests use generic getter and setter via join_keys() / join_keys<-() --- NAMESPACE | 7 + R/JoinKeys.R | 67 +-- R/join_key.R | 52 +++ R/join_keys.R | 171 ++++--- R/parents.R | 107 ++++- man/assert_join_keys.Rd | 3 + man/get_join_keys.Rd | 2 +- man/join_key.Rd | 2 +- man/join_keys.Rd | 2 +- man/merge_join_keys.Rd | 6 + man/parent.Rd | 22 + man/parents.Rd | 18 +- man/split_join_keys.Rd | 12 +- man/sub-.JoinKeys.Rd | 3 +- man/update_keys_given_parents.Rd | 2 +- tests/testthat/test-JoinKeys.R | 666 +++++++++++----------------- tests/testthat/test-get_join_keys.R | 23 - tests/testthat/test-join_key.R | 50 +++ tests/testthat/test-join_keys.R | 92 ++++ tests/testthat/test-parents.R | 138 +++++- 20 files changed, 828 insertions(+), 617 deletions(-) create mode 100644 R/join_key.R create mode 100644 man/parent.Rd create mode 100644 tests/testthat/test-join_key.R create mode 100644 tests/testthat/test-join_keys.R diff --git a/NAMESPACE b/NAMESPACE index d47b58036..c56e463d9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ S3method("[<-",Placeholder) S3method("join_keys<-",JoinKeys) S3method("join_keys<-",Placeholder) S3method("join_keys<-",teal_data) +S3method("parents<-",JoinKeys) S3method("parents<-",Placeholder) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) @@ -47,6 +48,8 @@ S3method(load_datasets,TealData) S3method(load_datasets,TealDataConnector) S3method(load_datasets,TealDataset) S3method(load_datasets,TealDatasetConnector) +S3method(merge_join_keys,Placeholder) +S3method(merge_join_keys,default) S3method(mutate_data,TealDataAbstract) S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) @@ -54,6 +57,7 @@ S3method(mutate_dataset,TealDatasetConnector) S3method(mutate_join_keys,JoinKeys) S3method(mutate_join_keys,Placeholder) S3method(mutate_join_keys,TealData) +S3method(parents,JoinKeys) S3method(parents,Placeholder) S3method(print,Placeholder) S3method(set_args,CallableCode) @@ -62,6 +66,8 @@ S3method(set_args,TealDatasetConnector) S3method(set_keys,TealDataAbstract) S3method(set_keys,TealDataset) S3method(set_keys,TealDatasetConnector) +S3method(split_join_keys,Placeholder) +S3method(split_join_keys,default) S3method(to_relational_data,MultiAssayExperiment) S3method(to_relational_data,TealDataset) S3method(to_relational_data,TealDatasetConnector) @@ -121,6 +127,7 @@ export(merge_join_keys) export(mutate_data) export(mutate_dataset) export(mutate_join_keys) +export(parent) export(parents) export(python_cdisc_dataset_connector) export(python_code) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 34dd0c7f3..379211b6b 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -104,7 +104,7 @@ JoinKeys <- R6::R6Class( # nolint if (missing(dataname)) { return(NULL) } - parents(private$.keys)[[dataname]] + parent(private$.keys, dataname) }, #' @description #' Gets the parents of the datasets. @@ -162,7 +162,9 @@ join_keys <- function(...) { x <- rlang::list2(...) # Getter - if (checkmate::test_list(x, len = 1, types = c("Placeholder", "JoinKeys"))) { + if (checkmate::test_list(x, len = 1, types = c("JoinKeys"))) { + return(x[[1]]$get()) + } else if (checkmate::test_list(x, len = 1, types = c("Placeholder"))) { return(x[[1]]) } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { return(x[[1]]@join_keys) @@ -184,17 +186,15 @@ join_keys <- function(...) { #' @param dataset_1 (`character`) name of first dataset. #' @param dataset_2 (`character`) name of second dataset. #' @export -#' @keywords internal -`[.JoinKeys` <- function(x, dataset_1, dataset_2 = dataset_1) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2) +`[.JoinKeys` <- function(x, dataset_1 = NULL, dataset_2 = NULL) { + checkmate::assert_string(dataset_1, null.ok = TRUE) + checkmate::assert_string(dataset_2, null.ok = TRUE) x$get(dataset_1, dataset_2) } #' @rdname sub-.JoinKeys #' @param value value to assign #' @export -#' @keywords internal `[<-.JoinKeys` <- function(x, dataset_1, dataset_2 = dataset_1, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) @@ -302,56 +302,3 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) { mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, val) { # nolint x$mutate_join_keys(dataset_1, dataset_2, val) } - -#' Create a relationship between a pair of datasets -#' -#' @description `r lifecycle::badge("stable")` -#' -#' @details `join_key()` will create a relationship for the variables on a pair -#' of datasets. -#' -#' @inheritParams mutate_join_keys -#' @param dataset_2 (optional `character`) other dataset name. In case it is omitted, then it -#' will create a primary key for `dataset_1`. -#' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` -#' with relationship to columns of `dataset_2` given by the elements in `keys`. -#' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1` -#' and `dataset_2`. -#' -#' @return object of class `JoinKeySet` to be passed into `join_keys` function. -#' -#' @seealso [join_keys()] -#' -#' @export -join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2) - checkmate::assert_character(keys, any.missing = FALSE) - - if (length(keys) > 0) { - if (is.null(names(keys))) { - names(keys) <- keys - } - - if (any(names(keys) == "")) { - names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""] - } - - stopifnot(!is.null(names(keys))) - stopifnot(!anyDuplicated(keys)) - stopifnot(!anyDuplicated(names(keys))) - } - - if (dataset_1 == dataset_2 && any(names(keys) != keys)) { - stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed") - } - - structure( - list( - dataset_1 = dataset_1, - dataset_2 = dataset_2, - keys = keys - ), - class = "JoinKeySet" - ) -} diff --git a/R/join_key.R b/R/join_key.R new file mode 100644 index 000000000..63b4f48b5 --- /dev/null +++ b/R/join_key.R @@ -0,0 +1,52 @@ +#' Create a relationship between a pair of datasets +#' +#' @description `r lifecycle::badge("stable")` +#' +#' @details `join_key()` will create a relationship for the variables on a pair +#' of datasets. +#' +#' @inheritParams mutate_join_keys +#' @param dataset_2 (optional `character`) other dataset name. In case it is omitted, then it +#' will create a primary key for `dataset_1`. +#' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` +#' with relationship to columns of `dataset_2` given by the elements in `keys`. +#' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1` +#' and `dataset_2`. +#' +#' @return object of class `JoinKeySet` to be passed into `join_keys` function. +#' +#' @seealso [join_keys()] +#' +#' @export +join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2) + checkmate::assert_character(keys, any.missing = FALSE) + + if (length(keys) > 0) { + if (is.null(names(keys))) { + names(keys) <- keys + } + + if (any(names(keys) == "")) { + names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""] + } + + stopifnot(!is.null(names(keys))) + stopifnot(!anyDuplicated(keys)) + stopifnot(!anyDuplicated(names(keys))) + } + + if (dataset_1 == dataset_2 && any(names(keys) != keys)) { + stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed") + } + + structure( + list( + dataset_1 = dataset_1, + dataset_2 = dataset_2, + keys = keys + ), + class = "JoinKeySet" + ) +} diff --git a/R/join_keys.R b/R/join_keys.R index 6f6599650..880b6520d 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -26,8 +26,12 @@ return(join_keys_obj) } + if (test_join_keys(value)) { + return(value) + } + if (length(join_keys_obj) > 0) { - stop("Keys already set, please use mutate_join_keys() or to change them") + stop("Keys already set, please use `mutate_join_keys(data)` or `data[ds1, ds2]<- new_key` to change them") } if (inherits(value, "JoinKeySet")) value <- list(value) @@ -51,11 +55,14 @@ #' @rdname get_join_keys #' @inheritParams mutate_join_keys #' @export -`join_keys<-.JoinKeys` <- function(data, dataset_1, dataset_2 = NULL, value) { - if (missing(dataset_1) || missing(value)) { +`join_keys<-.JoinKeys` <- function(data, value) { + if (length(data$get()) > 0) { + stop("Keys already set, please use `mutate_join_keys(data)` or `data[ds1, ds2]<- new_key` to change them") + } + if (missing(value)) { return(data) } - data$mutate(dataset_1, dataset_2, value) + data$set(value) data } @@ -87,14 +94,30 @@ #' jk["ds1", "ds2"] #' jk["ds1"] #' jk[["ds1"]] -`[.Placeholder` <- function(join_keys_obj, dataset_1, dataset_2 = NULL) { - checkmate::assert_string(dataset_1) +`[.Placeholder` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { + if (checkmate::test_integerish(dataset_1, len = 2)) { + # if dataset_1 is an index integet vector, then return itself + # trick to make the following work: join_keys(jk)["ds1", "ds2"] <- "key" + return(join_keys_obj) + } + checkmate::assert_string(dataset_1, null.ok = TRUE) checkmate::assert_string(dataset_2, null.ok = TRUE) + if (is.null(dataset_1) && is.null(dataset_2)) { + return(join_keys_obj) + } if (is.null(dataset_2)) { return(join_keys_obj[[dataset_1]]) } - join_keys_obj[[dataset_1]][[dataset_2]] + if (is.null(dataset_1)) { + return(join_keys_obj[[dataset_2]]) + } + + result <- join_keys_obj[[dataset_1]][[dataset_2]] + if (is.null(result)) { + return(character(0)) + } + result } #' @details @@ -120,21 +143,30 @@ checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2, null.ok = TRUE) + # Normalize value + new_join_key <- join_key(dataset_1, dataset_2, value) + dataset_1 <- new_join_key$dataset_1 + dataset_2 <- new_join_key$dataset_2 + value <- new_join_key$keys + + # Create pair ds_1 -> ds_2 if (is.null(join_keys_obj[[dataset_1]])) join_keys_obj[[dataset_1]] <- list() join_keys_obj[[dataset_1]][[dataset_2]] <- value + # Primary key, do nothing else if (identical(dataset_1, dataset_2)) { return(join_keys_obj) } + # Create symmetrical pair ds_2 -> ds_1 if (is.null(join_keys_obj[[dataset_2]])) join_keys_obj[[dataset_2]] <- list() if ( checkmate::test_character(value, min.len = 1) && - !checkmate::test_names(names(value)) + all(is.null(names(value))) ) { - value <- setNames(value, value) + value <- setNames(names(value), value) } else if ( checkmate::test_character(value, min.len = 1) ) { @@ -172,8 +204,20 @@ mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { res } -#' Split the `JoinKeys` object into a named list of join keys objects with an -#' element for each dataset +#' @rdname split_join_keys +#' @export +split_join_keys <- function(join_keys_obj) { + UseMethod("split_join_keys", join_keys_obj) +} + +#' @rdname split_join_keys +#' @export +split_join_keys.default <- function(join_keys_obj) { + split_join_keys(join_keys(join_keys_obj)) +} + +#' @rdname split_join_keys +#' @title Split the `JoinKeys` object into a named list of join keys objects with an element for each dataset #' #' @return (`list`) a list of `JoinKeys` object #' @export @@ -182,7 +226,7 @@ mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { #' jk["ds1", "ds2"] <- "some_col" #' jk["ds1", "ds3"] <- "new_col" #' split_join_keys(jk) -split_join_keys <- function(join_keys_obj) { +split_join_keys.Placeholder <- function(join_keys_obj) { assert_join_keys(join_keys_obj) list_of_list_of_join_key_set <- lapply( @@ -201,8 +245,22 @@ split_join_keys <- function(join_keys_obj) { return(res) } +#' @rdname merge_join_keys +#' @export +merge_join_keys <- function(join_keys_obj, new_join_keys) { + UseMethod("merge_join_keys", join_keys_obj) +} + +#' @rdname merge_join_keys +#' @export +merge_join_keys.default <- function(join_keys_obj, new_join_keys) { + merge_join_keys(join_keys(join_keys_obj), new_join_keys) +} + #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object #' +#' @rdname merge_join_keys +#' #' @param join_keys_obj (`JoinKeys`) object to merge the new_join_keys. #' @param new_join_keys `list` of `JoinKeys` objects or single `JoinKeys` object #' @@ -218,7 +276,7 @@ split_join_keys <- function(join_keys_obj) { #' jk2["ds1", "ds3"] <- "new_col" #' #' merge_join_keys(jk1, jk2) -merge_join_keys <- function(join_keys_obj, new_join_keys) { +merge_join_keys.Placeholder <- function(join_keys_obj, new_join_keys) { assert_join_keys(join_keys_obj) if (inherits(new_join_keys, c("JoinKeys", "Placeholder"))) { @@ -244,68 +302,6 @@ merge_join_keys <- function(join_keys_obj, new_join_keys) { return(result) } -#' Updates the keys of the datasets based on the parents. -#' -#' @param join_keys_obj (`JoinKeys`) object to update the keys. -#' -#' @return (`self`) invisibly for chaining -#' -#' @export -#' -#' @examples -#' jk <- new_join_keys() -#' join_keys(jk) <- list( -#' join_key("df1", "df1", c("id", "id2")), -#' join_key("df1", "df2", c("id" = "id")), -#' join_key("df1", "df3", c("id" = "id")) -#' ) -#' parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") -#' jk2 <- update_keys_given_parents(jk) -#' -#' jk[["df2"]] -#' jk2[["df2"]] -update_keys_given_parents <- function(join_keys_obj) { - jk <- join_keys(join_keys_obj) - - checkmate::assert_class(jk, "Placeholder", .var.name = vname(join_keys_obj)) - - datanames <- names(jk) - duplicate_pairs <- list() - for (d1 in datanames) { - d1_pk <- jk[d1, d1] - d1_parent <- parents(jk)[[d1]] - for (d2 in datanames) { - if (paste(d2, d1) %in% duplicate_pairs) { - next - } - if (length(jk[d1, d2]) == 0) { - d2_parent <- parents(jk)[[d2]] - d2_pk <- jk[d2, d2] - - fk <- if (identical(d1, d2_parent)) { - # first is parent of second -> parent keys -> first keys - d1_pk - } else if (identical(d1_parent, d2)) { - # second is parent of first -> parent keys -> second keys - d2_pk - } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { - # both has the same parent -> parent keys - jk[d1_parent, d1_parent] - } else { - # cant find connection - leave empty - next - } - jk <- mutate_join_keys(jk, d1, d2, fk) - duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) - } - } - } - # check parent child relation - assert_parent_child(join_keys_obj = jk) - - jk -} - #' Prints `JoinKeys`. #' #' @param ... additional arguments to the printing method @@ -362,22 +358,21 @@ new_join_keys <- function() { #' #' @keywords internal get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { - checkmate::assert_multi_class(join_keys_obj, c("teal_data", "Placeholder")) jk <- join_keys(join_keys_obj) + assert_join_keys(jk) + if (missing(dataset_1) && missing(dataset_2)) { return(jk) } if (missing(dataset_2)) { - return(jk[[dataset_1]]) + return(jk[dataset_1]) } if (missing(dataset_1)) { - return(jk[[dataset_2]]) + return(jk[dataset_2]) } - if (is.null(jk[[dataset_1]][[dataset_2]])) { - return(character(0)) - } - return(jk[[dataset_1]][[dataset_2]]) + + jk[dataset_1, dataset_2] } #' Helper function to add a new pair to a `JoinKeys` object @@ -390,14 +385,9 @@ get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { #' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) #' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) join_pair <- function(join_keys_obj, join_key_obj) { - checkmate::assert_multi_class(join_keys_obj, c("JoinKeys", "Placeholder")) + assert_join_keys(join_keys_obj) checkmate::assert_class(join_key_obj, "JoinKeySet") - if (checkmate::test_class(join_keys_obj, "JoinKeys")) { - join_keys_obj <- join_keys_obj$get() - class(join_keys_obj) <- "Placeholder" - } - dataset_1 <- join_key_obj$dataset_1 dataset_2 <- join_key_obj$dataset_2 keys <- join_key_obj$keys @@ -417,6 +407,11 @@ assert_join_keys <- function(x, .var.name = checkmate::vname(x)) { checkmate::assert_class(x, classes = c("Placeholder"), .var.name = .var.name) } +#' @rdname assert_join_keys +test_join_keys <- function(x) { + checkmate::test_class(x, classes = c("Placeholder")) +} + #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise diff --git a/R/parents.R b/R/parents.R index ec0c43d91..2682642d6 100644 --- a/R/parents.R +++ b/R/parents.R @@ -1,9 +1,37 @@ -#' A name +#' Getter for specific parent +#' +#' @param join_keys_obj (`JoinKeys`) object to retrieve. +#' @param dataset_name (`character(1)`) +#' +#' @export +#' +#' @examples +#' jk <- join_keys() +#' parent(jk, "ds1") +#' parents(jk) <- list("ds2" = "ds3") +#' parent(jk, "ds2") +parent <- function(join_keys_obj, dataset_name) { + checkmate::assert_string(dataset_name) + # assert join_keys_obj is performed by parents() + parents(join_keys_obj)[[dataset_name]] +} + +#' Getter and setter functions for parents attribute of `JoinKeys` +#' +#' @param join_keys_obj (`JoinKeys`) object to retrieve or manipulate. +#' @return a list of `character` representing the parents. +#' #' @export parents <- function(join_keys_obj) { UseMethod("parents", join_keys_obj) } +#' @rdname parents +#' @export +parents.JoinKeys <- function(join_keys_obj) { + parents(join_keys(join_keys_obj$get())) +} + #' @rdname parents #' @export #' @examples @@ -14,7 +42,11 @@ parents.Placeholder <- function(join_keys_obj) { } #' @rdname parents +#' +#' @param value (`list`) named list of character values +#' #' @export +#' #' @examples #' jk <- new_join_keys() #' parents(jk) <- list(ADSL = "ADTTE") @@ -22,6 +54,17 @@ parents.Placeholder <- function(join_keys_obj) { UseMethod("parents<-", join_keys_obj) } +#' @rdname parents +#' @export +`parents<-.JoinKeys` <- function(join_keys_obj, value) { + if (missing(value)) { + return(join_keys_obj) + } + jk <- join_keys_obj$get() + parents(jk) <- value + jk +} + #' @rdname parents #' @export #' @examples @@ -55,6 +98,68 @@ parents.Placeholder <- function(join_keys_obj) { join_keys_obj } +#' Updates the keys of the datasets based on the parents. +#' +#' @param join_keys_obj (`JoinKeys`) object to update the keys. +#' +#' @return (`self`) invisibly for chaining +#' +#' @export +#' +#' @examples +#' jk <- new_join_keys() +#' join_keys(jk) <- list( +#' join_key("df1", "df1", c("id", "id2")), +#' join_key("df1", "df2", c("id" = "id")), +#' join_key("df1", "df3", c("id" = "id")) +#' ) +#' parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") +#' jk2 <- update_keys_given_parents(jk) +#' +#' jk[["df2"]] +#' jk2[["df2"]] +update_keys_given_parents <- function(join_keys_obj) { + jk <- join_keys(join_keys_obj) + + checkmate::assert_class(jk, "Placeholder", .var.name = vname(join_keys_obj)) + + datanames <- names(jk) + duplicate_pairs <- list() + for (d1 in datanames) { + d1_pk <- jk[d1, d1] + d1_parent <- parents(jk)[[d1]] + for (d2 in datanames) { + if (paste(d2, d1) %in% duplicate_pairs) { + next + } + if (length(jk[d1, d2]) == 0) { + d2_parent <- parents(jk)[[d2]] + d2_pk <- jk[d2, d2] + + fk <- if (identical(d1, d2_parent)) { + # first is parent of second -> parent keys -> first keys + d1_pk + } else if (identical(d1_parent, d2)) { + # second is parent of first -> parent keys -> second keys + d2_pk + } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { + # both has the same parent -> parent keys + jk[d1_parent, d1_parent] + } else { + # cant find connection - leave empty + next + } + jk <- mutate_join_keys(jk, d1, d2, fk) + duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) + } + } + } + # check parent child relation + assert_parent_child(join_keys_obj = jk) + + jk +} + # ----------------------------------------------------------------------------- # # Helpers (non-exported) diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd index d4dffaa3d..c4f2fb458 100644 --- a/man/assert_join_keys.Rd +++ b/man/assert_join_keys.Rd @@ -2,9 +2,12 @@ % Please edit documentation in R/join_keys.R \name{assert_join_keys} \alias{assert_join_keys} +\alias{test_join_keys} \title{Check the JoinKeys class membership of an argument} \usage{ assert_join_keys(x, .var.name = checkmate::vname(x)) + +test_join_keys(x) } \arguments{ \item{x}{[any]\cr diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 3b97bc437..e376678b2 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -11,7 +11,7 @@ get_join_keys(data) get_join_keys(data, dataset_1, dataset_2 = NULL) <- value -\method{join_keys}{JoinKeys}(data, dataset_1, dataset_2 = NULL) <- value +\method{join_keys}{JoinKeys}(data) <- value \method{join_keys}{teal_data}(data, dataset_1, dataset_2 = NULL) <- value } diff --git a/man/join_key.Rd b/man/join_key.Rd index 17f020099..24a74efbd 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R +% Please edit documentation in R/join_key.R \name{join_key} \alias{join_key} \title{Create a relationship between a pair of datasets} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index ad9f27878..f5937fccb 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -17,7 +17,7 @@ join_keys(join_keys_obj) <- value \method{join_keys}{Placeholder}(join_keys_obj) <- value -\method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = NULL) +\method{[}{Placeholder}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) \method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value } diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index cbb42e9b4..b39409289 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -2,9 +2,15 @@ % Please edit documentation in R/join_keys.R \name{merge_join_keys} \alias{merge_join_keys} +\alias{merge_join_keys.default} +\alias{merge_join_keys.Placeholder} \title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} \usage{ merge_join_keys(join_keys_obj, new_join_keys) + +\method{merge_join_keys}{default}(join_keys_obj, new_join_keys) + +\method{merge_join_keys}{Placeholder}(join_keys_obj, new_join_keys) } \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) object to merge the new_join_keys.} diff --git a/man/parent.Rd b/man/parent.Rd new file mode 100644 index 000000000..6f6026b65 --- /dev/null +++ b/man/parent.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parents.R +\name{parent} +\alias{parent} +\title{Getter for specific parent} +\usage{ +parent(join_keys_obj, dataset_name) +} +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object to retrieve.} + +\item{dataset_name}{(\code{character(1)})} +} +\description{ +Getter for specific parent +} +\examples{ +jk <- join_keys() +parent(jk, "ds1") +parents(jk) <- list("ds2" = "ds3") +parent(jk, "ds2") +} diff --git a/man/parents.Rd b/man/parents.Rd index 2df7da94c..229fccfde 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -2,21 +2,35 @@ % Please edit documentation in R/parents.R \name{parents} \alias{parents} +\alias{parents.JoinKeys} \alias{parents.Placeholder} \alias{parents<-} +\alias{parents<-.JoinKeys} \alias{parents<-.Placeholder} -\title{A name} +\title{Getter and setter functions for parents attribute of \code{JoinKeys}} \usage{ parents(join_keys_obj) +\method{parents}{JoinKeys}(join_keys_obj) + \method{parents}{Placeholder}(join_keys_obj) parents(join_keys_obj) <- value +\method{parents}{JoinKeys}(join_keys_obj) <- value + \method{parents}{Placeholder}(join_keys_obj) <- value } +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object to retrieve or manipulate.} + +\item{value}{(\code{list}) named list of character values} +} +\value{ +a list of \code{character} representing the parents. +} \description{ -A name +Getter and setter functions for parents attribute of \code{JoinKeys} } \examples{ jk <- new_join_keys() diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd index 70af71a56..e8354d523 100644 --- a/man/split_join_keys.Rd +++ b/man/split_join_keys.Rd @@ -2,17 +2,21 @@ % Please edit documentation in R/join_keys.R \name{split_join_keys} \alias{split_join_keys} -\title{Split the \code{JoinKeys} object into a named list of join keys objects with an -element for each dataset} +\alias{split_join_keys.default} +\alias{split_join_keys.Placeholder} +\title{Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset} \usage{ split_join_keys(join_keys_obj) + +\method{split_join_keys}{default}(join_keys_obj) + +\method{split_join_keys}{Placeholder}(join_keys_obj) } \value{ (\code{list}) a list of \code{JoinKeys} object } \description{ -Split the \code{JoinKeys} object into a named list of join keys objects with an -element for each dataset +Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset } \examples{ jk <- new_join_keys() diff --git a/man/sub-.JoinKeys.Rd b/man/sub-.JoinKeys.Rd index 1fac6de0b..db5867a03 100644 --- a/man/sub-.JoinKeys.Rd +++ b/man/sub-.JoinKeys.Rd @@ -5,7 +5,7 @@ \alias{[<-.JoinKeys} \title{Getter for JoinKeys that returns the relationship between pairs of datasets} \usage{ -\method{[}{JoinKeys}(x, dataset_1, dataset_2 = dataset_1) +\method{[}{JoinKeys}(x, dataset_1 = NULL, dataset_2 = NULL) \method{[}{JoinKeys}(x, dataset_1, dataset_2 = dataset_1) <- value } @@ -21,4 +21,3 @@ \description{ Getter for JoinKeys that returns the relationship between pairs of datasets } -\keyword{internal} diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 8c9fe2bda..3304cec92 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/parents.R \name{update_keys_given_parents} \alias{update_keys_given_parents} \title{Updates the keys of the datasets based on the parents.} diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R index c57a4c403..98fb421f2 100644 --- a/tests/testthat/test-JoinKeys.R +++ b/tests/testthat/test-JoinKeys.R @@ -1,62 +1,4 @@ -test_that("join_key throws error with invalid keys arguments", { - # invalid types - expect_error(join_key("d1", "d2", keys = NULL)) - expect_error(join_key("d1", "d2", keys = 1:10)) - - # not fully named - expect_error(join_key("d1", "d2", keys = c("X" = "A", "B")), NA) - keys <- c("A", "C" = "B") - names(keys)[1] <- "" - expect_error(join_key("d1", "d2", keys), NA) - - # duplicates in names or values - expect_error(join_key("d1", "d2", keys = c("A" = "A", "A" = "B"))) - expect_error(join_key("d1", "d2", keys = c("C" = "A", "D" = "A"))) - - # names(keys)!= keys if datasets are the same - expect_error(join_key("d1", "d1", keys = c("B" = "A", "A" = "B"))) - expect_error(join_key("d1", keys = c("B" = "A", "A" = "B"))) -}) - -test_that("key empty name is changed to the key value", { - keys <- JoinKeys$new() - - # set empty key name - keys$mutate("d1", "d2", c("A" = "B", "C")) - expect_equal(keys$get()$d1$d2, setNames(c("B", "C"), c("A", "C"))) - - # set key on non-empty variable name equal to "" - keys$mutate("d1", "d2", c("A" = "B", "C" = "")) - expect_equal(keys$get()$d1$d2, setNames(c("B", ""), c("A", "C"))) - - # set key on empty variable name equal to "" - keys$mutate("d1", "d2", c("A" = "B", "")) - expect_equal(keys$get()$d1$d2, setNames(c("B", ""), c("A", ""))) -}) - -test_that("join_key throws error with invalid dataset arguments", { - # missing - expect_error(join_key("d1", as.character(NA), keys = c("A" = "B", "C" = "D"))) - # invalid type - expect_error(join_key("d1", 5, keys = c("A" = "B", "C" = "D"))) - # invalid length - expect_error(join_key("d1", c("d1", "d2"), keys = c("A" = "B", "C" = "D"))) -}) - -test_that("join_key does not throw error with valid arguments", { - # keys of length 0 - expect_silent(join_key("d1", "d2", keys = character(0))) - # keys of length 1 - expect_silent(join_key("d1", "d2", keys = c("A" = "B"))) - # keys of length > 1 - expect_silent(join_key("d1", "d2", keys = c("A" = "B", "C" = "D"))) - # dataset_1 and dataset_2 can be the same if keys match - expect_silent(join_key("d1", "d1", keys = c("A" = "A", "B" = "B"))) - - expect_silent(join_key("d1", keys = c("A" = "A", "B" = "B"))) -}) - -test_that("cannot set join_keys with incompatible keys", { +test_that("join_keys cannot set join_keys with incompatible keys", { # different keys expect_error( join_keys( @@ -94,7 +36,7 @@ test_that("cannot set join_keys with incompatible keys", { ) }) -test_that("can create join_keys with compatible information", { +test_that("join_keys can create join_keys with compatible information", { # different datasets expect_silent( join_keys( @@ -143,8 +85,7 @@ test_that("can create join_keys with compatible information", { ) }) - -test_that("cannot create JoinKeys with invalid arguments", { +test_that("join_keys cannot create JoinKeys with invalid arguments", { # not using join_key expect_error(join_keys("d1", "d2", "A")) # key sets with the same pair of datasets but different values @@ -152,7 +93,7 @@ test_that("cannot create JoinKeys with invalid arguments", { expect_error(join_keys(join_key("d1", "d2", c("A" = "X")), join_key("d2", "d1", c("A" = "X")))) }) -test_that("can create JoinKeys with valid arguments", { +test_that("join_keys can create JoinKeys with valid arguments", { # no keys expect_silent(join_keys()) # list of keys @@ -165,31 +106,31 @@ test_that("can create JoinKeys with valid arguments", { }) -test_that("cannot set keys in JoinKeys if they have already been set", { +test_that("join_keys cannot set keys in JoinKeys if they have already been set", { my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_error(my_keys$set(join_key("d1", "d3", "A"))) + expect_error(join_keys(my_keys) <- join_key("d1", "d3", "A")) }) -test_that("creating join keys with d1 -> d2 also creates the key d2 - > d1", { +test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) - expect_equal(my_keys$get("d2", "d1"), c("C" = "A")) + expect_equal(my_keys["d2", "d1"], c("C" = "A")) }) -test_that("can get all keys for a given dataset", { +test_that("join_keys[ can get all keys for a given dataset", { my_keys <- join_keys( join_key("d1", "d2", c("A" = "C")), join_key("d1", "d3", c("A" = "B", "S" = "T")), join_key("d2", "d3", c("C" = "U", "L" = "M")) ) - expect_equal(my_keys$get(dataset_1 = "d1"), list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys$get(dataset_2 = "d1"), list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys$get(dataset_1 = "d3"), list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))) + expect_equal(my_keys[dataset_1 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) + expect_equal(my_keys[dataset_2 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) + expect_equal(my_keys[dataset_1 = "d3"], list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))) }) -test_that("can get all keys from JoinKeys", { +test_that("join_keys can get all keys from JoinKeys", { my_keys <- join_keys( join_key("d1", "d2", c("A" = "C")), join_key("d1", "d3", c("A" = "B", "S" = "T")), @@ -198,54 +139,59 @@ test_that("can get all keys from JoinKeys", { all_keys <- my_keys$get() expect_equal(names(all_keys), c("d1", "d2", "d3")) - expect_equal(my_keys$get(dataset_1 = "d1"), all_keys[["d1"]]) + expect_equal(my_keys[dataset_1 = "d1"], all_keys[["d1"]]) }) -test_that("join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { +test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) - expect_equal(unname(test_keys$get("d1", "d2")), names(test_keys$get("d1", "d2"))) + expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) }) - -test_that("if no keys between pair of datasets then getting them returns character(0)", { +test_that("join_keys if no keys between pair of datasets then getting them returns character(0)", { my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_equal(my_keys$get("d1", "d3"), character(0)) - expect_equal(my_keys$get("d1", "d4"), character(0)) + expect_equal(my_keys["d1", "d3"], character(0)) + expect_equal(my_keys["d1", "d4"], character(0)) }) -test_that("can mutate existing keys", { +# ----------------------------------------------------------------------------- +# +# mutate_join_keys + +test_that("mutate_join_keys.JoinKeys can mutate existing keys", { my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys$mutate("d1", "d2", c("X" = "Y")) - expect_equal(my_keys$get("d1", "d2"), c("X" = "Y")) + new_keys <- mutate_join_keys(my_keys, "d1", "d2", c("X" = "Y")) + expect_equal(new_keys["d1", "d2"], c("X" = "Y")) }) -test_that("mutating non-existing keys adds them", { +test_that("mutate_join_keys.JoinKeys mutating non-existing keys adds them", { my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys$mutate("d2", "d3", c("X" = "Y")) - expect_equal(my_keys$get("d3", "d2"), c("Y" = "X")) + new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) + expect_equal(my_keys["d3", "d2"], c("Y" = "X")) }) -test_that("can remove keys by setting them to character(0)", { +test_that("mutate_join_keys.JoinKeys can remove keys by setting them to character(0)", { my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) - my_keys$mutate("d1", "d2", character(0)) - expect_equal(my_keys$get("d1", "d2"), character(0)) + new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) + expect_equal(my_keys["d1", "d2"], character(0)) }) -testthat::test_that("JoinKeys$split method returns empty list when object itself is empty", { - x <- JoinKeys$new() - testthat::expect_identical(x$split(), list()) +# ----------------------------------------------------------------------------- +# +# split_join_keys + +testthat::test_that("split_join_keys method returns empty list when object itself is empty", { + x <- join_keys() + testthat::expect_identical(split_join_keys(x), list()) }) -testthat::test_that("JoinKeys$split method returns a named list of JoinKeys objects with an element for each dataset", { - x <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("split_join_keys method returns a named list of JoinKeys objects with an element for each dataset", { + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - res <- x$split() + res <- split_join_keys(x) testthat::expect_true(inherits(res, "list")) testthat::expect_equal(length(res), 5) testthat::expect_equal(names(res), c("A", "B", "C", "Z", "Y")) @@ -259,27 +205,25 @@ testthat::test_that("JoinKeys$split method returns a named list of JoinKeys obje }) testthat::test_that( - "JoinKeys$split method returns an updated list after the state of the object is modified by JoinKeys$mutate()", + "split_join_keys method returns an updated list after the state of the object is modified by mutate_join_keys", { - x <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - res <- x$split() + res <- split_join_keys(x) - x$mutate("A", "B", c("a" = "b", "aa" = "bb")) - res2 <- x$split() + x2 <- mutate_join_keys(x, "A", "B", c("a" = "b", "aa" = "bb")) + res2 <- split_join_keys(x2) testthat::expect_false(identical(res, res2)) testthat::expect_identical(res2$A$get()$A$B, c("a" = "b", "aa" = "bb")) # adding new datasets - x$mutate("D", "G", c("d" = "g")) - res3 <- x$split() + x3 <- mutate_join_keys(x2, "D", "G", c("d" = "g")) + res3 <- split_join_keys(x3) testthat::expect_false(identical(res, res3)) testthat::expect_false(identical(res2, res3)) testthat::expect_identical(res3$D$get()$D$G, c("d" = "g")) @@ -288,261 +232,248 @@ testthat::test_that( } ) -testthat::test_that("JoinKeys$split method does not modify self", { - x <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("split_join_keys method does not modify self", { + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_self <- x$clone() - no_use_output <- x$split() + + previous_self <- x + no_use_output <- split_join_keys(x) testthat::expect_equal(previous_self, x) }) +# ----------------------------------------------------------------------------- +# +# merge_join_keys -testthat::test_that("JoinKeys$merge can handle edge case: calling object is empty", { - x <- JoinKeys$new() - y <- JoinKeys$new() - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys can handle edge case: calling object is empty", { + x <- join_keys() + y <- join_keys() + + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - testthat::expect_silent(x$merge(y)) - testthat::expect_identical(x$get(), y$get()) + + testthat::expect_silent(merge_join_keys(x, y)) + testthat::expect_identical(join_keys(x), join_keys(x)) }) -testthat::test_that("JoinKeys$merge can handle edge case: argument is an empty object", { - x <- JoinKeys$new() - y <- JoinKeys$new() - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys can handle edge case: argument is an empty object", { + x <- join_keys() + y <- join_keys() + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(x)) - testthat::expect_identical(previous_output, y$get()) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, x)) + testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("JoinKeys$merge can handle edge case: argument is a list of empty objects", { - x <- JoinKeys$new() - y <- JoinKeys$new() - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys can handle edge case: argument is a list of empty objects", { + x <- join_keys() + y <- join_keys() + + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(list(x, x$clone()))) - testthat::expect_identical(previous_output, y$get()) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x, x))) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_silent(y$merge(list(x, x$clone(), x$clone()))) - testthat::expect_identical(previous_output, y$get()) + testthat::expect_silent(merge_join_keys(y, list(x, x, x))) + testthat::expect_identical(previous_output, join_keys(y)) }) testthat::test_that( - "JoinKeys$merge throws error when improper argument is passed in without modifying the caller", + "merge_join_keys throws error when improper argument is passed in without modifying the caller", { - y <- JoinKeys$new() - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + y <- join_keys() + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_error(y$merge()) - testthat::expect_identical(previous_output, y$get()) - testthat::expect_error(y$merge(1)) - testthat::expect_identical(previous_output, y$get()) + previous_output <- join_keys(y) + testthat::expect_error(y <- merge_join_keys(y)) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(y, 1)) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_error(y$merge("A")) - testthat::expect_identical(previous_output, y$get()) + testthat::expect_error(y <- merge_join_keys(y, "A")) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_error(y$merge(list())) - testthat::expect_identical(previous_output, y$get()) + testthat::expect_error(y <- merge_join_keys(y, list())) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_error(y$merge(list(1))) - testthat::expect_identical(previous_output, y$get()) + testthat::expect_error(y <- merge_join_keys(list(1))) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_error(y$merge(list("A"))) - testthat::expect_identical(previous_output, y$get()) + testthat::expect_error(y <- merge_join_keys(y, list("A"))) + testthat::expect_identical(previous_output, join_keys(y)) } ) -testthat::test_that("JoinKeys$merge does nothing when argument is a JoinKeys object with identical data", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys does nothing when argument is a JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(x)) - testthat::expect_identical(previous_output, y$get()) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, x)) + testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("JoinKeys$merge does nothing when argument is a list of one JoinKeys object with identical data", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(list(x))) - testthat::expect_identical(previous_output, y$get()) - testthat::expect_silent(y$merge(list(x, x$clone()))) - testthat::expect_identical(previous_output, y$get()) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x))) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_silent(merge_join_keys(y, list(x, x))) + testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("JoinKeys$merge does nothing when argument is a list of many JoinKeys object with identical data", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) +testthat::test_that("merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(list(x, x, x, x, x, x, x, x))) - testthat::expect_identical(previous_output, y$get()) + + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) + testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("JoinKeys$merge clones data when argument is a list of one JoinKeys object that is a superset", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) - ) +testthat::test_that("merge_join_keys clones data when argument is a list of one JoinKeys object that is a superset", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")), + join_key("ZZ", "YY", c("zz" = "yy")) ) - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y$get() - testthat::expect_silent(y$merge(list(x))) - testthat::expect_false(identical(previous_output, y$get())) - testthat::expect_identical(x$get(), y$get()) + + previous_output <- join_keys(y) + testthat::expect_silent(y <- merge_join_keys(y, list(x))) + testthat::expect_false(identical(previous_output, join_keys(y))) + testthat::expect_identical(join_keys(x), join_keys(y)) }) -testthat::test_that("JoinKeys$merge does nothing when argument is a list of one JoinKeys object that is a subset", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) - ) +testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object that is a subset", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")), + join_key("ZZ", "YY", c("zz" = "yy")) ) - y$set( - list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) ) - previous_output <- x$get() - testthat::expect_silent(x$merge(list(y))) - testthat::expect_identical(previous_output, x$get()) + previous_output <- join_keys(x) + testthat::expect_silent(x <- merge_join_keys(x, list(y))) + testthat::expect_identical(previous_output, join_keys(x)) }) -testthat::test_that("JoinKeys$merge merges mutually exclusive data", { - x <- JoinKeys$new() - y <- JoinKeys$new() - x$set( - list( - join_key("A", "B", c("a" = "b")) - ) +testthat::test_that("merge_join_keys merges mutually exclusive data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")) ) - y$set( - list( - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(y) <- list( + join_key("Z", "Y", c("z" = "y")) ) - z <- JoinKeys$new() - z$merge(list(x, y)) - manual_join <- c(x$get(), y$get()) + + z <- join_keys() + z <- merge_join_keys(z, list(x, y)) + manual_join <- c(join_keys(x), join_keys(y)) class(manual_join) <- class(new_join_keys()) - testthat::expect_identical(manual_join, z$get()) + testthat::expect_identical(manual_join, join_keys(z)) - x$merge(y) - y$merge(x) + x <- merge_join_keys(x, y) + y <- merge_join_keys(y, x) - testthat::expect_identical(x$get(), z$get()) - testthat::expect_true(all(y$get() %in% z$get()) && all(z$get() %in% y$get())) - testthat::expect_true(all(y$get() %in% x$get()) && all(x$get() %in% y$get())) + testthat::expect_identical(join_keys(x), join_keys(z)) + testthat::expect_true(all(join_keys(y) %in% join_keys(z)) && all(join_keys(z) %in% join_keys(y))) + testthat::expect_true(all(join_keys(y) %in% join_keys(x)) && all(join_keys(x) %in% join_keys(y))) - testthat::expect_identical(names(z$get()), c("A", "B", "Z", "Y")) - testthat::expect_equal(length(z$get()), 4) - testthat::expect_identical(z$get()$A$B, c("a" = "b")) - testthat::expect_identical(z$get()$B$A, c("b" = "a")) - testthat::expect_identical(z$get()$Z$Y, c("z" = "y")) - testthat::expect_identical(z$get()$Y$Z, c("y" = "z")) + testthat::expect_identical(names(join_keys(z)), c("A", "B", "Z", "Y")) + testthat::expect_equal(length(join_keys(z)), 4) + testthat::expect_identical(join_keys(z)$A$B, c("a" = "b")) + testthat::expect_identical(join_keys(z)$B$A, c("b" = "a")) + testthat::expect_identical(join_keys(z)$Z$Y, c("z" = "y")) + testthat::expect_identical(join_keys(z)$Y$Z, c("y" = "z")) }) -testthat::test_that("JoinKeys$print for empty set", { - jk <- JoinKeys$new() +# ----------------------------------------------------------------------------- +# +# print.JoinKeys + +testthat::test_that("print.JoinKeys for empty set", { + jk <- join_keys() testthat::expect_output( print(jk), "An empty JoinKeys object." ) }) -testthat::test_that("JoinKeys$print for a non-empty set", { - jk <- JoinKeys$new() - jk$set(list(join_key("DF1", "DF2", c("id" = "fk")))) +testthat::test_that("print.JoinKeys for a non-empty set", { + jk <- join_keys() + join_keys(jk) <- list(join_key("DF1", "DF2", c("id" = "fk"))) testthat::expect_output( print(jk), "A JoinKeys object containing foreign keys between 2 datasets:" @@ -559,99 +490,9 @@ testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they ) }) -testthat::test_that("JoinKeys$set_parents throws error when overwriting the parent value with a different value", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_error(jk$set_parents(list(df1 = character(0), df2 = "df5"))) -}) - -testthat::test_that("JoinKeys$set_parents works when overwriting the parent value with the same value", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) -}) - -testthat::test_that("JoinKeys$get_parent returns the parent name of the dataset", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_identical(jk$get_parent("df1"), character(0)) - testthat::expect_identical(jk$get_parent("df2"), "df1") -}) - -testthat::test_that("JoinKeys$get_parent returns NULL when dataset is not found or not passed", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_null(jk$get_parent()) - testthat::expect_null(jk$get_parent("df3")) -}) - -testthat::test_that("JoinKeys$get_parents returns a list of all parents", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_identical(jk$get_parents(), list(df1 = character(0), df2 = "df1")) -}) - -testthat::test_that("JoinKeys$get_parents returns an empty list when no parents are present", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_identical(jk$get_parents(), list()) -}) - -testthat::test_that("JoinKeys$get_parents throws error when dataname input is provided", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_error(jk$get_parents("df1"), "unused argument \\(\"df1\"\\)") -}) - -testthat::test_that("JoinKeys$update_keys_given_parents does not update the join_keys when no presents are present", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - jk$update_keys_given_parents() - testthat::expect_equal(jk, join_keys(join_key("df1", "df2", c("id" = "id")))) -}) - -testthat::test_that("JoinKeys$update_keys_given_parents updates the join_keys when presents are present", { - jk <- JoinKeys$new() - jk$set(list( - join_key("df1", "df1", c("id", "id2")), - join_key("df1", "df2", c("id" = "id")), - join_key("df1", "df3", c("id" = "id")) - )) - jk$set_parents(list(df1 = character(0), df2 = "df1", df3 = "df1")) - jk$update_keys_given_parents() - expected_jk <- join_keys( - join_key("df1", "df1", c("id", "id2")), - join_key("df1", "df2", c("id" = "id")), - join_key("df1", "df3", c("id" = "id")), - join_key("df2", "df2", c("id", "id2")), - join_key("df2", "df3", c("id", "id2")), - join_key("df3", "df3", c("id", "id2")) - ) - expected_jk$set_parents(list(df1 = character(0), df2 = "df1", df3 = "df1")) - testthat::expect_equal(jk, expected_jk) -}) - -testthat::test_that("JoinKeys$check_parent_child does nothing if no parents are present", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df1", c("id" = "id")))) - testthat::expect_identical(jk$get_parents(), list()) - testthat::expect_silent(jk$.__enclos_env__$private$check_parent_child()) -}) - -testthat::test_that("JoinKeys$check_parent_child throws error if no join_keys exist for chuld-parent", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df1", c("id" = "id")))) - jk$set_parents(list(df1 = character(0), df2 = "df1", df3 = "df1")) - testthat::expect_error( - jk$.__enclos_env__$private$check_parent_child(), - "No join keys from df2 to its parent \\(df1\\) and vice versa" - ) -}) +# ----------------------------------------------------------------------------- +# +# cdisc_join_keys test_that("cdisc_join_keys will generate JoinKeys for named list with non-named elements", { new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) @@ -741,33 +582,24 @@ test_that("cdisc_join_keys does nothing with TealDataset", { expect_length(join_keys(cdisc_join_keys(adae_cdc))$get(), 0) }) -test_that("[.JoinKeys returns the primary key if arguments only have 1 dataset", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - expect_failure(expect_identical(jk$get("ds1"), jk["ds1"])) - checkmate::expect_character(jk["ds1"]) -}) - -test_that("[.JoinKeys subsets relationship pair successfully", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - expect_identical(jk$get("ds1", "ds1"), jk["ds1"]) -}) +# ----------------------------------------------------------------------------- +# +# Subset-JoinKeys test_that("[<-.JoinKeys assigns new relationship pair", { jk <- join_keys(join_key("ds1", keys = c("id"))) - expect_length(jk$get("ds1", "ds2"), 0) + expect_length(jk["ds1", "ds2"], 0) jk["ds1", "ds2"] <- c("id") - expect_identical(jk$get("ds1", "ds2"), c(id = "id")) - expect_identical(jk$get("ds1", "ds2"), jk["ds1", "ds2"]) + expect_identical(jk["ds1", "ds2"], c(id = "id")) + expect_identical(get_join_key(jk, "ds1", "ds2"), jk["ds1", "ds2"]) }) test_that("[<-.JoinKeys modifies existing relationship pair", { jk <- join_keys(join_key("ds1", keys = c("id"))) jk["ds1", "ds1"] <- c("Species") - expect_failure(expect_identical(jk$get("ds1", "ds1"), c(id = "id"))) - expect_identical(jk$get("ds1", "ds1"), c(Species = "Species")) + expect_failure(expect_identical(jk["ds1", "ds1"], c(id = "id"))) + expect_identical(get_join_key(jk, "ds1", "ds1"), c(Species = "Species")) }) diff --git a/tests/testthat/test-get_join_keys.R b/tests/testthat/test-get_join_keys.R index c52e6f7e4..e69de29bb 100644 --- a/tests/testthat/test-get_join_keys.R +++ b/tests/testthat/test-get_join_keys.R @@ -1,23 +0,0 @@ -test_that("join_keys.teal_data will successfully obtain object from teal_data", { - obj <- helper_generator_teal_data() - - expect_identical(obj@join_keys, join_keys(obj)) - helper_test_getter_join_keys(obj, "ds1") -}) - -test_that("join_keys.JoinKeys will return itself", { - obj <- helper_generator_JoinKeys() - - expect_identical(obj, join_keys(obj)) - helper_test_getter_join_keys(obj, "ds1") -}) - -test_that("join_keys<-.teal_data", { - obj <- helper_generator_teal_data() - helper_test_getter_join_keys_add(obj, "ds1", "ds2") -}) - -test_that("join_keys<-.JoinKeys", { - obj <- helper_generator_JoinKeys() - helper_test_getter_join_keys_add(obj, "ds1", "ds2") -}) diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R new file mode 100644 index 000000000..3a1961fb0 --- /dev/null +++ b/tests/testthat/test-join_key.R @@ -0,0 +1,50 @@ +test_that("join_key throws error with invalid keys arguments", { + # invalid types + expect_error(join_key("d1", "d2", keys = NULL)) + expect_error(join_key("d1", "d2", keys = 1:10)) + + # not fully named + expect_error(join_key("d1", "d2", keys = c("X" = "A", "B")), NA) + keys <- c("A", "C" = "B") + names(keys)[1] <- "" + expect_error(join_key("d1", "d2", keys), NA) + + # duplicates in names or values + expect_error(join_key("d1", "d2", keys = c("A" = "A", "A" = "B"))) + expect_error(join_key("d1", "d2", keys = c("C" = "A", "D" = "A"))) + + # names(keys)!= keys if datasets are the same + expect_error(join_key("d1", "d1", keys = c("B" = "A", "A" = "B"))) + expect_error(join_key("d1", keys = c("B" = "A", "A" = "B"))) +}) + +test_that("join_key throws error with invalid dataset arguments", { + # missing + expect_error(join_key("d1", as.character(NA), keys = c("A" = "B", "C" = "D"))) + # invalid type + expect_error(join_key("d1", 5, keys = c("A" = "B", "C" = "D"))) + # invalid length + expect_error(join_key("d1", c("d1", "d2"), keys = c("A" = "B", "C" = "D"))) +}) + +test_that("join_key does not throw error with valid arguments", { + # keys of length 0 + expect_silent(join_key("d1", "d2", keys = character(0))) + # keys of length 1 + expect_silent(join_key("d1", "d2", keys = c("A" = "B"))) + # keys of length > 1 + expect_silent(join_key("d1", "d2", keys = c("A" = "B", "C" = "D"))) + # dataset_1 and dataset_2 can be the same if keys match + expect_silent(join_key("d1", "d1", keys = c("A" = "A", "B" = "B"))) + + expect_silent(join_key("d1", keys = c("A" = "A", "B" = "B"))) +}) + +test_that("join_key will fill empty names with value", { + # keys of length 0 + jk <- join_key("d1", "d2", keys = c("A" = "B", "C")) + expect_identical(jk$keys, setNames(c("B", "C"), c("A", "C"))) + + jk <- join_key("d1", "d2", keys = c("B", "C")) + expect_identical(jk$keys, setNames(c("B", "C"), c("B", "C"))) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R new file mode 100644 index 000000000..fd83ad94b --- /dev/null +++ b/tests/testthat/test-join_keys.R @@ -0,0 +1,92 @@ +test_that("join_keys.teal_data will successfully obtain object from teal_data", { + obj <- helper_generator_teal_data() + + expect_identical(obj@join_keys, join_keys(obj)) + helper_test_getter_join_keys(obj, "ds1") +}) + +test_that("join_keys.JoinKeys will return itself", { + obj <- helper_generator_JoinKeys() + + expect_identical(obj, join_keys(obj)) + helper_test_getter_join_keys(obj, "ds1") +}) + +test_that("join_keys<-.teal_data", { + obj <- helper_generator_teal_data() + helper_test_getter_join_keys_add(obj, "ds1", "ds2") +}) + +test_that("join_keys<-.JoinKeys", { + obj <- helper_generator_JoinKeys() + helper_test_getter_join_keys_add(obj, "ds1", "ds2") +}) + +# ----------------------------------------------------------------------------- +# +# mutate_join_keys (empty value name) +# + +test_that("mutate_join_keys with empty name is changed to the key value", { + jk <- new_join_keys() + + # set empty key name + jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "C")) + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + + # set key on non-empty variable name equal to "" + jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "C" = "")) + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + + # set key on empty variable name equal to "" + jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "")) + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) +}) + +test_that("[<-.JoinKeys with empty name is changed to the key value", { + jk <- new_join_keys() + + # set empty key name + jk["d1", "d2"] <- c("A" = "B", "C") + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + + # set key on non-empty variable name equal to "" + jk["d1", "d2"] <- c("A" = "B", "C" = "") + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + + # set key on empty variable name equal to "" + jk["d1", "d2"] <- c("A" = "B", "") + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) +}) + +test_that("join_keys()[]<-.Placeholder with empty name is changed to the key value", { + jk <- new_join_keys() + + # set empty key name + join_keys(jk)["d1", "d2"] <- c("A" = "B", "C") + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + + # set key on non-empty variable name equal to "" + join_keys(jk)["d1", "d2"] <- c("A" = "B", "C" = "") + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + + # set key on empty variable name equal to "" + join_keys(jk)["d1", "d2"] <- c("A" = "B", "") + expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) +}) + +test_that("join_keys()[]<-.teal_data with empty name is changed to the key value", { + td <- teal_data() + + # set empty key name + join_keys(td)["d1", "d2"] <- c("A" = "B", "C") + expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + + # set key on non-empty variable name equal to "" + join_keys(td)["d1", "d2"] <- c("A" = "B", "C" = "") + expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + + # set key on empty variable name equal to "" + join_keys(td)["d1", "d2"] <- c("A" = "B", "") + expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", ""))) +}) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 6bdbfc399..9aace042d 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -1,15 +1,15 @@ test_that("parents will return empty list when empty/not set", { - jk <- new_join_keys() + jk <- join_keys() expect_identical(parents(jk), list()) }) test_that("parents will return empty NULL when there is no parent", { - jk <- new_join_keys() + jk <- join_keys() expect_null(parents(jk)[["ds1"]]) }) test_that("parents<- will add to parents attribute using `[` notation", { - jk <- new_join_keys() + jk <- join_keys() parents(jk)["ds1"] <- "ds2" parents(jk)["ds3"] <- "ds4" @@ -18,7 +18,7 @@ test_that("parents<- will add to parents attribute using `[` notation", { }) test_that("parents<- will add to parents attribute using `[[` notation", { - jk <- new_join_keys() + jk <- join_keys() parents(jk)[["ds1"]] <- "ds2" parents(jk)[["ds3"]] <- "ds4" @@ -27,7 +27,7 @@ test_that("parents<- will add to parents attribute using `[[` notation", { }) test_that("parents<- will add to parents attribute using list", { - jk <- new_join_keys() + jk <- join_keys() parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") expect_length(parents(jk), 2) @@ -35,7 +35,7 @@ test_that("parents<- will add to parents attribute using list", { }) test_that("parents<- will add to parents attribute using list, `[` and `[[` notation", { - jk <- new_join_keys() + jk <- join_keys() parents(jk)[["ds1"]] <- "ds2" parents(jk) <- list(ds3 = "ds4", "ds5" = "ds6") parents(jk)["ds7"] <- "ds8" @@ -45,27 +45,133 @@ test_that("parents<- will add to parents attribute using list, `[` and `[[` nota }) test_that("check_parent_child will detect empty keys", { - jk <- new_join_keys() + jk <- join_keys() jk["ds1", "ds2"] <- character(0) parents(jk) <- list(ds1 = "ds2") expect_error(check_parent_child(jk)) }) test_that("check_parent_child will detect invalid key pairs", { - jk <- new_join_keys() - jk[["ds1"]][["ds2"]] <- "key1" - jk[["ds2"]][["ds1"]] <- character(0) + jk <- join_keys() + jk["ds1", "ds2"] <- "key1" + jk["ds2", "ds1"] <- character(0) parents(jk) <- list(ds1 = "ds2") expect_error(check_parent_child(jk)) - jk <- new_join_keys() - jk[["ds2"]][["ds1"]] <- "key1" - jk[["ds1"]][["ds2"]] <- character(0) - parents(jk) <- list(ds1 = "ds2") - expect_error(check_parent_child(jk)) + jk2 <- join_keys() + jk2["ds2", "ds1"] <- "key1" + jk2["ds1", "ds2"] <- character(0) + parents(jk2) <- list(ds1 = "ds2") + expect_error(check_parent_child(jk2)) }) test_that("check_parent_child will skip empty JoinKeys", { - jk <- new_join_keys() + jk <- join_keys() expect_silent(check_parent_child(jk)) }) + +testthat::test_that("parents<- throws error when overwriting the parent value with a different value", { + jk <- join_keys() + jk$set(list(join_key("df1", "df2", c("id" = "id")))) + testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) + testthat::expect_error(jk$set_parents(list(df1 = character(0), df2 = "df5"))) +}) + +testthat::test_that("parents<- works when overwriting the parent value with the same value", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) +}) + +testthat::test_that("parent returns the parent name of the dataset", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_identical(parent(jk, "df1"), character(0)) + testthat::expect_identical(parent(jk, "df2"), "df1") +}) + +testthat::test_that("parent returns NULL when dataset is not found or not passed", { + jk <- join_keys() + jk$set(list(join_key("df1", "df2", c("id" = "id")))) + testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) + testthat::expect_null(jk$get_parent()) + testthat::expect_null(jk$get_parent("df3")) +}) + +testthat::test_that("get_parents returns a list of all parents", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_identical(parents(jk), list(df1 = character(0), df2 = "df1")) +}) + +testthat::test_that("parents returns an empty list when no parents are present", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_identical(parents(jk), list()) +}) + +testthat::test_that("parents throws error when dataname input is provided", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_error(parents(jk, "df1"), "unused argument \\(\"df1\"\\)") +}) + +# ----------------------------------------------------------------------------- +# +# update_keys_given_parents +# + +testthat::test_that("update_keys_given_parents does not update the join_keys when no presents are present", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + jk$update_keys_given_parents() + testthat::expect_equal(jk, join_keys(join_key("df1", "df2", c("id" = "id")))) +}) + +testthat::test_that("update_keys_given_parents updates the join_keys when presents are present", { + jk <- join_keys() + + join_keys(jk) <- list( + join_key("df1", "df1", c("id", "id2")), + join_key("df1", "df2", c("id" = "id")), + join_key("df1", "df3", c("id" = "id")) + ) + + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") + jk <- update_keys_given_parents(jk) + + expected_jk <- join_keys( + join_key("df1", "df1", c("id", "id2")), + join_key("df1", "df2", c("id" = "id")), + join_key("df1", "df3", c("id" = "id")), + join_key("df2", "df2", c("id", "id2")), + join_key("df2", "df3", c("id", "id2")), + join_key("df3", "df3", c("id", "id2")) + ) + parents(expected_jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") + testthat::expect_equal(jk, expected_jk) +}) + +# ----------------------------------------------------------------------------- +# +# assert_parent_child + +testthat::test_that("assert_parent_child does nothing if no parents are present", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) + testthat::expect_identical(parents(jk), list()) + testthat::expect_silent(assert_parent_child(jk)) +}) + +testthat::test_that("JoinKeys$check_parent_child throws error if no join_keys exist for chuld-parent", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") + testthat::expect_error( + assert_parent_child(jk), + "No join keys from df2 to its parent \\(df1\\) and vice versa" + ) +}) From bff7fafd4ccb55ada956d40cec02a7463f9f9bf6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 11:45:54 +0100 Subject: [PATCH 008/152] restructure the files and pass all tests --- NAMESPACE | 1 + R/JoinKeys.R | 10 +- R/join_keys.R | 142 +++++++++++++++++--------- man/add_key.Rd | 21 ++++ man/assert_join_keys.Rd | 3 + man/get_join_keys.Rd | 12 ++- man/join_keys.Rd | 4 +- man/join_pair.Rd | 1 + man/length.JoinKeys.Rd | 11 ++ tests/testthat/helper-get_join_keys.R | 14 +-- tests/testthat/test-JoinKeys.R | 35 +++---- tests/testthat/test-cdisc_data.R | 6 +- tests/testthat/test-join_keys.R | 17 +-- tests/testthat/test-teal_data.R | 6 +- 14 files changed, 190 insertions(+), 93 deletions(-) create mode 100644 man/add_key.Rd create mode 100644 man/length.JoinKeys.Rd diff --git a/NAMESPACE b/NAMESPACE index c56e463d9..003c2b263 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,7 @@ S3method(get_raw_data,TealDatasetConnector) S3method(is_pulled,TealDataAbstract) S3method(is_pulled,TealDataset) S3method(is_pulled,TealDatasetConnector) +S3method(length,JoinKeys) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) S3method(load_datasets,TealData) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 379211b6b..4dd522d7c 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -167,9 +167,9 @@ join_keys <- function(...) { } else if (checkmate::test_list(x, len = 1, types = c("Placeholder"))) { return(x[[1]]) } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { - return(x[[1]]@join_keys) + return(x[[1]]@join_keys$get()) } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { - return(x[[1]]$get_join_keys()) + return(x[[1]]$get_join_keys()$get()) } # Constructor @@ -181,6 +181,12 @@ join_keys <- function(...) { res } +#' Length of an Object +#' @export +length.JoinKeys <- function(x) { + length(x$get()) +} + #' @title Getter for JoinKeys that returns the relationship between pairs of datasets #' @param x JoinKeys object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. diff --git a/R/join_keys.R b/R/join_keys.R index 880b6520d..e149a0d4d 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -20,18 +20,26 @@ #' # Using the setter (assignment) #' jk <- new_join_keys() #' join_keys(jk) -#' join_keys(jk) <- join_key("ds1", "ds2", "some_col2") +#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") +#' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") +#' join_keys(jk)["ds1", "ds3"] <- "some_col3" `join_keys<-.Placeholder` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } + # Assume assignment of join keys as a merge operation + # Needed to support join_keys(jk)[ds1, ds2] <- "key" if (test_join_keys(value)) { - return(value) + return(merge_join_keys(join_keys_obj, value)) } - if (length(join_keys_obj) > 0) { - stop("Keys already set, please use `mutate_join_keys(data)` or `data[ds1, ds2]<- new_key` to change them") + # Assignment of list of JoinKeySet will merge it with existing JoinKeys + if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "JoinKeySet", min.len = 1)) { + jk <- new_join_keys() + join_keys(jk) <- value + message("Keys already set, merging new list of JoinKeySet with existing keys.") + return(merge_join_keys(join_keys_obj, jk)) } if (inherits(value, "JoinKeySet")) value <- list(value) @@ -51,28 +59,48 @@ join_keys_obj } - #' @rdname get_join_keys #' @inheritParams mutate_join_keys #' @export +#' +#' @examples +#' jk <- JoinKeys$new() +#' join_keys(jk)["ds1", "ds2"] <- "key1" +#' join_keys(jk)["ds2", "ds2"] <- "key2" +#' join_keys(jk)["ds3", "ds2"] <- "key3" `join_keys<-.JoinKeys` <- function(data, value) { - if (length(data$get()) > 0) { - stop("Keys already set, please use `mutate_join_keys(data)` or `data[ds1, ds2]<- new_key` to change them") - } if (missing(value)) { return(data) } + data$set(value) data } #' @rdname get_join_keys #' @export -`join_keys<-.teal_data` <- function(data, dataset_1, dataset_2 = NULL, value) { - if (missing(dataset_1) || missing(value)) { +#' @examples +#' td <- teal_data() +#' join_keys(td)["ds1", "ds2"] <- "key1" +#' join_keys(td)["ds2", "ds2"] <- "key2" +#' join_keys(td)["ds3", "ds2"] <- "key3" +`join_keys<-.teal_data` <- function(data, value) { + if (missing(value)) { + return(data) + } + + if (test_join_keys(value) && inherits(value, "tmp_assignment")) { + # detect when coming from [<-.JoinKeys + data@join_keys$merge(value) return(data) } - data@join_keys <- mutate_join_keys(data@join_keys, dataset_1, dataset_2, value) + + if (test_join_keys(value)) { + data@join_keys$merge(jk, value) + return(data) + } + + data@join_keys$set(value) data } @@ -140,41 +168,9 @@ #' jk["ds1"] <- "primary_key" #' jk `[<-.Placeholder` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2, null.ok = TRUE) + join_keys_obj <- add_key(join_keys_obj, dataset_1, dataset_2, value) - # Normalize value - new_join_key <- join_key(dataset_1, dataset_2, value) - dataset_1 <- new_join_key$dataset_1 - dataset_2 <- new_join_key$dataset_2 - value <- new_join_key$keys - - # Create pair ds_1 -> ds_2 - if (is.null(join_keys_obj[[dataset_1]])) join_keys_obj[[dataset_1]] <- list() - - join_keys_obj[[dataset_1]][[dataset_2]] <- value - - # Primary key, do nothing else - if (identical(dataset_1, dataset_2)) { - return(join_keys_obj) - } - - # Create symmetrical pair ds_2 -> ds_1 - if (is.null(join_keys_obj[[dataset_2]])) join_keys_obj[[dataset_2]] <- list() - - if ( - checkmate::test_character(value, min.len = 1) && - all(is.null(names(value))) - ) { - value <- setNames(names(value), value) - } else if ( - checkmate::test_character(value, min.len = 1) - ) { - # Invert key - value <- setNames(names(value), value) - } - - join_keys_obj[[dataset_2]][[dataset_1]] <- value + class(join_keys_obj) <- unique(c(class(join_keys_obj), "tmp_assignment")) join_keys_obj } @@ -294,7 +290,7 @@ merge_join_keys.Placeholder <- function(join_keys_obj, new_join_keys) { for (dataset_1 in names(jk)) { for (dataset_2 in names(jk[[dataset_1]])) { - result[dataset_1, dataset_2] <- jk[[dataset_1]][[dataset_2]] + result[[dataset_1]][[dataset_2]] <- jk[[dataset_1]][[dataset_2]] } } } @@ -344,6 +340,50 @@ new_join_keys <- function() { result } +#' Internal assignment of value to a JoinKeys object +#' +#' @inheritParams join_keys +#' +#' @keywords internal +add_key <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2, null.ok = TRUE) + + # Normalize value + new_join_key <- join_key(dataset_1, dataset_2, value) + dataset_1 <- new_join_key$dataset_1 + dataset_2 <- new_join_key$dataset_2 + value <- new_join_key$keys + + # Create pair ds_1 -> ds_2 + if (is.null(join_keys_obj[[dataset_1]])) join_keys_obj[[dataset_1]] <- list() + + join_keys_obj[[dataset_1]][[dataset_2]] <- value + + # Primary key, do nothing else + if (identical(dataset_1, dataset_2)) { + return(join_keys_obj) + } + + # Create symmetrical pair ds_2 -> ds_1 + if (is.null(join_keys_obj[[dataset_2]])) join_keys_obj[[dataset_2]] <- list() + + if ( + checkmate::test_character(value, min.len = 1) && + all(is.null(names(value))) + ) { + value <- setNames(names(value), value) + } else if ( + checkmate::test_character(value, min.len = 1) + ) { + # Invert key + value <- setNames(names(value), value) + } + + join_keys_obj[[dataset_2]][[dataset_1]] <- value + join_keys_obj +} + #' Get value of a single relationship pair #' #' @param join_keys_obj (`JoinKeys`) object that holds the relationship keys. @@ -384,6 +424,7 @@ get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { #' jk <- new_join_keys() #' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) #' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) +#' jk join_pair <- function(join_keys_obj, join_key_obj) { assert_join_keys(join_keys_obj) checkmate::assert_class(join_key_obj, "JoinKeySet") @@ -392,7 +433,7 @@ join_pair <- function(join_keys_obj, join_key_obj) { dataset_2 <- join_key_obj$dataset_2 keys <- join_key_obj$keys - join_keys_obj[dataset_1, dataset_2] <- keys + join_keys_obj <- add_key(join_keys_obj, dataset_1, dataset_2, keys) join_keys_obj } @@ -408,10 +449,17 @@ assert_join_keys <- function(x, .var.name = checkmate::vname(x)) { } #' @rdname assert_join_keys +#' @keywords internal test_join_keys <- function(x) { checkmate::test_class(x, classes = c("Placeholder")) } +#' @rdname assert_join_keys +#' @keywords internal +expect_join_keys <- function(x) { + checkmate::expect_class(x, classes = c("Placeholder")) +} + #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise diff --git a/man/add_key.Rd b/man/add_key.Rd new file mode 100644 index 000000000..4a21dfe89 --- /dev/null +++ b/man/add_key.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{add_key} +\alias{add_key} +\title{Internal assignment of value to a JoinKeys object} +\usage{ +add_key(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) +} +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} + +\item{dataset_1}{(\code{character}) name of first dataset.} + +\item{dataset_2}{(\code{character}) name of second dataset.} + +\item{value}{(\code{character} vector) value to assign.} +} +\description{ +Internal assignment of value to a JoinKeys object +} +\keyword{internal} diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd index c4f2fb458..d073530f8 100644 --- a/man/assert_join_keys.Rd +++ b/man/assert_join_keys.Rd @@ -3,11 +3,14 @@ \name{assert_join_keys} \alias{assert_join_keys} \alias{test_join_keys} +\alias{expect_join_keys} \title{Check the JoinKeys class membership of an argument} \usage{ assert_join_keys(x, .var.name = checkmate::vname(x)) test_join_keys(x) + +expect_join_keys(x) } \arguments{ \item{x}{[any]\cr diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index e376678b2..9556074f8 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -13,7 +13,7 @@ get_join_keys(data, dataset_1, dataset_2 = NULL) <- value \method{join_keys}{JoinKeys}(data) <- value -\method{join_keys}{teal_data}(data, dataset_1, dataset_2 = NULL) <- value +\method{join_keys}{teal_data}(data) <- value } \arguments{ \item{data}{`` - object to extract the join keys} @@ -30,3 +30,13 @@ Either \code{JoinKeys} object or \code{NULL} if no join keys \description{ Function to get join keys from a `` object } +\examples{ +jk <- JoinKeys$new() +join_keys(jk)["ds1", "ds2"] <- "key1" +join_keys(jk)["ds2", "ds2"] <- "key2" +join_keys(jk)["ds3", "ds2"] <- "key3" +td <- teal_data() +join_keys(td)["ds1", "ds2"] <- "key1" +join_keys(td)["ds2", "ds2"] <- "key2" +join_keys(td)["ds3", "ds2"] <- "key3" +} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index f5937fccb..293bdcae8 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -75,7 +75,9 @@ cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE # Using the setter (assignment) jk <- new_join_keys() join_keys(jk) -join_keys(jk) <- join_key("ds1", "ds2", "some_col2") +join_keys(jk) <- join_key("ds1", "ds2", "some_col") +join_keys(jk) <- join_key("ds3", "ds4", "some_col2") +join_keys(jk)["ds1", "ds3"] <- "some_col3" # Getter for JoinKeys jk <- new_join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") diff --git a/man/join_pair.Rd b/man/join_pair.Rd index 49f971c37..df330bba9 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -18,4 +18,5 @@ Helper function to add a new pair to a \code{JoinKeys} object jk <- new_join_keys() jk <- join_pair(jk, join_key("ds1", "ds2", "value")) jk <- join_pair(jk, join_key("ds3", "ds2", "value")) +jk } diff --git a/man/length.JoinKeys.Rd b/man/length.JoinKeys.Rd new file mode 100644 index 000000000..03ad0961e --- /dev/null +++ b/man/length.JoinKeys.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/JoinKeys.R +\name{length.JoinKeys} +\alias{length.JoinKeys} +\title{Length of an Object} +\usage{ +\method{length}{JoinKeys}(x) +} +\description{ +Length of an Object +} diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index aaefcbf5b..58669d0b5 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -24,9 +24,9 @@ helper_generator_JoinKeys <- function(dataset_1 = "ds1", keys = c("id")) { # nol helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { jk <- join_keys(obj) - expect_s3_class(jk, c("JoinKey", "R6")) - expect_length(jk$get(), 1) - expect_length(jk$get(dataset_1), 1) + expect_join_keys(jk) + expect_length(jk, 1) + expect_length(jk[dataset_1, dataset_1], 1) obj } @@ -38,8 +38,8 @@ helper_test_getter_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset jk <- join_keys(obj) - checkmate::expect_r6(jk, c("JoinKeys")) - expect_length(jk$get(), 2) - expect_length(jk$get(dataset_1), 1) - expect_length(jk$get(new_dataset_1), 1) + expect_join_keys(jk) + expect_length(jk, 2) + expect_length(jk[dataset_1, dataset_1], 1) + expect_length(jk[new_dataset_1, new_dataset_1], 1) } diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R index 98fb421f2..f425fd27a 100644 --- a/tests/testthat/test-JoinKeys.R +++ b/tests/testthat/test-JoinKeys.R @@ -105,13 +105,6 @@ test_that("join_keys can create JoinKeys with valid arguments", { expect_silent(join_keys(join_key("d1", "d2", "X"), join_key("d2", "d1", "X"))) }) - -test_that("join_keys cannot set keys in JoinKeys if they have already been set", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_error(join_keys(my_keys) <- join_key("d1", "d3", "A")) -}) - - test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) expect_equal(my_keys["d2", "d1"], c("C" = "A")) @@ -498,33 +491,33 @@ test_that("cdisc_join_keys will generate JoinKeys for named list with non-named new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) jk <- join_keys(new_dataset) - expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk$get("ADSL", "ADTTE")), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk$get("ADTTE", "ADSL")), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will generate JoinKeys for character list", { new_dataset <- cdisc_join_keys("ADSL", "ADTTE") jk <- join_keys(new_dataset) - expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk$get("ADSL", "ADTTE")), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk$get("ADTTE", "ADSL")), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will generate JoinKeys for named list", { new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) jk <- join_keys(new_dataset) - expect_identical(unname(jk$get("ADSL", "ADSL")), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk$get("ADTTE", "ADTTE")), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk$get("ADSL", "ADTTE")), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk$get("ADTTE", "ADSL")), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { @@ -567,7 +560,7 @@ test_that("cdisc_join_keys will retrieve known primary keys", { datasets, function(.x) { jk <- cdisc_join_keys(.x) - expect_equal(unname(jk[.x]), get_cdisc_keys(.x)) + expect_equal(unname(jk[.x, .x]), get_cdisc_keys(.x)) character(0) }, character(0) @@ -579,7 +572,7 @@ test_that("cdisc_join_keys does nothing with TealDataset", { function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) ) adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - expect_length(join_keys(cdisc_join_keys(adae_cdc))$get(), 0) + expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) }) # ----------------------------------------------------------------------------- diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index 7e687fbd4..da04f1e62 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -57,7 +57,7 @@ testthat::test_that("cdisc_data sets the join_keys internally", { join_key("ADTTE", "ADAE", c("STUDYID", "USUBJID")) ) jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) - testthat::expect_equal(join_keys(data), jks) + testthat::expect_equal(join_keys(data), join_keys(jks)) # TODO: JK remove join_keys from jk_expected }) testthat::test_that( @@ -77,7 +77,7 @@ testthat::test_that( jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) testthat::expect_equal( join_keys(data), - jks + join_keys(jks) # TODO: JK remove join_keys from jk_expected ) } ) @@ -96,7 +96,7 @@ testthat::test_that("cdisc_data sets primary keys as join_keys when no join_keys join_key("df2", "df2", "df2_id") ) jks$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), jks) + testthat::expect_equal(join_keys(data), join_keys(jks)) # TODO: JK remove join_keys from jk_expected }) testthat::test_that("cdisc_data throws error when a parent/child graph is not correct", { diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index fd83ad94b..ec94cf365 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -1,14 +1,14 @@ test_that("join_keys.teal_data will successfully obtain object from teal_data", { obj <- helper_generator_teal_data() - expect_identical(obj@join_keys, join_keys(obj)) + expect_identical(obj@join_keys$get(), join_keys(obj)) helper_test_getter_join_keys(obj, "ds1") }) test_that("join_keys.JoinKeys will return itself", { obj <- helper_generator_JoinKeys() - expect_identical(obj, join_keys(obj)) + expect_identical(obj$get(), join_keys(obj)) helper_test_getter_join_keys(obj, "ds1") }) @@ -28,18 +28,16 @@ test_that("join_keys<-.JoinKeys", { # test_that("mutate_join_keys with empty name is changed to the key value", { - jk <- new_join_keys() - # set empty key name - jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "C")) + jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "C")) expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" - jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "C" = "")) + jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "C" = "")) expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) # set key on empty variable name equal to "" - jk <- mutate_join_keys(jk, "d1", "d2", c("A" = "B", "")) + jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "")) expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) @@ -61,15 +59,16 @@ test_that("[<-.JoinKeys with empty name is changed to the key value", { test_that("join_keys()[]<-.Placeholder with empty name is changed to the key value", { jk <- new_join_keys() - # set empty key name join_keys(jk)["d1", "d2"] <- c("A" = "B", "C") expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + jk <- new_join_keys() # set key on non-empty variable name equal to "" join_keys(jk)["d1", "d2"] <- c("A" = "B", "C" = "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + jk <- new_join_keys() # set key on empty variable name equal to "" join_keys(jk)["d1", "d2"] <- c("A" = "B", "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) @@ -82,10 +81,12 @@ test_that("join_keys()[]<-.teal_data with empty name is changed to the key value join_keys(td)["d1", "d2"] <- c("A" = "B", "C") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + td <- teal_data() # set key on non-empty variable name equal to "" join_keys(td)["d1", "d2"] <- c("A" = "B", "C" = "") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + td <- teal_data() # set key on empty variable name equal to "" join_keys(td)["d1", "d2"] <- c("A" = "B", "") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", ""))) diff --git a/tests/testthat/test-teal_data.R b/tests/testthat/test-teal_data.R index f84d354b6..8c448f4fb 100644 --- a/tests/testthat/test-teal_data.R +++ b/tests/testthat/test-teal_data.R @@ -146,7 +146,7 @@ testthat::test_that("teal_data sets passed join_keys to datasets correctly", { ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), jk_expected) + testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected }) testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when key names differ", { @@ -165,7 +165,7 @@ testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when k ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), jk_expected) + testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected }) testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when key names differ (multiple keys)", { @@ -182,7 +182,7 @@ testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when k join_key("df1", "df2", c(id = "fk", id2 = "fk2")) ) jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), jk_expected) + testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected }) testthat::test_that("teal_data returns TealData object with cdisc_dataset input", { From e8a47ce7a23c1298005da0a726a5f6bfdbe08744 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 12:19:28 +0100 Subject: [PATCH 009/152] corrects for R CMD checks --- R/JoinKeys.R | 31 +++++++++----- R/get_join_keys.R | 6 +-- R/join_keys.R | 69 +++++++++++++++++++------------- R/parents.R | 15 +++---- man/check_parent_child.Rd | 6 --- man/get_join_keys.Rd | 22 ++-------- man/join_keys.Rd | 33 +++++++++++++-- man/join_pair.Rd | 2 +- man/length.JoinKeys.Rd | 7 ++++ man/merge_join_keys.Rd | 4 +- man/mutate_join_keys.Rd | 10 ++--- man/parents.Rd | 6 +-- man/print.Placeholder.Rd | 4 +- man/split_join_keys.Rd | 5 ++- man/update_keys_given_parents.Rd | 2 +- 15 files changed, 129 insertions(+), 93 deletions(-) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 4dd522d7c..011891b51 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -133,15 +133,16 @@ JoinKeys <- R6::R6Class( # nolint ) ) -# constructors ==== +# Constructors ==== #' Create a `JoinKeys` out of a list of `JoinKeySet` objects #' #' @description `r lifecycle::badge("stable")` #' -#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. #' @details Note that join keys are symmetric although the relationship only needs #' to be specified once. +# +#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. #' #' @return `JoinKeys` #' @@ -149,6 +150,7 @@ JoinKeys <- R6::R6Class( # nolint #' #' @examples #' # setting join keys +#' #' join_keys( #' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), #' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) @@ -157,7 +159,6 @@ JoinKeys <- R6::R6Class( # nolint #' jk <- join_keys() #' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") #' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") -#' join_keys <- function(...) { x <- rlang::list2(...) @@ -182,6 +183,12 @@ join_keys <- function(...) { } #' Length of an Object +#' +#' @param x (`JoinKeys`) object +#' +#' @return number of relationship pairs and primary keys defined in `JoinKeys` +#' object +#' #' @export length.JoinKeys <- function(x) { length(x$get()) @@ -209,17 +216,19 @@ length.JoinKeys <- function(x) { } #' @rdname join_keys +#' #' @details #' `cdisc_join_keys` is a wrapper around `join_keys` that sets the default #' join keys for CDISC datasets. It is used internally by `cdisc_data` to #' set the default join keys for CDISC datasets. #' #' @export +#' #' @examples #' -#' # default CDISC join keys -#' cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") +#' # Default CDISC join keys #' +#' cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") cdisc_join_keys <- function(...) { data_objects <- rlang::list2(...) @@ -263,12 +272,12 @@ cdisc_join_keys <- function(...) { #' @param x (`JoinKeys`) object to be modified #' @param dataset_1 (`character`) one dataset name #' @param dataset_2 (`character`) other dataset name -#' @param val (named `character`) column names used to join +#' @param value (named `character`) column names used to join #' #' @return modified `JoinKeys` object #' #' @export -mutate_join_keys <- function(x, dataset_1, dataset_2, val) { +mutate_join_keys <- function(x, dataset_1, dataset_2, value) { UseMethod("mutate_join_keys") } @@ -285,8 +294,8 @@ mutate_join_keys <- function(x, dataset_1, dataset_2, val) { #' #' mutate_join_keys(x, "dataset_A", "dataset_B", c("col_1" = "col_10")) #' x$get("dataset_A", "dataset_B") -mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) { - x$mutate(dataset_1, dataset_2, val) +mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { + x$mutate(dataset_1, dataset_2, value) } #' @rdname mutate_join_keys @@ -305,6 +314,6 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, val) { #' #' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) #' join_keys(x)$get("ADSL", "ADRS") -mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, val) { # nolint - x$mutate_join_keys(dataset_1, dataset_2, val) +mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, value) { # nolint + x$mutate_join_keys(dataset_1, dataset_2, value) } diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 11ca23bcb..a4e274e4a 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -14,10 +14,10 @@ get_join_keys <- function(data) { #' @inheritParams mutate_join_keys #' @param value value to assign #' @export -`get_join_keys<-` <- function(data, dataset_1, dataset_2 = NULL, value) { +`get_join_keys<-` <- function(x, dataset_1, dataset_2 = NULL, value) { lifecycle::deprecate_stop( when = " 0.3.1", - what = "get_join_keys(data) <- ...", - details = "Use `join_keys(data) <- ...`" + what = "get_join_keys(x) <- ...", + details = "Use `join_keys(x) <- ...`" ) } diff --git a/R/join_keys.R b/R/join_keys.R index e149a0d4d..837c6ff09 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -17,8 +17,10 @@ #' @rdname join_keys #' @export #' @examples +#' #' # Using the setter (assignment) -#' jk <- new_join_keys() +#' +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor or constructor #' join_keys(jk) #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") @@ -59,49 +61,51 @@ join_keys_obj } -#' @rdname get_join_keys -#' @inheritParams mutate_join_keys +#' @rdname join_keys #' @export #' #' @examples +#' +#' # Using old JoinKeys +#' #' jk <- JoinKeys$new() #' join_keys(jk)["ds1", "ds2"] <- "key1" #' join_keys(jk)["ds2", "ds2"] <- "key2" #' join_keys(jk)["ds3", "ds2"] <- "key3" -`join_keys<-.JoinKeys` <- function(data, value) { +`join_keys<-.JoinKeys` <- function(join_keys_obj, value) { if (missing(value)) { - return(data) + return(join_keys_obj) } - data$set(value) - data + join_keys_obj$set(value) + join_keys_obj } -#' @rdname get_join_keys +#' @rdname join_keys #' @export #' @examples #' td <- teal_data() #' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td)["ds2", "ds2"] <- "key2" #' join_keys(td)["ds3", "ds2"] <- "key3" -`join_keys<-.teal_data` <- function(data, value) { +`join_keys<-.teal_data` <- function(join_keys_obj, value) { if (missing(value)) { - return(data) + return(join_keys_obj) } if (test_join_keys(value) && inherits(value, "tmp_assignment")) { # detect when coming from [<-.JoinKeys - data@join_keys$merge(value) - return(data) + join_keys_obj@join_keys$merge(value) + return(join_keys_obj) } if (test_join_keys(value)) { - data@join_keys$merge(jk, value) - return(data) + join_keys_obj@join_keys$merge(join_keys_obj, value) + return(join_keys_obj) } - data@join_keys$set(value) - data + join_keys_obj@join_keys$set(value) + join_keys_obj } #' @details @@ -116,8 +120,10 @@ #' @export #' #' @examples +#' #' # Getter for JoinKeys -#' jk <- new_join_keys() +#' +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' jk["ds1", "ds2"] #' jk["ds1"] @@ -159,11 +165,15 @@ #' @export #' #' @examples +#' #' # Setter via index -#' jk <- new_join_keys() +#' +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") +#' #' # overwrites previously defined key #' jk["ds1", "ds2"] <- "(new) pair key" +#' #' # Creates primary key by only defining `dataset_1` #' jk["ds1"] <- "primary_key" #' jk @@ -178,7 +188,7 @@ #' @rdname mutate_join_keys #' @export #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) #' mutate_join_keys(jk, "ds2", "ds3", "another") mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { @@ -193,7 +203,7 @@ mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { "JoinKeys updated the keys between %s and %s to %s", dataset_1, dataset_2, - paste(val, collapse = ", ") + paste(value, collapse = ", ") ) ) @@ -212,13 +222,18 @@ split_join_keys.default <- function(join_keys_obj) { split_join_keys(join_keys(join_keys_obj)) } -#' @rdname split_join_keys -#' @title Split the `JoinKeys` object into a named list of join keys objects with an element for each dataset +#' Split the `JoinKeys` object into a named list of join keys objects with an element for each dataset +#' +#' @param join_keys_obj (`JoinKeys`) base object to get the keys from. #' #' @return (`list`) a list of `JoinKeys` object +#' +#' @rdname split_join_keys +#' #' @export +#' #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' jk["ds1", "ds2"] <- "some_col" #' jk["ds1", "ds3"] <- "new_col" #' split_join_keys(jk) @@ -265,10 +280,10 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' @export #' #' @examples -#' jk1 <- new_join_keys() +#' jk1 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' jk1["ds1", "ds2"] <- "some_col" #' -#' jk2 <- new_join_keys() +#' jk2 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' jk2["ds1", "ds3"] <- "new_col" #' #' merge_join_keys(jk1, jk2) @@ -300,7 +315,7 @@ merge_join_keys.Placeholder <- function(join_keys_obj, new_join_keys) { #' Prints `JoinKeys`. #' -#' @param ... additional arguments to the printing method +#' @inheritParams base::print #' @return the `x` parameter #' #' @export @@ -421,7 +436,7 @@ get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { #' @param join_key_obj (`JoinKeySet`) relationship pair to add. #' #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) #' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) #' jk diff --git a/R/parents.R b/R/parents.R index 2682642d6..f0c968dbf 100644 --- a/R/parents.R +++ b/R/parents.R @@ -35,7 +35,7 @@ parents.JoinKeys <- function(join_keys_obj) { #' @rdname parents #' @export #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' parents(jk) parents.Placeholder <- function(join_keys_obj) { rlang::`%||%`(attr(join_keys_obj, "__parents__"), list()) @@ -48,7 +48,7 @@ parents.Placeholder <- function(join_keys_obj) { #' @export #' #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' parents(jk) <- list(ADSL = "ADTTE") `parents<-` <- function(join_keys_obj, value) { UseMethod("parents<-", join_keys_obj) @@ -68,7 +68,7 @@ parents.Placeholder <- function(join_keys_obj) { #' @rdname parents #' @export #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") #' parents(jk)["ADTTE"] <- "ADSL" #' parents(jk)["ADTTE"] <- "ADSL2" @@ -107,7 +107,7 @@ parents.Placeholder <- function(join_keys_obj) { #' @export #' #' @examples -#' jk <- new_join_keys() +#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() #' join_keys(jk) <- list( #' join_key("df1", "df1", c("id", "id2")), #' join_key("df1", "df2", c("id" = "id")), @@ -121,7 +121,7 @@ parents.Placeholder <- function(join_keys_obj) { update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) - checkmate::assert_class(jk, "Placeholder", .var.name = vname(join_keys_obj)) + checkmate::assert_class(jk, "Placeholder", .var.name = checkmate::vname(join_keys_obj)) datanames <- names(jk) duplicate_pairs <- list() @@ -167,11 +167,6 @@ update_keys_given_parents <- function(join_keys_obj) { #' Check if parent/child are valid #' #' @keywords internal -#' @examples -#' jk <- new_join_keys() -#' jk["ds1", "ds2"] <- character(0) -#' parents(jk) <- list(ds1 = "ds2") -#' check_parent_child(jk) check_parent_child <- function(join_keys_obj) { jk_parents <- parents(join_keys_obj) if (length(jk_parents) > 0) { diff --git a/man/check_parent_child.Rd b/man/check_parent_child.Rd index b915aec2f..0e762a2eb 100644 --- a/man/check_parent_child.Rd +++ b/man/check_parent_child.Rd @@ -9,10 +9,4 @@ check_parent_child(join_keys_obj) \description{ Check if parent/child are valid } -\examples{ -jk <- new_join_keys() -jk["ds1", "ds2"] <- character(0) -parents(jk) <- list(ds1 = "ds2") -check_parent_child(jk) -} \keyword{internal} diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 9556074f8..2b643dd87 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -1,23 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_join_keys.R, R/join_keys.R +% Please edit documentation in R/get_join_keys.R \name{get_join_keys} \alias{get_join_keys} \alias{get_join_keys<-} -\alias{join_keys<-.JoinKeys} -\alias{join_keys<-.teal_data} \title{Function to get join keys from a `` object} \usage{ get_join_keys(data) -get_join_keys(data, dataset_1, dataset_2 = NULL) <- value - -\method{join_keys}{JoinKeys}(data) <- value - -\method{join_keys}{teal_data}(data) <- value +get_join_keys(x, dataset_1, dataset_2 = NULL) <- value } \arguments{ \item{data}{`` - object to extract the join keys} +\item{x}{(\code{JoinKeys}) object to be modified} + \item{dataset_1}{(\code{character}) one dataset name} \item{dataset_2}{(\code{character}) other dataset name} @@ -30,13 +26,3 @@ Either \code{JoinKeys} object or \code{NULL} if no join keys \description{ Function to get join keys from a `` object } -\examples{ -jk <- JoinKeys$new() -join_keys(jk)["ds1", "ds2"] <- "key1" -join_keys(jk)["ds2", "ds2"] <- "key2" -join_keys(jk)["ds3", "ds2"] <- "key3" -td <- teal_data() -join_keys(td)["ds1", "ds2"] <- "key1" -join_keys(td)["ds2", "ds2"] <- "key2" -join_keys(td)["ds3", "ds2"] <- "key3" -} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 293bdcae8..cf19c57e5 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -5,6 +5,8 @@ \alias{cdisc_join_keys} \alias{join_keys<-} \alias{join_keys<-.Placeholder} +\alias{join_keys<-.JoinKeys} +\alias{join_keys<-.teal_data} \alias{[.Placeholder} \alias{[<-.Placeholder} \title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} @@ -17,6 +19,10 @@ join_keys(join_keys_obj) <- value \method{join_keys}{Placeholder}(join_keys_obj) <- value +\method{join_keys}{JoinKeys}(join_keys_obj) <- value + +\method{join_keys}{teal_data}(join_keys_obj) <- value + \method{[}{Placeholder}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) \method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value @@ -59,6 +65,7 @@ When \code{dataset_2} is omitted, it will create a primary key with \code{datase } \examples{ # setting join keys + join_keys( join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) @@ -68,27 +75,45 @@ jk <- join_keys() jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +# Default CDISC join keys -# default CDISC join keys cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") # Using the setter (assignment) -jk <- new_join_keys() + +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor or constructor join_keys(jk) join_keys(jk) <- join_key("ds1", "ds2", "some_col") join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" + +# Using old JoinKeys + +jk <- JoinKeys$new() +join_keys(jk)["ds1", "ds2"] <- "key1" +join_keys(jk)["ds2", "ds2"] <- "key2" +join_keys(jk)["ds3", "ds2"] <- "key3" +td <- teal_data() +join_keys(td)["ds1", "ds2"] <- "key1" +join_keys(td)["ds2", "ds2"] <- "key2" +join_keys(td)["ds3", "ds2"] <- "key3" + # Getter for JoinKeys -jk <- new_join_keys() + +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") jk["ds1", "ds2"] jk["ds1"] jk[["ds1"]] + # Setter via index -jk <- new_join_keys() + +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") + # overwrites previously defined key jk["ds1", "ds2"] <- "(new) pair key" + # Creates primary key by only defining `dataset_1` jk["ds1"] <- "primary_key" jk diff --git a/man/join_pair.Rd b/man/join_pair.Rd index df330bba9..00167c1a3 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -15,7 +15,7 @@ join_pair(join_keys_obj, join_key_obj) Helper function to add a new pair to a \code{JoinKeys} object } \examples{ -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() jk <- join_pair(jk, join_key("ds1", "ds2", "value")) jk <- join_pair(jk, join_key("ds3", "ds2", "value")) jk diff --git a/man/length.JoinKeys.Rd b/man/length.JoinKeys.Rd index 03ad0961e..43bf3deb1 100644 --- a/man/length.JoinKeys.Rd +++ b/man/length.JoinKeys.Rd @@ -6,6 +6,13 @@ \usage{ \method{length}{JoinKeys}(x) } +\arguments{ +\item{x}{(\code{JoinKeys}) object} +} +\value{ +number of relationship pairs and primary keys defined in \code{JoinKeys} +object +} \description{ Length of an Object } diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index b39409289..2faf54a20 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -24,10 +24,10 @@ a new \code{JoinKeys} object with the resulting merge. Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object } \examples{ -jk1 <- new_join_keys() +jk1 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() jk1["ds1", "ds2"] <- "some_col" -jk2 <- new_join_keys() +jk2 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() jk2["ds1", "ds3"] <- "new_col" merge_join_keys(jk1, jk2) diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 5f5dcf49e..7b2539102 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -7,11 +7,11 @@ \alias{mutate_join_keys.Placeholder} \title{Mutate \code{JoinKeys} with a new values} \usage{ -mutate_join_keys(x, dataset_1, dataset_2, val) +mutate_join_keys(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, val) +\method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{TealData}(x, dataset_1, dataset_2, val) +\method{mutate_join_keys}{TealData}(x, dataset_1, dataset_2, value) \method{mutate_join_keys}{Placeholder}(x, dataset_1, dataset_2, value) } @@ -22,7 +22,7 @@ mutate_join_keys(x, dataset_1, dataset_2, val) \item{dataset_2}{(\code{character}) other dataset name} -\item{val}{(named \code{character}) column names used to join} +\item{value}{(named \code{character}) column names used to join} } \value{ modified \code{JoinKeys} object @@ -55,7 +55,7 @@ join_keys(x)$get("ADSL", "ADRS") mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) join_keys(x)$get("ADSL", "ADRS") -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) mutate_join_keys(jk, "ds2", "ds3", "another") } diff --git a/man/parents.Rd b/man/parents.Rd index 229fccfde..d9574469f 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -33,11 +33,11 @@ a list of \code{character} representing the parents. Getter and setter functions for parents attribute of \code{JoinKeys} } \examples{ -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() parents(jk) -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() parents(jk) <- list(ADSL = "ADTTE") -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") parents(jk)["ADTTE"] <- "ADSL" parents(jk)["ADTTE"] <- "ADSL2" diff --git a/man/print.Placeholder.Rd b/man/print.Placeholder.Rd index 6a2656639..b268ca61d 100644 --- a/man/print.Placeholder.Rd +++ b/man/print.Placeholder.Rd @@ -7,7 +7,9 @@ \method{print}{Placeholder}(x, ...) } \arguments{ -\item{...}{additional arguments to the printing method} +\item{x}{an object used to select a method.} + +\item{...}{further arguments passed to or from other methods.} } \value{ the \code{x} parameter diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd index e8354d523..3a1151836 100644 --- a/man/split_join_keys.Rd +++ b/man/split_join_keys.Rd @@ -12,6 +12,9 @@ split_join_keys(join_keys_obj) \method{split_join_keys}{Placeholder}(join_keys_obj) } +\arguments{ +\item{join_keys_obj}{(\code{JoinKeys}) base object to get the keys from.} +} \value{ (\code{list}) a list of \code{JoinKeys} object } @@ -19,7 +22,7 @@ split_join_keys(join_keys_obj) Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset } \examples{ -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() jk["ds1", "ds2"] <- "some_col" jk["ds1", "ds3"] <- "new_col" split_join_keys(jk) diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 3304cec92..1a772c0f9 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -16,7 +16,7 @@ update_keys_given_parents(join_keys_obj) Updates the keys of the datasets based on the parents. } \examples{ -jk <- new_join_keys() +jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() join_keys(jk) <- list( join_key("df1", "df1", c("id", "id2")), join_key("df1", "df2", c("id" = "id")), From 5ac9174547f1d8964809f91e55f79058c455b4c1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 14:36:41 +0100 Subject: [PATCH 010/152] Migration of R6 -> List. All test ok --- NAMESPACE | 13 +- R/JoinKeys.R | 219 ++------------ R/TealData.R | 6 +- R/cdisc_data.R | 8 +- R/join_keys.R | 79 ++--- R/parents.R | 34 +-- R/teal_data-class.R | 2 +- R/teal_data.R | 14 +- man/JoinKeys.Rd | 271 ------------------ man/join_keys.Rd | 29 +- man/join_pair.Rd | 2 +- man/length.JoinKeys.Rd | 18 -- man/merge_join_keys.Rd | 8 +- man/mutate_join_keys.Rd | 19 +- man/new_teal_data.Rd | 2 +- man/parents.Rd | 12 +- ...print.Placeholder.Rd => print.JoinKeys.Rd} | 6 +- man/split_join_keys.Rd | 6 +- man/sub-.JoinKeys.Rd | 23 -- man/update_keys_given_parents.Rd | 2 +- tests/testthat/test-JoinKeys.R | 40 +-- tests/testthat/test-cdisc_data.R | 13 +- tests/testthat/test-join_keys.R | 30 +- tests/testthat/test-parents.R | 16 +- tests/testthat/test-teal_data.R | 18 +- 25 files changed, 163 insertions(+), 727 deletions(-) delete mode 100644 man/JoinKeys.Rd delete mode 100644 man/length.JoinKeys.Rd rename man/{print.Placeholder.Rd => print.JoinKeys.Rd} (79%) delete mode 100644 man/sub-.JoinKeys.Rd diff --git a/NAMESPACE b/NAMESPACE index 003c2b263..769ac4ad3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,10 @@ # Generated by roxygen2: do not edit by hand S3method("[",JoinKeys) -S3method("[",Placeholder) S3method("[<-",JoinKeys) -S3method("[<-",Placeholder) S3method("join_keys<-",JoinKeys) -S3method("join_keys<-",Placeholder) S3method("join_keys<-",teal_data) S3method("parents<-",JoinKeys) -S3method("parents<-",Placeholder) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(dataset,MultiAssayExperiment) @@ -42,32 +38,29 @@ S3method(get_raw_data,TealDatasetConnector) S3method(is_pulled,TealDataAbstract) S3method(is_pulled,TealDataset) S3method(is_pulled,TealDatasetConnector) -S3method(length,JoinKeys) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) S3method(load_datasets,TealData) S3method(load_datasets,TealDataConnector) S3method(load_datasets,TealDataset) S3method(load_datasets,TealDatasetConnector) -S3method(merge_join_keys,Placeholder) +S3method(merge_join_keys,JoinKeys) S3method(merge_join_keys,default) S3method(mutate_data,TealDataAbstract) S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) S3method(mutate_join_keys,JoinKeys) -S3method(mutate_join_keys,Placeholder) S3method(mutate_join_keys,TealData) S3method(parents,JoinKeys) -S3method(parents,Placeholder) -S3method(print,Placeholder) +S3method(print,JoinKeys) S3method(set_args,CallableCode) S3method(set_args,CallableFunction) S3method(set_args,TealDatasetConnector) S3method(set_keys,TealDataAbstract) S3method(set_keys,TealDataset) S3method(set_keys,TealDatasetConnector) -S3method(split_join_keys,Placeholder) +S3method(split_join_keys,JoinKeys) S3method(split_join_keys,default) S3method(to_relational_data,MultiAssayExperiment) S3method(to_relational_data,TealDataset) diff --git a/R/JoinKeys.R b/R/JoinKeys.R index 011891b51..1df4a3101 100644 --- a/R/JoinKeys.R +++ b/R/JoinKeys.R @@ -1,138 +1,3 @@ -## JoinKeys ==== -#' -#' -#' @title R6 Class to store relationships for joining datasets -#' -#' @description `r lifecycle::badge("stable")` -#' This class stores symmetric links between pairs of key-values -#' (e.g. column A of dataset X can be joined with column B of dataset Y). This relationship -#' is more general than the SQL foreign key relationship which also imposes constraints on the values -#' of these columns. -#' @param dataset_1 (`character`) one dataset name -#' @param dataset_2 (`character`) other dataset name -#' -#' @examples -#' x <- teal.data:::JoinKeys$new() -#' x$set( -#' list( -#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), -#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) -#' ) -#' ) -#' x$get() -#' x$mutate("dataset_A", "dataset_B", c("col1" = "col10")) -#' x$get("dataset_A", "dataset_B") -JoinKeys <- R6::R6Class( # nolint - classname = "JoinKeys", - ## __Public Methods ==== - public = list( - #' @description - #' Create a new object of `JoinKeys` - #' @return empty (`JoinKeys`) - initialize = function() { - logger::log_trace("JoinKeys initialized.") - class(private$.keys) <- class(new_join_keys()) - return(invisible(self)) - }, - #' @description - #' Split the current `JoinKeys` object into a named list of join keys objects with an element for each dataset - #' @return (`list`) a list of `JoinKeys` object - split = function() { - split_join_keys(private$.keys) - }, - #' @description - #' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object - #' @param x `list` of `JoinKeys` objects or single `JoinKeys` object - #' @return (`self`) invisibly for chaining - merge = function(x) { - private$.keys <- merge_join_keys(private$.keys, x) - }, - #' @description - #' Get join keys between two datasets. - #' @return (`character`) named character vector x with names(x) the - #' columns of `dataset_1` and the values of `(x)` the corresponding join - #' keys in `dataset_2` or `character(0)` if no relationship - #' @details if one or both of `dataset_1` and `dataset_2` are missing then - #' underlying keys structure is returned for further processing - get = function(dataset_1, dataset_2) { - get_join_key(private$.keys, dataset_1, dataset_2) - }, - #' @description - #' Change join_keys for a given pair of dataset names (or - #' add join_keys for given pair if it does not exist) - #' @param val (named `character`) column names used to join - #' @return (`self`) invisibly for chaining - mutate = function(dataset_1, dataset_2, val) { - private$.keys <- mutate_join_keys(private$.keys, dataset_1, dataset_2, val) - return(invisible(self)) - }, - #' @description - #' Set up join keys basing on list of `JoinKeySet` objects. - #' @param x `list` of `JoinKeySet` objects (which are created using the `join_key` function) - #' or single `JoinKeySet` objects - #' @details Note that join keys are symmetric although the relationship only needs - #' to be specified once - #' @return (`self`) invisibly for chaining - set = function(x) { - join_keys(private$.keys) <- x - return(invisible(self)) - }, - #' @description - #' Prints this `JoinKeys`. - #' - #' @param ... additional arguments to the printing method - #' @return invisibly self - print = function(...) { - print.Placeholder(private$.keys) - }, - #' @description - #' Sets the parents of the datasets. - #' - #' @param named_list Named (`list`) of the parents datasets. - #' - #' @return (`self`) invisibly for chaining - set_parents = function(named_list) { - parents(private$.keys) <- named_list - invisible(self) - }, - #' @description - #' Gets the parent of the desired dataset. - #' - #' @param dataname (`character`) name of the dataset. - #' @return (`character`) the parent of the desired dataset - get_parent = function(dataname) { - if (missing(dataname)) { - return(NULL) - } - parent(private$.keys, dataname) - }, - #' @description - #' Gets the parents of the datasets. - #' - #' @return (`list`) A named list of the parents of all datasets - get_parents = function() { - parents(private$.keys) - }, - #' @description - #' Updates the keys of the datasets based on the parents. - #' - #' @return (`self`) invisibly for chaining - update_keys_given_parents = function() { - private$.keys <- update_keys_given_parents(private$.keys) - - invisible(self) - } - ), - ## __Private Fields ==== - private = list( - .keys = list(), - check_parent_child = function() { - # Needed for a single test - assert_parent_child(private$.keys) - } - ) -) - # Constructors ==== #' Create a `JoinKeys` out of a list of `JoinKeySet` objects @@ -151,70 +16,38 @@ JoinKeys <- R6::R6Class( # nolint #' @examples #' # setting join keys #' -#' join_keys( +#' jk <- join_keys( #' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), #' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) #' ) +#' jk +#' #' # or #' jk <- join_keys() #' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") #' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +#' jk join_keys <- function(...) { x <- rlang::list2(...) # Getter if (checkmate::test_list(x, len = 1, types = c("JoinKeys"))) { - return(x[[1]]$get()) - } else if (checkmate::test_list(x, len = 1, types = c("Placeholder"))) { return(x[[1]]) } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { - return(x[[1]]@join_keys$get()) + return(x[[1]]@join_keys) } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { - return(x[[1]]$get_join_keys()$get()) + return(x[[1]]$get_join_keys()) } # Constructor - res <- JoinKeys$new() + res <- new_join_keys() if (length(x) > 0) { - res$set(x) + join_keys(res) <- x } res } -#' Length of an Object -#' -#' @param x (`JoinKeys`) object -#' -#' @return number of relationship pairs and primary keys defined in `JoinKeys` -#' object -#' -#' @export -length.JoinKeys <- function(x) { - length(x$get()) -} - -#' @title Getter for JoinKeys that returns the relationship between pairs of datasets -#' @param x JoinKeys object to extract the join keys -#' @param dataset_1 (`character`) name of first dataset. -#' @param dataset_2 (`character`) name of second dataset. -#' @export -`[.JoinKeys` <- function(x, dataset_1 = NULL, dataset_2 = NULL) { - checkmate::assert_string(dataset_1, null.ok = TRUE) - checkmate::assert_string(dataset_2, null.ok = TRUE) - x$get(dataset_1, dataset_2) -} - -#' @rdname sub-.JoinKeys -#' @param value value to assign -#' @export -`[<-.JoinKeys` <- function(x, dataset_1, dataset_2 = dataset_1, value) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2) - x$mutate(dataset_1, dataset_2, value) - x -} - #' @rdname join_keys #' #' @details @@ -232,18 +65,16 @@ length.JoinKeys <- function(x) { cdisc_join_keys <- function(...) { data_objects <- rlang::list2(...) - join_keys <- join_keys() - lapply(seq_along(data_objects), function(ix) { + jk <- join_keys() + for (ix in seq_along(data_objects)) { item <- data_objects[[ix]] name <- names(data_objects)[ix] if (checkmate::test_class(item, "JoinKeySet")) { - join_keys$set(item) - return(NULL) + jk[item$dataset_1, item$dataset_2] <- item$keys } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { - return(NULL) } else { if ((is.null(name) || identical(trimws(name), "")) && is.character(item)) { name <- item @@ -251,16 +82,16 @@ cdisc_join_keys <- function(...) { if (name %in% names(default_cdisc_keys)) { # Set default primary keys keys_list <- default_cdisc_keys[[name]] - join_keys[name] <- keys_list$primary + jk[name] <- keys_list$primary if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { - join_keys[name, keys_list$parent] <- keys_list$foreign + jk[name, keys_list$parent] <- keys_list$foreign } } } - }) + } - join_keys + jk } # wrappers ==== @@ -281,23 +112,6 @@ mutate_join_keys <- function(x, dataset_1, dataset_2, value) { UseMethod("mutate_join_keys") } -#' @rdname mutate_join_keys -#' @export -#' @examples -#' # JoinKeys ---- -#' -#' x <- join_keys( -#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), -#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) -#' ) -#' x$get("dataset_A", "dataset_B") -#' -#' mutate_join_keys(x, "dataset_A", "dataset_B", c("col_1" = "col_10")) -#' x$get("dataset_A", "dataset_B") -mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { - x$mutate(dataset_1, dataset_2, value) -} - #' @rdname mutate_join_keys #' @export #' @examples @@ -315,5 +129,6 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { #' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) #' join_keys(x)$get("ADSL", "ADRS") mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, value) { # nolint - x$mutate_join_keys(dataset_1, dataset_2, value) + x@join_keys <- mutate_join_keys(x@join_keys, dataset_1, dataset_2, value) + x@join_keys } diff --git a/R/TealData.R b/R/TealData.R index baea9488b..b5823e585 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -180,7 +180,7 @@ TealData <- R6::R6Class( # nolint if (missing(dataset_1) && missing(dataset_2)) { private$join_keys } else { - private$join_keys$get(dataset_1, dataset_2) + private$join_keys[dataset_1, dataset_2] } }, @@ -189,7 +189,7 @@ TealData <- R6::R6Class( # nolint #' #' @return named (`list`) of the parents of all datasets. get_parents = function() { - private$join_keys$get_parents() + parents(private$join_keys) }, # ___ shiny ==== @@ -294,7 +294,7 @@ TealData <- R6::R6Class( # nolint #' @param val (named `character`) column names used to join #' @return (`self`) invisibly for chaining mutate_join_keys = function(dataset_1, dataset_2, val) { - private$join_keys$mutate(dataset_1, dataset_2, val) + private$join_keys <- mutate_join_keys(private$join_keys, dataset_1, dataset_2, val) }, # ___ check ==== diff --git a/R/cdisc_data.R b/R/cdisc_data.R index f44f8721f..e043db499 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -54,8 +54,9 @@ deprecated_join_keys_extract <- function(data_objects, join_keys) { ) { return(join_keys) } + # TODO: check if redundant with same call in teal_data body - update_join_keys_to_primary(data_objects, join_keys) + join_keys <- update_join_keys_to_primary(data_objects, join_keys) new_parents_fun <- function(data_objects) { lapply( @@ -88,8 +89,9 @@ deprecated_join_keys_extract <- function(data_objects, join_keys) { if (is_dag(new_parents)) { stop("Cycle detected in a parent and child dataset graph.") } - join_keys$set_parents(new_parents) - join_keys$update_keys_given_parents() + + parents(join_keys) <- new_parents + join_keys <- update_keys_given_parents(join_keys) join_keys } diff --git a/R/join_keys.R b/R/join_keys.R index 837c6ff09..5966a173b 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -20,12 +20,12 @@ #' #' # Using the setter (assignment) #' -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor or constructor +#' jk <- join_keys() #' join_keys(jk) #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") #' join_keys(jk)["ds1", "ds3"] <- "some_col3" -`join_keys<-.Placeholder` <- function(join_keys_obj, value) { +`join_keys<-.JoinKeys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } @@ -63,27 +63,8 @@ #' @rdname join_keys #' @export -#' #' @examples #' -#' # Using old JoinKeys -#' -#' jk <- JoinKeys$new() -#' join_keys(jk)["ds1", "ds2"] <- "key1" -#' join_keys(jk)["ds2", "ds2"] <- "key2" -#' join_keys(jk)["ds3", "ds2"] <- "key3" -`join_keys<-.JoinKeys` <- function(join_keys_obj, value) { - if (missing(value)) { - return(join_keys_obj) - } - - join_keys_obj$set(value) - join_keys_obj -} - -#' @rdname join_keys -#' @export -#' @examples #' td <- teal_data() #' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td)["ds2", "ds2"] <- "key2" @@ -93,15 +74,9 @@ return(join_keys_obj) } - if (test_join_keys(value) && inherits(value, "tmp_assignment")) { - # detect when coming from [<-.JoinKeys - join_keys_obj@join_keys$merge(value) - return(join_keys_obj) - } - if (test_join_keys(value)) { - join_keys_obj@join_keys$merge(join_keys_obj, value) - return(join_keys_obj) + join_keys_obj@join_keys <- merge_join_keys(join_keys_obj@join_keys, value) + return(join_keys_obj@join_keys) } join_keys_obj@join_keys$set(value) @@ -123,18 +98,22 @@ #' #' # Getter for JoinKeys #' -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' jk["ds1", "ds2"] #' jk["ds1"] #' jk[["ds1"]] -`[.Placeholder` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { +`[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { if (checkmate::test_integerish(dataset_1, len = 2)) { # if dataset_1 is an index integet vector, then return itself # trick to make the following work: join_keys(jk)["ds1", "ds2"] <- "key" return(join_keys_obj) } checkmate::assert_string(dataset_1, null.ok = TRUE) + if (missing(dataset_2)) { + # protection if dataset_2 is passed through by a function + dataset_2 <- NULL + } checkmate::assert_string(dataset_2, null.ok = TRUE) if (is.null(dataset_1) && is.null(dataset_2)) { @@ -168,7 +147,7 @@ #' #' # Setter via index #' -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") #' #' # overwrites previously defined key @@ -177,7 +156,7 @@ #' # Creates primary key by only defining `dataset_1` #' jk["ds1"] <- "primary_key" #' jk -`[<-.Placeholder` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { +`[<-.JoinKeys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { join_keys_obj <- add_key(join_keys_obj, dataset_1, dataset_2, value) class(join_keys_obj) <- unique(c(class(join_keys_obj), "tmp_assignment")) @@ -188,10 +167,10 @@ #' @rdname mutate_join_keys #' @export #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) #' mutate_join_keys(jk, "ds2", "ds3", "another") -mutate_join_keys.Placeholder <- function(x, dataset_1, dataset_2, value) { +mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) checkmate::assert_character(value, any.missing = FALSE) @@ -233,11 +212,11 @@ split_join_keys.default <- function(join_keys_obj) { #' @export #' #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' jk["ds1", "ds2"] <- "some_col" #' jk["ds1", "ds3"] <- "new_col" #' split_join_keys(jk) -split_join_keys.Placeholder <- function(join_keys_obj) { +split_join_keys.JoinKeys <- function(join_keys_obj) { assert_join_keys(join_keys_obj) list_of_list_of_join_key_set <- lapply( @@ -280,29 +259,25 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' @export #' #' @examples -#' jk1 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk1 <- join_keys() #' jk1["ds1", "ds2"] <- "some_col" #' -#' jk2 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk2 <- join_keys() #' jk2["ds1", "ds3"] <- "new_col" #' #' merge_join_keys(jk1, jk2) -merge_join_keys.Placeholder <- function(join_keys_obj, new_join_keys) { +merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { assert_join_keys(join_keys_obj) - if (inherits(new_join_keys, c("JoinKeys", "Placeholder"))) { + if (test_join_keys(new_join_keys)) { new_join_keys <- list(new_join_keys) } - checkmate::assert_list(new_join_keys, types = c("JoinKeys", "Placeholder"), min.len = 1) + checkmate::assert_list(new_join_keys, types = c("JoinKeys"), min.len = 1) result <- join_keys_obj for (jk in new_join_keys) { - if (checkmate::test_class(jk, "JoinKeys")) { - jk <- jk$get() - } - for (dataset_1 in names(jk)) { for (dataset_2 in names(jk[[dataset_1]])) { result[[dataset_1]][[dataset_2]] <- jk[[dataset_1]][[dataset_2]] @@ -319,7 +294,7 @@ merge_join_keys.Placeholder <- function(join_keys_obj, new_join_keys) { #' @return the `x` parameter #' #' @export -print.Placeholder <- function(x, ...) { +print.JoinKeys <- function(x, ...) { check_ellipsis(...) keys_list <- x my_parents <- parents(keys_list) @@ -351,7 +326,7 @@ print.Placeholder <- function(x, ...) { #' @keywords internal new_join_keys <- function() { result <- list() - class(result) <- c("Placeholder", "list") + class(result) <- c("JoinKeys", "list") result } @@ -436,7 +411,7 @@ get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { #' @param join_key_obj (`JoinKeySet`) relationship pair to add. #' #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) #' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) #' jk @@ -460,19 +435,19 @@ join_pair <- function(join_keys_obj, join_key_obj) { #' #' @keywords internal assert_join_keys <- function(x, .var.name = checkmate::vname(x)) { - checkmate::assert_class(x, classes = c("Placeholder"), .var.name = .var.name) + checkmate::assert_class(x, classes = c("JoinKeys"), .var.name = .var.name) } #' @rdname assert_join_keys #' @keywords internal test_join_keys <- function(x) { - checkmate::test_class(x, classes = c("Placeholder")) + checkmate::test_class(x, classes = c("JoinKeys")) } #' @rdname assert_join_keys #' @keywords internal expect_join_keys <- function(x) { - checkmate::expect_class(x, classes = c("Placeholder")) + checkmate::expect_class(x, classes = c("JoinKeys")) } #' Helper function to assert if two key sets contain incompatible keys diff --git a/R/parents.R b/R/parents.R index f0c968dbf..c2ecd3b64 100644 --- a/R/parents.R +++ b/R/parents.R @@ -11,6 +11,9 @@ #' parents(jk) <- list("ds2" = "ds3") #' parent(jk, "ds2") parent <- function(join_keys_obj, dataset_name) { + if (missing(dataset_name)) { + return(NULL) + } checkmate::assert_string(dataset_name) # assert join_keys_obj is performed by parents() parents(join_keys_obj)[[dataset_name]] @@ -26,18 +29,12 @@ parents <- function(join_keys_obj) { UseMethod("parents", join_keys_obj) } -#' @rdname parents -#' @export -parents.JoinKeys <- function(join_keys_obj) { - parents(join_keys(join_keys_obj$get())) -} - #' @rdname parents #' @export #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' parents(jk) -parents.Placeholder <- function(join_keys_obj) { +parents.JoinKeys <- function(join_keys_obj) { rlang::`%||%`(attr(join_keys_obj, "__parents__"), list()) } @@ -48,31 +45,20 @@ parents.Placeholder <- function(join_keys_obj) { #' @export #' #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' parents(jk) <- list(ADSL = "ADTTE") `parents<-` <- function(join_keys_obj, value) { UseMethod("parents<-", join_keys_obj) } -#' @rdname parents -#' @export -`parents<-.JoinKeys` <- function(join_keys_obj, value) { - if (missing(value)) { - return(join_keys_obj) - } - jk <- join_keys_obj$get() - parents(jk) <- value - jk -} - #' @rdname parents #' @export #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") #' parents(jk)["ADTTE"] <- "ADSL" #' parents(jk)["ADTTE"] <- "ADSL2" -`parents<-.Placeholder` <- function(join_keys_obj, value) { +`parents<-.JoinKeys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } @@ -107,7 +93,7 @@ parents.Placeholder <- function(join_keys_obj) { #' @export #' #' @examples -#' jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +#' jk <- join_keys() #' join_keys(jk) <- list( #' join_key("df1", "df1", c("id", "id2")), #' join_key("df1", "df2", c("id" = "id")), @@ -121,7 +107,7 @@ parents.Placeholder <- function(join_keys_obj) { update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) - checkmate::assert_class(jk, "Placeholder", .var.name = checkmate::vname(join_keys_obj)) + checkmate::assert_class(jk, "JoinKeys", .var.name = checkmate::vname(join_keys_obj)) datanames <- names(jk) duplicate_pairs <- list() diff --git a/R/teal_data-class.R b/R/teal_data-class.R index 39efc1c21..ae7b1e637 100644 --- a/R/teal_data-class.R +++ b/R/teal_data-class.R @@ -59,7 +59,7 @@ setClass( new_teal_data <- function(data, code = character(0), join_keys = join_keys(), - datanames = union(names(data), names(join_keys$get()))) { + datanames = union(names(data), names(join_keys))) { checkmate::assert_list(data) checkmate::assert_class(join_keys, "JoinKeys") if (is.null(datanames)) datanames <- character(0) # todo: allow to specify diff --git a/R/teal_data.R b/R/teal_data.R index 037fb2650..5d73a624a 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -45,7 +45,7 @@ teal_data <- function(..., Find more information on https://github.com/insightsengineering/teal/discussions/945' )" ) - deprecated_join_keys_extract(data_objects, join_keys) + join_keys <- deprecated_join_keys_extract(data_objects, join_keys) x <- TealData$new(..., check = check, join_keys = join_keys) if (length(code) > 0 && !identical(code, "")) { @@ -114,18 +114,20 @@ teal_data_file <- function(path, code = get_code(path)) { #' #' @keywords internal update_join_keys_to_primary <- function(data_objects, join_keys) { - lapply(data_objects, function(obj) { + for (obj in data_objects) { if (inherits(obj, "TealDataConnector")) { - update_join_keys_to_primary(obj$get_items(), join_keys) + join_keys <- update_join_keys_to_primary(obj$get_items(), join_keys) } else { dataname <- obj$get_dataname() - if (length(join_keys$get(dataname, dataname)) == 0) { - join_keys$mutate( + if (length(join_keys[dataname, dataname]) == 0) { + join_keys <- mutate_join_keys( + join_keys, dataname, dataname, obj$get_keys() ) } } - }) + } + join_keys } diff --git a/man/JoinKeys.Rd b/man/JoinKeys.Rd deleted file mode 100644 index 978b19bef..000000000 --- a/man/JoinKeys.Rd +++ /dev/null @@ -1,271 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R -\name{JoinKeys} -\alias{JoinKeys} -\title{R6 Class to store relationships for joining datasets} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -This class stores symmetric links between pairs of key-values -(e.g. column A of dataset X can be joined with column B of dataset Y). This relationship -is more general than the SQL foreign key relationship which also imposes constraints on the values -of these columns. -} -\examples{ -x <- teal.data:::JoinKeys$new() -x$set( - list( - join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), - join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) - ) -) -x$get() -x$mutate("dataset_A", "dataset_B", c("col1" = "col10")) -x$get("dataset_A", "dataset_B") -} -\section{Methods}{ -\subsection{Public methods}{ -\itemize{ -\item \href{#method-JoinKeys-new}{\code{JoinKeys$new()}} -\item \href{#method-JoinKeys-split}{\code{JoinKeys$split()}} -\item \href{#method-JoinKeys-merge}{\code{JoinKeys$merge()}} -\item \href{#method-JoinKeys-get}{\code{JoinKeys$get()}} -\item \href{#method-JoinKeys-mutate}{\code{JoinKeys$mutate()}} -\item \href{#method-JoinKeys-set}{\code{JoinKeys$set()}} -\item \href{#method-JoinKeys-print}{\code{JoinKeys$print()}} -\item \href{#method-JoinKeys-set_parents}{\code{JoinKeys$set_parents()}} -\item \href{#method-JoinKeys-get_parent}{\code{JoinKeys$get_parent()}} -\item \href{#method-JoinKeys-get_parents}{\code{JoinKeys$get_parents()}} -\item \href{#method-JoinKeys-update_keys_given_parents}{\code{JoinKeys$update_keys_given_parents()}} -\item \href{#method-JoinKeys-clone}{\code{JoinKeys$clone()}} -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-new}{}}} -\subsection{Method \code{new()}}{ -Create a new object of \code{JoinKeys} -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$new()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -empty (\code{JoinKeys}) -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-split}{}}} -\subsection{Method \code{split()}}{ -Split the current \code{JoinKeys} object into a named list of join keys objects with an element for each dataset -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$split()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{list}) a list of \code{JoinKeys} object -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-merge}{}}} -\subsection{Method \code{merge()}}{ -Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$merge(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{\code{list} of \code{JoinKeys} objects or single \code{JoinKeys} object} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{self}) invisibly for chaining -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-get}{}}} -\subsection{Method \code{get()}}{ -Get join keys between two datasets. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$get(dataset_1, dataset_2)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataset_1}}{(\code{character}) one dataset name} - -\item{\code{dataset_2}}{(\code{character}) other dataset name} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -if one or both of \code{dataset_1} and \code{dataset_2} are missing then -underlying keys structure is returned for further processing -} - -\subsection{Returns}{ -(\code{character}) named character vector x with names(x) the -columns of \code{dataset_1} and the values of \code{(x)} the corresponding join -keys in \code{dataset_2} or \code{character(0)} if no relationship -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-mutate}{}}} -\subsection{Method \code{mutate()}}{ -Change join_keys for a given pair of dataset names (or -add join_keys for given pair if it does not exist) -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$mutate(dataset_1, dataset_2, val)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataset_1}}{(\code{character}) one dataset name} - -\item{\code{dataset_2}}{(\code{character}) other dataset name} - -\item{\code{val}}{(named \code{character}) column names used to join} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{self}) invisibly for chaining -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-set}{}}} -\subsection{Method \code{set()}}{ -Set up join keys basing on list of \code{JoinKeySet} objects. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$set(x)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{x}}{\code{list} of \code{JoinKeySet} objects (which are created using the \code{join_key} function) -or single \code{JoinKeySet} objects} -} -\if{html}{\out{
}} -} -\subsection{Details}{ -Note that join keys are symmetric although the relationship only needs -to be specified once -} - -\subsection{Returns}{ -(\code{self}) invisibly for chaining -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-print}{}}} -\subsection{Method \code{print()}}{ -Prints this \code{JoinKeys}. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$print(...)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{...}}{additional arguments to the printing method} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -invisibly self -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-set_parents}{}}} -\subsection{Method \code{set_parents()}}{ -Sets the parents of the datasets. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$set_parents(named_list)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{named_list}}{Named (\code{list}) of the parents datasets.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{self}) invisibly for chaining -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-get_parent}{}}} -\subsection{Method \code{get_parent()}}{ -Gets the parent of the desired dataset. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$get_parent(dataname)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{dataname}}{(\code{character}) name of the dataset.} -} -\if{html}{\out{
}} -} -\subsection{Returns}{ -(\code{character}) the parent of the desired dataset -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-get_parents}{}}} -\subsection{Method \code{get_parents()}}{ -Gets the parents of the datasets. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$get_parents()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{list}) A named list of the parents of all datasets -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-update_keys_given_parents}{}}} -\subsection{Method \code{update_keys_given_parents()}}{ -Updates the keys of the datasets based on the parents. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$update_keys_given_parents()}\if{html}{\out{
}} -} - -\subsection{Returns}{ -(\code{self}) invisibly for chaining -} -} -\if{html}{\out{
}} -\if{html}{\out{}} -\if{latex}{\out{\hypertarget{method-JoinKeys-clone}{}}} -\subsection{Method \code{clone()}}{ -The objects of this class are cloneable with this method. -\subsection{Usage}{ -\if{html}{\out{
}}\preformatted{JoinKeys$clone(deep = FALSE)}\if{html}{\out{
}} -} - -\subsection{Arguments}{ -\if{html}{\out{
}} -\describe{ -\item{\code{deep}}{Whether to make a deep clone.} -} -\if{html}{\out{
}} -} -} -} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index cf19c57e5..fd962fddc 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -4,11 +4,10 @@ \alias{join_keys} \alias{cdisc_join_keys} \alias{join_keys<-} -\alias{join_keys<-.Placeholder} \alias{join_keys<-.JoinKeys} \alias{join_keys<-.teal_data} -\alias{[.Placeholder} -\alias{[<-.Placeholder} +\alias{[.JoinKeys} +\alias{[<-.JoinKeys} \title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} \usage{ join_keys(...) @@ -17,15 +16,13 @@ cdisc_join_keys(...) join_keys(join_keys_obj) <- value -\method{join_keys}{Placeholder}(join_keys_obj) <- value - \method{join_keys}{JoinKeys}(join_keys_obj) <- value \method{join_keys}{teal_data}(join_keys_obj) <- value -\method{[}{Placeholder}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) +\method{[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) -\method{[}{Placeholder}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value +\method{[}{JoinKeys}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value } \arguments{ \item{...}{optional, a \code{JoinKeySet} objects created using the \code{join_key} function.} @@ -66,14 +63,17 @@ When \code{dataset_2} is omitted, it will create a primary key with \code{datase \examples{ # setting join keys -join_keys( +jk <- join_keys( join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) ) +jk + # or jk <- join_keys() jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +jk # Default CDISC join keys @@ -81,18 +81,11 @@ cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE # Using the setter (assignment) -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor or constructor +jk <- join_keys() join_keys(jk) join_keys(jk) <- join_key("ds1", "ds2", "some_col") join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" - -# Using old JoinKeys - -jk <- JoinKeys$new() -join_keys(jk)["ds1", "ds2"] <- "key1" -join_keys(jk)["ds2", "ds2"] <- "key2" -join_keys(jk)["ds3", "ds2"] <- "key3" td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td)["ds2", "ds2"] <- "key2" @@ -100,7 +93,7 @@ join_keys(td)["ds3", "ds2"] <- "key3" # Getter for JoinKeys -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") jk["ds1", "ds2"] jk["ds1"] @@ -108,7 +101,7 @@ jk[["ds1"]] # Setter via index -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") # overwrites previously defined key diff --git a/man/join_pair.Rd b/man/join_pair.Rd index 00167c1a3..fbcfc3b3e 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -15,7 +15,7 @@ join_pair(join_keys_obj, join_key_obj) Helper function to add a new pair to a \code{JoinKeys} object } \examples{ -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() jk <- join_pair(jk, join_key("ds1", "ds2", "value")) jk <- join_pair(jk, join_key("ds3", "ds2", "value")) jk diff --git a/man/length.JoinKeys.Rd b/man/length.JoinKeys.Rd deleted file mode 100644 index 43bf3deb1..000000000 --- a/man/length.JoinKeys.Rd +++ /dev/null @@ -1,18 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R -\name{length.JoinKeys} -\alias{length.JoinKeys} -\title{Length of an Object} -\usage{ -\method{length}{JoinKeys}(x) -} -\arguments{ -\item{x}{(\code{JoinKeys}) object} -} -\value{ -number of relationship pairs and primary keys defined in \code{JoinKeys} -object -} -\description{ -Length of an Object -} diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index 2faf54a20..5cadc5ec5 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -3,14 +3,14 @@ \name{merge_join_keys} \alias{merge_join_keys} \alias{merge_join_keys.default} -\alias{merge_join_keys.Placeholder} +\alias{merge_join_keys.JoinKeys} \title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} \usage{ merge_join_keys(join_keys_obj, new_join_keys) \method{merge_join_keys}{default}(join_keys_obj, new_join_keys) -\method{merge_join_keys}{Placeholder}(join_keys_obj, new_join_keys) +\method{merge_join_keys}{JoinKeys}(join_keys_obj, new_join_keys) } \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) object to merge the new_join_keys.} @@ -24,10 +24,10 @@ a new \code{JoinKeys} object with the resulting merge. Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object } \examples{ -jk1 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk1 <- join_keys() jk1["ds1", "ds2"] <- "some_col" -jk2 <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk2 <- join_keys() jk2["ds1", "ds3"] <- "new_col" merge_join_keys(jk1, jk2) diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 7b2539102..4b23d6d0b 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -2,18 +2,15 @@ % Please edit documentation in R/JoinKeys.R, R/join_keys.R \name{mutate_join_keys} \alias{mutate_join_keys} -\alias{mutate_join_keys.JoinKeys} \alias{mutate_join_keys.TealData} -\alias{mutate_join_keys.Placeholder} +\alias{mutate_join_keys.JoinKeys} \title{Mutate \code{JoinKeys} with a new values} \usage{ mutate_join_keys(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, value) - \method{mutate_join_keys}{TealData}(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{Placeholder}(x, dataset_1, dataset_2, value) +\method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, value) } \arguments{ \item{x}{(\code{JoinKeys}) object to be modified} @@ -32,16 +29,6 @@ modified \code{JoinKeys} object Mutate \code{JoinKeys} with a new values } \examples{ -# JoinKeys ---- - -x <- join_keys( - join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), - join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) -) -x$get("dataset_A", "dataset_B") - -mutate_join_keys(x, "dataset_A", "dataset_B", c("col_1" = "col_10")) -x$get("dataset_A", "dataset_B") # TealData ---- ADSL <- teal.data::example_cdisc_data("ADSL") @@ -55,7 +42,7 @@ join_keys(x)$get("ADSL", "ADRS") mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) join_keys(x)$get("ADSL", "ADRS") -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) mutate_join_keys(jk, "ds2", "ds3", "another") } diff --git a/man/new_teal_data.Rd b/man/new_teal_data.Rd index 1191cebc5..675802af5 100644 --- a/man/new_teal_data.Rd +++ b/man/new_teal_data.Rd @@ -8,7 +8,7 @@ new_teal_data( data, code = character(0), join_keys = join_keys(), - datanames = union(names(data), names(join_keys$get())) + datanames = union(names(data), names(join_keys)) ) } \arguments{ diff --git a/man/parents.Rd b/man/parents.Rd index d9574469f..a6fe26609 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -3,23 +3,17 @@ \name{parents} \alias{parents} \alias{parents.JoinKeys} -\alias{parents.Placeholder} \alias{parents<-} \alias{parents<-.JoinKeys} -\alias{parents<-.Placeholder} \title{Getter and setter functions for parents attribute of \code{JoinKeys}} \usage{ parents(join_keys_obj) \method{parents}{JoinKeys}(join_keys_obj) -\method{parents}{Placeholder}(join_keys_obj) - parents(join_keys_obj) <- value \method{parents}{JoinKeys}(join_keys_obj) <- value - -\method{parents}{Placeholder}(join_keys_obj) <- value } \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) object to retrieve or manipulate.} @@ -33,11 +27,11 @@ a list of \code{character} representing the parents. Getter and setter functions for parents attribute of \code{JoinKeys} } \examples{ -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() parents(jk) -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() parents(jk) <- list(ADSL = "ADTTE") -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") parents(jk)["ADTTE"] <- "ADSL" parents(jk)["ADTTE"] <- "ADSL2" diff --git a/man/print.Placeholder.Rd b/man/print.JoinKeys.Rd similarity index 79% rename from man/print.Placeholder.Rd rename to man/print.JoinKeys.Rd index b268ca61d..2be9c997e 100644 --- a/man/print.Placeholder.Rd +++ b/man/print.JoinKeys.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_keys.R -\name{print.Placeholder} -\alias{print.Placeholder} +\name{print.JoinKeys} +\alias{print.JoinKeys} \title{Prints \code{JoinKeys}.} \usage{ -\method{print}{Placeholder}(x, ...) +\method{print}{JoinKeys}(x, ...) } \arguments{ \item{x}{an object used to select a method.} diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd index 3a1151836..bf87d7baa 100644 --- a/man/split_join_keys.Rd +++ b/man/split_join_keys.Rd @@ -3,14 +3,14 @@ \name{split_join_keys} \alias{split_join_keys} \alias{split_join_keys.default} -\alias{split_join_keys.Placeholder} +\alias{split_join_keys.JoinKeys} \title{Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset} \usage{ split_join_keys(join_keys_obj) \method{split_join_keys}{default}(join_keys_obj) -\method{split_join_keys}{Placeholder}(join_keys_obj) +\method{split_join_keys}{JoinKeys}(join_keys_obj) } \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) base object to get the keys from.} @@ -22,7 +22,7 @@ split_join_keys(join_keys_obj) Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset } \examples{ -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() jk["ds1", "ds2"] <- "some_col" jk["ds1", "ds3"] <- "new_col" split_join_keys(jk) diff --git a/man/sub-.JoinKeys.Rd b/man/sub-.JoinKeys.Rd deleted file mode 100644 index db5867a03..000000000 --- a/man/sub-.JoinKeys.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R -\name{[.JoinKeys} -\alias{[.JoinKeys} -\alias{[<-.JoinKeys} -\title{Getter for JoinKeys that returns the relationship between pairs of datasets} -\usage{ -\method{[}{JoinKeys}(x, dataset_1 = NULL, dataset_2 = NULL) - -\method{[}{JoinKeys}(x, dataset_1, dataset_2 = dataset_1) <- value -} -\arguments{ -\item{x}{JoinKeys object to extract the join keys} - -\item{dataset_1}{(\code{character}) name of first dataset.} - -\item{dataset_2}{(\code{character}) name of second dataset.} - -\item{value}{value to assign} -} -\description{ -Getter for JoinKeys that returns the relationship between pairs of datasets -} diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 1a772c0f9..c56597583 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -16,7 +16,7 @@ update_keys_given_parents(join_keys_obj) Updates the keys of the datasets based on the parents. } \examples{ -jk <- teal.data:::new_join_keys() # TODO: JK remove in favor of join_keys() +jk <- join_keys() join_keys(jk) <- list( join_key("df1", "df1", c("id", "id2")), join_key("df1", "df2", c("id" = "id")), diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R index f425fd27a..7ad001300 100644 --- a/tests/testthat/test-JoinKeys.R +++ b/tests/testthat/test-JoinKeys.R @@ -130,7 +130,7 @@ test_that("join_keys can get all keys from JoinKeys", { join_key("d2", "d3", c("C" = "U", "L" = "M")) ) - all_keys <- my_keys$get() + all_keys <- my_keys expect_equal(names(all_keys), c("d1", "d2", "d3")) expect_equal(my_keys[dataset_1 = "d1"], all_keys[["d1"]]) }) @@ -159,13 +159,13 @@ test_that("mutate_join_keys.JoinKeys can mutate existing keys", { test_that("mutate_join_keys.JoinKeys mutating non-existing keys adds them", { my_keys <- join_keys(join_key("d1", "d2", "A")) new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) - expect_equal(my_keys["d3", "d2"], c("Y" = "X")) + expect_equal(new_keys["d3", "d2"], c("Y" = "X")) }) test_that("mutate_join_keys.JoinKeys can remove keys by setting them to character(0)", { my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) - expect_equal(my_keys["d1", "d2"], character(0)) + expect_equal(new_keys["d1", "d2"], character(0)) }) # ----------------------------------------------------------------------------- @@ -190,11 +190,11 @@ testthat::test_that("split_join_keys method returns a named list of JoinKeys obj testthat::expect_equal(names(res), c("A", "B", "C", "Z", "Y")) checkmate::expect_list(res, types = "JoinKeys") - testthat::expect_equal(names(res$A$get()), c("A", "B", "C")) - testthat::expect_equal(names(res$B$get()), c("B", "A")) - testthat::expect_equal(names(res$C$get()), c("C", "A")) - testthat::expect_equal(names(res$Z$get()), c("Z", "Y")) - testthat::expect_equal(names(res$Y$get()), c("Y", "Z")) + testthat::expect_equal(names(res$A), c("A", "B", "C")) + testthat::expect_equal(names(res$B), c("B", "A")) + testthat::expect_equal(names(res$C), c("C", "A")) + testthat::expect_equal(names(res$Z), c("Z", "Y")) + testthat::expect_equal(names(res$Y), c("Y", "Z")) }) testthat::test_that( @@ -212,16 +212,16 @@ testthat::test_that( res2 <- split_join_keys(x2) testthat::expect_false(identical(res, res2)) - testthat::expect_identical(res2$A$get()$A$B, c("a" = "b", "aa" = "bb")) + testthat::expect_identical(res2$A$A$B, c("a" = "b", "aa" = "bb")) # adding new datasets x3 <- mutate_join_keys(x2, "D", "G", c("d" = "g")) res3 <- split_join_keys(x3) testthat::expect_false(identical(res, res3)) testthat::expect_false(identical(res2, res3)) - testthat::expect_identical(res3$D$get()$D$G, c("d" = "g")) - testthat::expect_identical(res3$D$get()$G$D, c("g" = "d")) - testthat::expect_identical(names(res3$D$get()), c("D", "G")) + testthat::expect_identical(res3$D$D$G, c("d" = "g")) + testthat::expect_identical(res3$D$G$D, c("g" = "d")) + testthat::expect_identical(names(res3$D), c("D", "G")) } ) @@ -474,11 +474,11 @@ testthat::test_that("print.JoinKeys for a non-empty set", { }) testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they are empty", { - jk <- JoinKeys$new() - jk$set(list(join_key("df1", "df2", c("id" = "fk")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "fk"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) testthat::expect_identical( - ss <- jk$get_parents(), + ss <- parents(jk), list(df1 = character(0), df2 = "df1") ) }) @@ -525,11 +525,11 @@ test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { internal_keys <- default_cdisc_keys[["ADTTE"]] jk <- cdisc_join_keys("ADTTE") - primary_keys <- unname(jk$get("ADTTE", "ADTTE")) + primary_keys <- unname(jk["ADTTE", "ADTTE"]) expect_equal(primary_keys, internal_keys$primary) - foreign_keys <- unname(jk$get("ADTTE", internal_keys$parent)) + foreign_keys <- unname(jk["ADTTE", internal_keys$parent]) expect_equal(foreign_keys, internal_keys$foreign) }) @@ -541,10 +541,10 @@ test_that("cdisc_join_keys will retrieve known primary and foreign keys", { function(.x) { internal_keys <- default_cdisc_keys[[.x]] jk <- cdisc_join_keys(.x) - primary_keys <- unname(jk$get(.x, .x)) + primary_keys <- unname(jk[.x, .x]) expect_equal(primary_keys, internal_keys$primary) if (!is.null(internal_keys$foreign)) { - foreign_keys <- unname(jk$get(.x, internal_keys$parent)) + foreign_keys <- unname(jk[.x, internal_keys$parent]) expect_equal(foreign_keys, internal_keys$foreign) } character(0) diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index da04f1e62..be37571fd 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -56,8 +56,8 @@ testthat::test_that("cdisc_data sets the join_keys internally", { join_key("ADSL", "ADAE", c("STUDYID", "USUBJID")), join_key("ADTTE", "ADAE", c("STUDYID", "USUBJID")) ) - jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) - testthat::expect_equal(join_keys(data), join_keys(jks)) # TODO: JK remove join_keys from jk_expected + parents(jks) <- list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL") + testthat::expect_equal(join_keys(data), jks) }) testthat::test_that( @@ -74,10 +74,10 @@ testthat::test_that( join_key("ADSL", "ADAE", c("STUDYID")), join_key("ADTTE", "ADAE", c("STUDYID")) ) - jks$set_parents(list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL")) + parents(jks) <- list(ADSL = character(0), ADTTE = "ADSL", ADAE = "ADSL") testthat::expect_equal( join_keys(data), - join_keys(jks) # TODO: JK remove join_keys from jk_expected + jks ) } ) @@ -95,8 +95,9 @@ testthat::test_that("cdisc_data sets primary keys as join_keys when no join_keys join_key("df1", "df1", "id"), join_key("df2", "df2", "df2_id") ) - jks$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), join_keys(jks)) # TODO: JK remove join_keys from jk_expected + parents(jks) <- list(df1 = character(0), df2 = character(0)) + testthat::expect_equal(join_keys(data), jks) + testthat::expect_equal(parents(join_keys(data)), parents(jks)) }) testthat::test_that("cdisc_data throws error when a parent/child graph is not correct", { diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index ec94cf365..ac4ceba55 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -1,14 +1,14 @@ test_that("join_keys.teal_data will successfully obtain object from teal_data", { obj <- helper_generator_teal_data() - expect_identical(obj@join_keys$get(), join_keys(obj)) + expect_identical(obj@join_keys, join_keys(obj)) helper_test_getter_join_keys(obj, "ds1") }) test_that("join_keys.JoinKeys will return itself", { obj <- helper_generator_JoinKeys() - expect_identical(obj$get(), join_keys(obj)) + expect_identical(obj, join_keys(obj)) helper_test_getter_join_keys(obj, "ds1") }) @@ -29,65 +29,65 @@ test_that("join_keys<-.JoinKeys", { test_that("mutate_join_keys with empty name is changed to the key value", { # set empty key name - jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "C")) + jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "C")) expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" - jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "C" = "")) + jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "C" = "")) expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) # set key on empty variable name equal to "" - jk <- mutate_join_keys(new_join_keys(), "d1", "d2", c("A" = "B", "")) + jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "")) expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) test_that("[<-.JoinKeys with empty name is changed to the key value", { - jk <- new_join_keys() - # set empty key name + jk <- join_keys() jk["d1", "d2"] <- c("A" = "B", "C") expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" + jk <- join_keys() jk["d1", "d2"] <- c("A" = "B", "C" = "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) # set key on empty variable name equal to "" + jk <- join_keys() jk["d1", "d2"] <- c("A" = "B", "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) -test_that("join_keys()[]<-.Placeholder with empty name is changed to the key value", { - jk <- new_join_keys() +test_that("join_keys()[]<-.JoinKeys with empty name is changed to the key value", { # set empty key name + jk <- join_keys() join_keys(jk)["d1", "d2"] <- c("A" = "B", "C") expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) - jk <- new_join_keys() # set key on non-empty variable name equal to "" + jk <- join_keys() join_keys(jk)["d1", "d2"] <- c("A" = "B", "C" = "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) - jk <- new_join_keys() # set key on empty variable name equal to "" + jk <- join_keys() join_keys(jk)["d1", "d2"] <- c("A" = "B", "") expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) test_that("join_keys()[]<-.teal_data with empty name is changed to the key value", { - td <- teal_data() - # set empty key name + td <- teal_data() join_keys(td)["d1", "d2"] <- c("A" = "B", "C") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) - td <- teal_data() # set key on non-empty variable name equal to "" + td <- teal_data() join_keys(td)["d1", "d2"] <- c("A" = "B", "C" = "") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", "C"))) - td <- teal_data() # set key on empty variable name equal to "" + td <- teal_data() join_keys(td)["d1", "d2"] <- c("A" = "B", "") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 9aace042d..083a146b3 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -72,9 +72,9 @@ test_that("check_parent_child will skip empty JoinKeys", { testthat::test_that("parents<- throws error when overwriting the parent value with a different value", { jk <- join_keys() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_error(jk$set_parents(list(df1 = character(0), df2 = "df5"))) + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_error(parents(jk) <- list(df1 = character(0), df2 = "df5")) }) testthat::test_that("parents<- works when overwriting the parent value with the same value", { @@ -94,10 +94,10 @@ testthat::test_that("parent returns the parent name of the dataset", { testthat::test_that("parent returns NULL when dataset is not found or not passed", { jk <- join_keys() - jk$set(list(join_key("df1", "df2", c("id" = "id")))) - testthat::expect_silent(jk$set_parents(list(df1 = character(0), df2 = "df1"))) - testthat::expect_null(jk$get_parent()) - testthat::expect_null(jk$get_parent("df3")) + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_null(parent(jk)) + testthat::expect_null(parent(jk, "df3")) }) testthat::test_that("get_parents returns a list of all parents", { @@ -127,7 +127,7 @@ testthat::test_that("parents throws error when dataname input is provided", { testthat::test_that("update_keys_given_parents does not update the join_keys when no presents are present", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - jk$update_keys_given_parents() + jk <- update_keys_given_parents(jk) testthat::expect_equal(jk, join_keys(join_key("df1", "df2", c("id" = "id")))) }) diff --git a/tests/testthat/test-teal_data.R b/tests/testthat/test-teal_data.R index 8c448f4fb..baf821340 100644 --- a/tests/testthat/test-teal_data.R +++ b/tests/testthat/test-teal_data.R @@ -144,9 +144,9 @@ testthat::test_that("teal_data sets passed join_keys to datasets correctly", { join_key("df1", "df1", "id"), join_key("df2", "df2", "df2_id") ) - jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) + parents(jk_expected) <- list(df1 = character(0), df2 = character(0)) - testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when key names differ", { @@ -163,9 +163,9 @@ testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when k join_key("df2", "df1", c(fk = "id")), join_key("df2", "df2", "df2_id") ) - jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) + parents(jk_expected) <- list(df1 = character(0), df2 = character(0)) - testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when key names differ (multiple keys)", { @@ -181,8 +181,8 @@ testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when k join_key("df2", "df2", "df2_id"), join_key("df1", "df2", c(id = "fk", id2 = "fk2")) ) - jk_expected$set_parents(list(df1 = character(0), df2 = character(0))) - testthat::expect_equal(join_keys(data), join_keys(jk_expected)) # TODO: JK remove join_keys from jk_expected + parents(jk_expected) <- list(df1 = character(0), df2 = character(0)) + testthat::expect_equal(join_keys(data), jk_expected) }) testthat::test_that("teal_data returns TealData object with cdisc_dataset input", { @@ -263,7 +263,7 @@ testthat::test_that("update_join_keys_to_primary updates the join_keys", { jks <- join_keys(join_key("df1", "df2", "id")) data_objects <- list(df1, df2) - update_join_keys_to_primary(data_objects, jks) + jks <- update_join_keys_to_primary(data_objects, jks) testthat::expect_equal( jks, join_keys( @@ -284,7 +284,7 @@ testthat::test_that("update_join_keys_to_primary updates the join_keys when prim jks <- join_keys(join_key("df1", "df2", "id")) data_objects <- list(df1, df2) - update_join_keys_to_primary(data_objects, jks) + jks <- update_join_keys_to_primary(data_objects, jks) testthat::expect_equal( jks, join_keys( @@ -305,7 +305,7 @@ testthat::test_that("update_join_keys_to_primary updates join_keys with characte jks <- join_keys(join_key("df1", "df2", "id")) data_objects <- list(df1, df2) - update_join_keys_to_primary(data_objects, jks) + jks <- update_join_keys_to_primary(data_objects, jks) testthat::expect_equal( jks, join_keys( From 2980c32ae0a011f62e49015beaa800d20811d077 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 15:12:13 +0100 Subject: [PATCH 011/152] adds some test coverage --- R/get_join_keys.R | 2 +- R/join_keys.R | 64 ++++++++++++++--------------- R/parents.R | 30 -------------- man/check_parent_child.Rd | 12 ------ man/join_keys.Rd | 1 + tests/testthat/test-get_join_keys.R | 7 ++++ tests/testthat/test-join_keys.R | 20 ++++++++- tests/testthat/test-parents.R | 50 ++++++++++++++++++---- 8 files changed, 101 insertions(+), 85 deletions(-) delete mode 100644 man/check_parent_child.Rd diff --git a/R/get_join_keys.R b/R/get_join_keys.R index a4e274e4a..6390f59d0 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -17,7 +17,7 @@ get_join_keys <- function(data) { `get_join_keys<-` <- function(x, dataset_1, dataset_2 = NULL, value) { lifecycle::deprecate_stop( when = " 0.3.1", - what = "get_join_keys(x) <- ...", + what = "`get_join_keys<-`()", details = "Use `join_keys(x) <- ...`" ) } diff --git a/R/join_keys.R b/R/join_keys.R index 5966a173b..f74cb1e12 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -40,7 +40,7 @@ if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "JoinKeySet", min.len = 1)) { jk <- new_join_keys() join_keys(jk) <- value - message("Keys already set, merging new list of JoinKeySet with existing keys.") + message("note: Keys already set, merging new list of JoinKeySet with existing keys.") return(merge_join_keys(join_keys_obj, jk)) } @@ -330,6 +330,37 @@ new_join_keys <- function() { result } +#' Get value of a single relationship pair +#' +#' @param join_keys_obj (`JoinKeys`) object that holds the relationship keys. +#' @param dataset_1 (`character(1)`) one of the datasets to retrieve keys ( +#' order of the datasets is irrelevant). +#' @param dataset_2 (`character(1)`) the other dataset to retrieve keys (the +#' order of the datasets is irrelevant). +#' +#' @return Character vector with keys or (if one of the datasets is omitted) a +#' list of relationship pairs. If both datasets are omitted it returens the +#' `JoinKeys` object +#' +#' @keywords internal +get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { + jk <- join_keys(join_keys_obj) + + assert_join_keys(jk) + + if (missing(dataset_1) && missing(dataset_2)) { + return(jk) + } + if (missing(dataset_2)) { + return(jk[dataset_1]) + } + if (missing(dataset_1)) { + return(jk[dataset_2]) + } + + jk[dataset_1, dataset_2] +} + #' Internal assignment of value to a JoinKeys object #' #' @inheritParams join_keys @@ -374,37 +405,6 @@ add_key <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { join_keys_obj } -#' Get value of a single relationship pair -#' -#' @param join_keys_obj (`JoinKeys`) object that holds the relationship keys. -#' @param dataset_1 (`character(1)`) one of the datasets to retrieve keys ( -#' order of the datasets is irrelevant). -#' @param dataset_2 (`character(1)`) the other dataset to retrieve keys (the -#' order of the datasets is irrelevant). -#' -#' @return Character vector with keys or (if one of the datasets is omitted) a -#' list of relationship pairs. If both datasets are omitted it returens the -#' `JoinKeys` object -#' -#' @keywords internal -get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { - jk <- join_keys(join_keys_obj) - - assert_join_keys(jk) - - if (missing(dataset_1) && missing(dataset_2)) { - return(jk) - } - if (missing(dataset_2)) { - return(jk[dataset_1]) - } - if (missing(dataset_1)) { - return(jk[dataset_2]) - } - - jk[dataset_1, dataset_2] -} - #' Helper function to add a new pair to a `JoinKeys` object #' #' @param join_keys_obj (`JoinKeys`) Object with existing pairs. diff --git a/R/parents.R b/R/parents.R index c2ecd3b64..6caf3b36b 100644 --- a/R/parents.R +++ b/R/parents.R @@ -145,33 +145,3 @@ update_keys_given_parents <- function(join_keys_obj) { jk } - -# ----------------------------------------------------------------------------- -# -# Helpers (non-exported) - -#' Check if parent/child are valid -#' -#' @keywords internal -check_parent_child <- function(join_keys_obj) { - jk_parents <- parents(join_keys_obj) - if (length(jk_parents) > 0) { - for (idx1 in seq_along(jk_parents)) { - name_from <- names(jk_parents)[[idx1]] - for (idx2 in seq_along(jk_parents[[idx1]])) { - name_to <- jk_parents[[idx1]][[idx2]] - keys_from <- join_keys_obj[name_from, name_to] - keys_to <- join_keys_obj[name_to, name_from] - if (length(keys_from) == 0 && length(keys_to) == 0) { - stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) - } - if (length(keys_from) == 0) { - stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to)) - } - if (length(keys_to) == 0) { - stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from)) - } - } - } - } -} diff --git a/man/check_parent_child.Rd b/man/check_parent_child.Rd deleted file mode 100644 index 0e762a2eb..000000000 --- a/man/check_parent_child.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/parents.R -\name{check_parent_child} -\alias{check_parent_child} -\title{Check if parent/child are valid} -\usage{ -check_parent_child(join_keys_obj) -} -\description{ -Check if parent/child are valid -} -\keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index fd962fddc..ca458154e 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -86,6 +86,7 @@ join_keys(jk) join_keys(jk) <- join_key("ds1", "ds2", "some_col") join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" + td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td)["ds2", "ds2"] <- "key2" diff --git a/tests/testthat/test-get_join_keys.R b/tests/testthat/test-get_join_keys.R index e69de29bb..a9bb4776a 100644 --- a/tests/testthat/test-get_join_keys.R +++ b/tests/testthat/test-get_join_keys.R @@ -0,0 +1,7 @@ +testthat::test_that("get_join_keys is deprecated", { + lifecycle::expect_defunct(get_join_keys(join_keys())) +}) + +testthat::test_that("get_join_keys<- is deprecated", { + lifecycle::expect_defunct(`get_join_keys<-`(NULL, NULL, NULL, NULL)) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index ac4ceba55..56a9965c1 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -12,16 +12,32 @@ test_that("join_keys.JoinKeys will return itself", { helper_test_getter_join_keys(obj, "ds1") }) -test_that("join_keys<-.teal_data", { +test_that("join_keys<-.teal_data shared test to getter and setter", { obj <- helper_generator_teal_data() helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) -test_that("join_keys<-.JoinKeys", { +test_that("join_keys<-.JoinKeys shared test to getter and setter", { obj <- helper_generator_JoinKeys() helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) +test_that("join_keys<-.JoinKeys to set via a JoinKeySet object", { + obj <- join_keys() + join_keys(obj) <- join_key("ds1", "ds2", "id") + expect_equal(obj$ds1, list("ds2" = c("id" = "id"))) + expect_equal(obj$ds2, list("ds1" = c("id" = "id"))) +}) + +test_that("join_keys<-.JoinKeys to set via multiple lists that progressively merge object", { + obj <- join_keys() + join_keys(obj) <- list(join_key("ds1", "ds2", "id")) + join_keys(obj) <- list(join_key("ds3", "ds4", "id_id")) + join_keys(obj) <- join_key("ds5", "ds6", "id_id_id") + + expect_length(obj, 6) +}) + # ----------------------------------------------------------------------------- # # mutate_join_keys (empty value name) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 083a146b3..080847371 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -26,6 +26,14 @@ test_that("parents<- will add to parents attribute using `[[` notation", { expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) }) +test_that("parents<- does nothing with empty value", { + jk <- join_keys() + jk2 <- `parents<-`(jk) + + expect_length(parents(jk2), 0) + expect_equal(jk, jk2) +}) + test_that("parents<- will add to parents attribute using list", { jk <- join_keys() parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") @@ -44,30 +52,30 @@ test_that("parents<- will add to parents attribute using list, `[` and `[[` nota expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4", ds5 = "ds6", ds7 = "ds8")) }) -test_that("check_parent_child will detect empty keys", { +test_that("assert_parent_child will detect empty keys", { jk <- join_keys() jk["ds1", "ds2"] <- character(0) parents(jk) <- list(ds1 = "ds2") - expect_error(check_parent_child(jk)) + expect_error(assert_parent_child(jk)) }) -test_that("check_parent_child will detect invalid key pairs", { +test_that("assert_parent_child will detect invalid key pairs", { jk <- join_keys() jk["ds1", "ds2"] <- "key1" jk["ds2", "ds1"] <- character(0) parents(jk) <- list(ds1 = "ds2") - expect_error(check_parent_child(jk)) + expect_error(assert_parent_child(jk)) jk2 <- join_keys() jk2["ds2", "ds1"] <- "key1" jk2["ds1", "ds2"] <- character(0) parents(jk2) <- list(ds1 = "ds2") - expect_error(check_parent_child(jk2)) + expect_error(assert_parent_child(jk2)) }) -test_that("check_parent_child will skip empty JoinKeys", { +test_that("assert_parent_child will skip empty JoinKeys", { jk <- join_keys() - expect_silent(check_parent_child(jk)) + expect_silent(assert_parent_child(jk)) }) testthat::test_that("parents<- throws error when overwriting the parent value with a different value", { @@ -166,7 +174,7 @@ testthat::test_that("assert_parent_child does nothing if no parents are present" testthat::expect_silent(assert_parent_child(jk)) }) -testthat::test_that("JoinKeys$check_parent_child throws error if no join_keys exist for chuld-parent", { +testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") @@ -175,3 +183,29 @@ testthat::test_that("JoinKeys$check_parent_child throws error if no join_keys ex "No join keys from df2 to its parent \\(df1\\) and vice versa" ) }) + +testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { + jk <- join_keys() + join_keys(jk) <- list( + join_key("df1", "df1", c("id" = "id")) + ) + jk[["df2"]][["df1"]] <- "id" + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") + testthat::expect_error( + assert_parent_child(jk), + "No join keys from df2 parent name \\(df1\\) to df2" + ) +}) + +testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { + jk <- join_keys() + join_keys(jk) <- list( + join_key("df1", "df1", c("id" = "id")) + ) + jk[["df1"]][["df2"]] <- "id" + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") + testthat::expect_error( + assert_parent_child(jk), + "No join keys from df2 to its parent \\(df1\\)" + ) +}) From 4326eb2fae7b41c32486df1579a155db3a9a7bb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 15:52:29 +0100 Subject: [PATCH 012/152] re-structure files --- NAMESPACE | 2 +- R/JoinKeys.R | 134 ------- R/cdisc_join_keys.R | 45 +++ R/join_keys.R | 88 +++++ man/join_keys.Rd | 24 +- man/mutate_join_keys.Rd | 25 +- tests/testthat/test-JoinKeys.R | 598 ------------------------------- tests/testthat/test-join_keys.R | 601 ++++++++++++++++++++++++++++++++ 8 files changed, 759 insertions(+), 758 deletions(-) delete mode 100644 R/JoinKeys.R create mode 100644 R/cdisc_join_keys.R delete mode 100644 tests/testthat/test-JoinKeys.R diff --git a/NAMESPACE b/NAMESPACE index 769ac4ad3..a92c3910a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -51,7 +51,7 @@ S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) S3method(mutate_join_keys,JoinKeys) -S3method(mutate_join_keys,TealData) +S3method(mutate_join_keys,teal_data) S3method(parents,JoinKeys) S3method(print,JoinKeys) S3method(set_args,CallableCode) diff --git a/R/JoinKeys.R b/R/JoinKeys.R deleted file mode 100644 index 1df4a3101..000000000 --- a/R/JoinKeys.R +++ /dev/null @@ -1,134 +0,0 @@ -# Constructors ==== - -#' Create a `JoinKeys` out of a list of `JoinKeySet` objects -#' -#' @description `r lifecycle::badge("stable")` -#' -#' @details Note that join keys are symmetric although the relationship only needs -#' to be specified once. -# -#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. -#' -#' @return `JoinKeys` -#' -#' @export -#' -#' @examples -#' # setting join keys -#' -#' jk <- join_keys( -#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), -#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) -#' ) -#' jk -#' -#' # or -#' jk <- join_keys() -#' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") -#' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") -#' jk -join_keys <- function(...) { - x <- rlang::list2(...) - - # Getter - if (checkmate::test_list(x, len = 1, types = c("JoinKeys"))) { - return(x[[1]]) - } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { - return(x[[1]]@join_keys) - } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { - return(x[[1]]$get_join_keys()) - } - - # Constructor - res <- new_join_keys() - if (length(x) > 0) { - join_keys(res) <- x - } - - res -} - -#' @rdname join_keys -#' -#' @details -#' `cdisc_join_keys` is a wrapper around `join_keys` that sets the default -#' join keys for CDISC datasets. It is used internally by `cdisc_data` to -#' set the default join keys for CDISC datasets. -#' -#' @export -#' -#' @examples -#' -#' # Default CDISC join keys -#' -#' cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") -cdisc_join_keys <- function(...) { - data_objects <- rlang::list2(...) - - jk <- join_keys() - for (ix in seq_along(data_objects)) { - item <- data_objects[[ix]] - name <- names(data_objects)[ix] - - if (checkmate::test_class(item, "JoinKeySet")) { - jk[item$dataset_1, item$dataset_2] <- item$keys - } else if ( - checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) - ) { - } else { - if ((is.null(name) || identical(trimws(name), "")) && is.character(item)) { - name <- item - } - if (name %in% names(default_cdisc_keys)) { - # Set default primary keys - keys_list <- default_cdisc_keys[[name]] - jk[name] <- keys_list$primary - - if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { - jk[name, keys_list$parent] <- keys_list$foreign - } - } - } - } - - jk -} - -# wrappers ==== -#' Mutate `JoinKeys` with a new values -#' -#' @description `r lifecycle::badge("experimental")` -#' Mutate `JoinKeys` with a new values -#' -#' @param x (`JoinKeys`) object to be modified -#' @param dataset_1 (`character`) one dataset name -#' @param dataset_2 (`character`) other dataset name -#' @param value (named `character`) column names used to join -#' -#' @return modified `JoinKeys` object -#' -#' @export -mutate_join_keys <- function(x, dataset_1, dataset_2, value) { - UseMethod("mutate_join_keys") -} - -#' @rdname mutate_join_keys -#' @export -#' @examples -#' # TealData ---- -#' -#' ADSL <- teal.data::example_cdisc_data("ADSL") -#' ADRS <- teal.data::example_cdisc_data("ADRS") -#' -#' x <- cdisc_data( -#' cdisc_dataset("ADSL", ADSL), -#' cdisc_dataset("ADRS", ADRS) -#' ) -#' join_keys(x)$get("ADSL", "ADRS") -#' -#' mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -#' join_keys(x)$get("ADSL", "ADRS") -mutate_join_keys.TealData <- function(x, dataset_1, dataset_2, value) { # nolint - x@join_keys <- mutate_join_keys(x@join_keys, dataset_1, dataset_2, value) - x@join_keys -} diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R new file mode 100644 index 000000000..aaa89a766 --- /dev/null +++ b/R/cdisc_join_keys.R @@ -0,0 +1,45 @@ +#' @rdname join_keys +#' +#' @details +#' `cdisc_join_keys` is a wrapper around `join_keys` that sets the default +#' join keys for CDISC datasets. It is used internally by `cdisc_data` to +#' set the default join keys for CDISC datasets. +#' +#' @export +#' +#' @examples +#' +#' # Default CDISC join keys +#' +#' cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") +cdisc_join_keys <- function(...) { + data_objects <- rlang::list2(...) + + jk <- join_keys() + for (ix in seq_along(data_objects)) { + item <- data_objects[[ix]] + name <- names(data_objects)[ix] + + if (checkmate::test_class(item, "JoinKeySet")) { + jk[item$dataset_1, item$dataset_2] <- item$keys + } else if ( + checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) + ) { + } else { + if ((is.null(name) || identical(trimws(name), "")) && is.character(item)) { + name <- item + } + if (name %in% names(default_cdisc_keys)) { + # Set default primary keys + keys_list <- default_cdisc_keys[[name]] + jk[name] <- keys_list$primary + + if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { + jk[name, keys_list$parent] <- keys_list$foreign + } + } + } + } + + jk +} diff --git a/R/join_keys.R b/R/join_keys.R index f74cb1e12..ab2901773 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,3 +1,53 @@ +# Constructors ==== + +#' Create a `JoinKeys` out of a list of `JoinKeySet` objects +#' +#' @description `r lifecycle::badge("stable")` +#' +#' @details Note that join keys are symmetric although the relationship only needs +#' to be specified once. +# +#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. +#' +#' @return `JoinKeys` +#' +#' @export +#' +#' @examples +#' # setting join keys +#' +#' jk <- join_keys( +#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), +#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) +#' ) +#' jk +#' +#' # or +#' jk <- join_keys() +#' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") +#' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +#' jk +join_keys <- function(...) { + x <- rlang::list2(...) + + # Getter + if (checkmate::test_list(x, len = 1, types = c("JoinKeys"))) { + return(x[[1]]) + } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { + return(x[[1]]@join_keys) + } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { + return(x[[1]]$get_join_keys()) + } + + # Constructor + res <- new_join_keys() + if (length(x) > 0) { + join_keys(res) <- x + } + + res +} + #' @details #' The setter assignment `join_keys() <- ...` will only work for an empty #' `JoinKey` object, otherwise `mutate_join_keys()` must be used. @@ -164,6 +214,24 @@ join_keys_obj } +# wrappers ==== +#' Mutate `JoinKeys` with a new values +#' +#' @description `r lifecycle::badge("experimental")` +#' Mutate `JoinKeys` with a new values +#' +#' @param x (`JoinKeys`) object to be modified +#' @param dataset_1 (`character`) one dataset name +#' @param dataset_2 (`character`) other dataset name +#' @param value (named `character`) column names used to join +#' +#' @return modified `JoinKeys` object +#' +#' @export +mutate_join_keys <- function(x, dataset_1, dataset_2, value) { + UseMethod("mutate_join_keys") +} + #' @rdname mutate_join_keys #' @export #' @examples @@ -189,6 +257,26 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { res } +#' @rdname mutate_join_keys +#' @export +#' @examples +#' # teal_data ---- +#' +#' ADSL <- teal.data::example_cdisc_data("ADSL") +#' ADRS <- teal.data::example_cdisc_data("ADRS") +#' +#' x <- cdisc_data( +#' "ADSL" = ADSL, +#' "ADRS" = ADRS +#' ) +#' join_keys(x)["ADSL", "ADRS"] +#' +#' join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) +mutate_join_keys.teal_data <- function(x, dataset_1, dataset_2, value) { # nolint + join_keys(x) <- mutate_join_keys(join_keys(x), dataset_1, dataset_2, value) + join_keys(x) +} + #' @rdname split_join_keys #' @export split_join_keys <- function(join_keys_obj) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index ca458154e..1dcc72c83 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R, R/join_keys.R -\name{join_keys} -\alias{join_keys} +% Please edit documentation in R/cdisc_join_keys.R, R/join_keys.R +\name{cdisc_join_keys} \alias{cdisc_join_keys} +\alias{join_keys} \alias{join_keys<-} \alias{join_keys<-.JoinKeys} \alias{join_keys<-.teal_data} @@ -10,10 +10,10 @@ \alias{[<-.JoinKeys} \title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} \usage{ -join_keys(...) - cdisc_join_keys(...) +join_keys(...) + join_keys(join_keys_obj) <- value \method{join_keys}{JoinKeys}(join_keys_obj) <- value @@ -42,13 +42,13 @@ join_keys(join_keys_obj) <- value \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} } \details{ -Note that join keys are symmetric although the relationship only needs -to be specified once. - \code{cdisc_join_keys} is a wrapper around \code{join_keys} that sets the default join keys for CDISC datasets. It is used internally by \code{cdisc_data} to set the default join keys for CDISC datasets. +Note that join keys are symmetric although the relationship only needs +to be specified once. + The setter assignment \code{join_keys() <- ...} will only work for an empty \code{JoinKey} object, otherwise \code{mutate_join_keys()} must be used. @@ -61,6 +61,10 @@ Setter via index directly (bypassing the need to use \code{join_key()}). When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. } \examples{ + +# Default CDISC join keys + +cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") # setting join keys jk <- join_keys( @@ -75,10 +79,6 @@ jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") jk -# Default CDISC join keys - -cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") - # Using the setter (assignment) jk <- join_keys() diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 4b23d6d0b..b5defd4b5 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/JoinKeys.R, R/join_keys.R +% Please edit documentation in R/join_keys.R \name{mutate_join_keys} \alias{mutate_join_keys} -\alias{mutate_join_keys.TealData} \alias{mutate_join_keys.JoinKeys} +\alias{mutate_join_keys.teal_data} \title{Mutate \code{JoinKeys} with a new values} \usage{ mutate_join_keys(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{TealData}(x, dataset_1, dataset_2, value) - \method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, value) + +\method{mutate_join_keys}{teal_data}(x, dataset_1, dataset_2, value) } \arguments{ \item{x}{(\code{JoinKeys}) object to be modified} @@ -29,20 +29,19 @@ modified \code{JoinKeys} object Mutate \code{JoinKeys} with a new values } \examples{ -# TealData ---- +jk <- join_keys() +join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +mutate_join_keys(jk, "ds2", "ds3", "another") +# teal_data ---- ADSL <- teal.data::example_cdisc_data("ADSL") ADRS <- teal.data::example_cdisc_data("ADRS") x <- cdisc_data( - cdisc_dataset("ADSL", ADSL), - cdisc_dataset("ADRS", ADRS) + "ADSL" = ADSL, + "ADRS" = ADRS ) -join_keys(x)$get("ADSL", "ADRS") +join_keys(x)["ADSL", "ADRS"] -mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -join_keys(x)$get("ADSL", "ADRS") -jk <- join_keys() -join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) -mutate_join_keys(jk, "ds2", "ds3", "another") +join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) } diff --git a/tests/testthat/test-JoinKeys.R b/tests/testthat/test-JoinKeys.R deleted file mode 100644 index 7ad001300..000000000 --- a/tests/testthat/test-JoinKeys.R +++ /dev/null @@ -1,598 +0,0 @@ -test_that("join_keys cannot set join_keys with incompatible keys", { - # different keys - expect_error( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D", "E" = "F")) - ) - ) - - expect_error( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = character(0)) - ) - ) - - expect_error( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d2", "d1", keys = character(0)) - ) - ) - - expect_error( - join_keys( - join_key("d1", "d2", keys = character(0)), - join_key("d2", "d1", keys = c("A" = "B", "C" = "D")) - ) - ) - - expect_error( - join_keys( - join_key("d1", "d2", keys = c("a" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) - ) - ) -}) - -test_that("join_keys can create join_keys with compatible information", { - # different datasets - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d3", keys = c("A" = "B", "C" = "D")) - ) - ) - - # same keys - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) - ) - ) - - # reordering keys still matches - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) - ) - ) - - # can match with empty - expect_silent( - join_keys( - join_key("d1", "d2", keys = character(0)), - join_key("d1", "d2", keys = character(0)) - ) - ) - - expect_silent( - join_keys( - join_key("d2", "d1", keys = character(0)), - join_key("d2", "d1", keys = character(0)) - ) - ) - - # swapping dataset order still matches - expect_silent( - join_keys( - join_key("d2", "d1", keys = c("B" = "A", "D" = "C")), - join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) - ) - ) -}) - -test_that("join_keys cannot create JoinKeys with invalid arguments", { - # not using join_key - expect_error(join_keys("d1", "d2", "A")) - # key sets with the same pair of datasets but different values - expect_error(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d1", "B"))) - expect_error(join_keys(join_key("d1", "d2", c("A" = "X")), join_key("d2", "d1", c("A" = "X")))) -}) - -test_that("join_keys can create JoinKeys with valid arguments", { - # no keys - expect_silent(join_keys()) - # list of keys - expect_silent(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d3", "B"))) - # single key out of list - expect_silent(join_keys(join_key("d1", "d2", "A"))) - # key sets with the same pair of datasets and the same values - expect_silent(join_keys(join_key("d1", "d2", c("A" = "C")), join_key("d2", "d1", c("C" = "A")))) - expect_silent(join_keys(join_key("d1", "d2", "X"), join_key("d2", "d1", "X"))) -}) - -test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { - my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) - expect_equal(my_keys["d2", "d1"], c("C" = "A")) -}) - - -test_that("join_keys[ can get all keys for a given dataset", { - my_keys <- join_keys( - join_key("d1", "d2", c("A" = "C")), - join_key("d1", "d3", c("A" = "B", "S" = "T")), - join_key("d2", "d3", c("C" = "U", "L" = "M")) - ) - expect_equal(my_keys[dataset_1 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys[dataset_2 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys[dataset_1 = "d3"], list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))) -}) - - -test_that("join_keys can get all keys from JoinKeys", { - my_keys <- join_keys( - join_key("d1", "d2", c("A" = "C")), - join_key("d1", "d3", c("A" = "B", "S" = "T")), - join_key("d2", "d3", c("C" = "U", "L" = "M")) - ) - - all_keys <- my_keys - expect_equal(names(all_keys), c("d1", "d2", "d3")) - expect_equal(my_keys[dataset_1 = "d1"], all_keys[["d1"]]) -}) - -test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { - test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) - expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) -}) - -test_that("join_keys if no keys between pair of datasets then getting them returns character(0)", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_equal(my_keys["d1", "d3"], character(0)) - expect_equal(my_keys["d1", "d4"], character(0)) -}) - -# ----------------------------------------------------------------------------- -# -# mutate_join_keys - -test_that("mutate_join_keys.JoinKeys can mutate existing keys", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - new_keys <- mutate_join_keys(my_keys, "d1", "d2", c("X" = "Y")) - expect_equal(new_keys["d1", "d2"], c("X" = "Y")) -}) - -test_that("mutate_join_keys.JoinKeys mutating non-existing keys adds them", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) - expect_equal(new_keys["d3", "d2"], c("Y" = "X")) -}) - -test_that("mutate_join_keys.JoinKeys can remove keys by setting them to character(0)", { - my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) - new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) - expect_equal(new_keys["d1", "d2"], character(0)) -}) - -# ----------------------------------------------------------------------------- -# -# split_join_keys - -testthat::test_that("split_join_keys method returns empty list when object itself is empty", { - x <- join_keys() - testthat::expect_identical(split_join_keys(x), list()) -}) - -testthat::test_that("split_join_keys method returns a named list of JoinKeys objects with an element for each dataset", { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - res <- split_join_keys(x) - testthat::expect_true(inherits(res, "list")) - testthat::expect_equal(length(res), 5) - testthat::expect_equal(names(res), c("A", "B", "C", "Z", "Y")) - checkmate::expect_list(res, types = "JoinKeys") - - testthat::expect_equal(names(res$A), c("A", "B", "C")) - testthat::expect_equal(names(res$B), c("B", "A")) - testthat::expect_equal(names(res$C), c("C", "A")) - testthat::expect_equal(names(res$Z), c("Z", "Y")) - testthat::expect_equal(names(res$Y), c("Y", "Z")) -}) - -testthat::test_that( - "split_join_keys method returns an updated list after the state of the object is modified by mutate_join_keys", - { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - res <- split_join_keys(x) - - x2 <- mutate_join_keys(x, "A", "B", c("a" = "b", "aa" = "bb")) - res2 <- split_join_keys(x2) - - testthat::expect_false(identical(res, res2)) - testthat::expect_identical(res2$A$A$B, c("a" = "b", "aa" = "bb")) - - # adding new datasets - x3 <- mutate_join_keys(x2, "D", "G", c("d" = "g")) - res3 <- split_join_keys(x3) - testthat::expect_false(identical(res, res3)) - testthat::expect_false(identical(res2, res3)) - testthat::expect_identical(res3$D$D$G, c("d" = "g")) - testthat::expect_identical(res3$D$G$D, c("g" = "d")) - testthat::expect_identical(names(res3$D), c("D", "G")) - } -) - -testthat::test_that("split_join_keys method does not modify self", { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_self <- x - no_use_output <- split_join_keys(x) - testthat::expect_equal(previous_self, x) -}) - -# ----------------------------------------------------------------------------- -# -# merge_join_keys - -testthat::test_that("merge_join_keys can handle edge case: calling object is empty", { - x <- join_keys() - y <- join_keys() - - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - testthat::expect_silent(merge_join_keys(x, y)) - testthat::expect_identical(join_keys(x), join_keys(x)) -}) - -testthat::test_that("merge_join_keys can handle edge case: argument is an empty object", { - x <- join_keys() - y <- join_keys() - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, x)) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that("merge_join_keys can handle edge case: argument is a list of empty objects", { - x <- join_keys() - y <- join_keys() - - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x, x))) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_silent(merge_join_keys(y, list(x, x, x))) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that( - "merge_join_keys throws error when improper argument is passed in without modifying the caller", - { - y <- join_keys() - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- join_keys(y) - testthat::expect_error(y <- merge_join_keys(y)) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_error(y <- merge_join_keys(y, 1)) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_error(y <- merge_join_keys(y, "A")) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_error(y <- merge_join_keys(y, list())) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_error(y <- merge_join_keys(list(1))) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_error(y <- merge_join_keys(y, list("A"))) - testthat::expect_identical(previous_output, join_keys(y)) - } -) - -testthat::test_that("merge_join_keys does nothing when argument is a JoinKeys object with identical data", { - x <- join_keys() - y <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, x)) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object with identical data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x))) - testthat::expect_identical(previous_output, join_keys(y)) - - testthat::expect_silent(merge_join_keys(y, list(x, x))) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that("merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that("merge_join_keys clones data when argument is a list of one JoinKeys object that is a superset", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- join_keys(y) - testthat::expect_silent(y <- merge_join_keys(y, list(x))) - testthat::expect_false(identical(previous_output, join_keys(y))) - testthat::expect_identical(join_keys(x), join_keys(y)) -}) - -testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object that is a subset", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- join_keys(x) - testthat::expect_silent(x <- merge_join_keys(x, list(y))) - testthat::expect_identical(previous_output, join_keys(x)) -}) - -testthat::test_that("merge_join_keys merges mutually exclusive data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")) - ) - join_keys(y) <- list( - join_key("Z", "Y", c("z" = "y")) - ) - - z <- join_keys() - z <- merge_join_keys(z, list(x, y)) - manual_join <- c(join_keys(x), join_keys(y)) - class(manual_join) <- class(new_join_keys()) - testthat::expect_identical(manual_join, join_keys(z)) - - x <- merge_join_keys(x, y) - y <- merge_join_keys(y, x) - - testthat::expect_identical(join_keys(x), join_keys(z)) - testthat::expect_true(all(join_keys(y) %in% join_keys(z)) && all(join_keys(z) %in% join_keys(y))) - testthat::expect_true(all(join_keys(y) %in% join_keys(x)) && all(join_keys(x) %in% join_keys(y))) - - testthat::expect_identical(names(join_keys(z)), c("A", "B", "Z", "Y")) - testthat::expect_equal(length(join_keys(z)), 4) - testthat::expect_identical(join_keys(z)$A$B, c("a" = "b")) - testthat::expect_identical(join_keys(z)$B$A, c("b" = "a")) - testthat::expect_identical(join_keys(z)$Z$Y, c("z" = "y")) - testthat::expect_identical(join_keys(z)$Y$Z, c("y" = "z")) -}) - -# ----------------------------------------------------------------------------- -# -# print.JoinKeys - -testthat::test_that("print.JoinKeys for empty set", { - jk <- join_keys() - testthat::expect_output( - print(jk), - "An empty JoinKeys object." - ) -}) - -testthat::test_that("print.JoinKeys for a non-empty set", { - jk <- join_keys() - join_keys(jk) <- list(join_key("DF1", "DF2", c("id" = "fk"))) - testthat::expect_output( - print(jk), - "A JoinKeys object containing foreign keys between 2 datasets:" - ) -}) - -testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they are empty", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "fk"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_identical( - ss <- parents(jk), - list(df1 = character(0), df2 = "df1") - ) -}) - -# ----------------------------------------------------------------------------- -# -# cdisc_join_keys - -test_that("cdisc_join_keys will generate JoinKeys for named list with non-named elements", { - new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate JoinKeys for character list", { - new_dataset <- cdisc_join_keys("ADSL", "ADTTE") - jk <- join_keys(new_dataset) - - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate JoinKeys for named list", { - new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - internal_keys <- default_cdisc_keys[["ADTTE"]] - jk <- cdisc_join_keys("ADTTE") - primary_keys <- unname(jk["ADTTE", "ADTTE"]) - - expect_equal(primary_keys, internal_keys$primary) - - foreign_keys <- unname(jk["ADTTE", internal_keys$parent]) - expect_equal(foreign_keys, internal_keys$foreign) -}) - -test_that("cdisc_join_keys will retrieve known primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - internal_keys <- default_cdisc_keys[[.x]] - jk <- cdisc_join_keys(.x) - primary_keys <- unname(jk[.x, .x]) - expect_equal(primary_keys, internal_keys$primary) - if (!is.null(internal_keys$foreign)) { - foreign_keys <- unname(jk[.x, internal_keys$parent]) - expect_equal(foreign_keys, internal_keys$foreign) - } - character(0) - }, - character(0) - ) -}) - -test_that("cdisc_join_keys will retrieve known primary keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - jk <- cdisc_join_keys(.x) - expect_equal(unname(jk[.x, .x]), get_cdisc_keys(.x)) - character(0) - }, - character(0) - ) -}) - -test_that("cdisc_join_keys does nothing with TealDataset", { - adae_cf <- callable_function( - function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) - ) - adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) -}) - -# ----------------------------------------------------------------------------- -# -# Subset-JoinKeys - -test_that("[<-.JoinKeys assigns new relationship pair", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - expect_length(jk["ds1", "ds2"], 0) - - jk["ds1", "ds2"] <- c("id") - expect_identical(jk["ds1", "ds2"], c(id = "id")) - expect_identical(get_join_key(jk, "ds1", "ds2"), jk["ds1", "ds2"]) -}) - -test_that("[<-.JoinKeys modifies existing relationship pair", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - jk["ds1", "ds1"] <- c("Species") - expect_failure(expect_identical(jk["ds1", "ds1"], c(id = "id"))) - expect_identical(get_join_key(jk, "ds1", "ds1"), c(Species = "Species")) -}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 56a9965c1..bd27355ac 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -107,3 +107,604 @@ test_that("join_keys()[]<-.teal_data with empty name is changed to the key value join_keys(td)["d1", "d2"] <- c("A" = "B", "") expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", ""))) }) + +# ----------------------------------------------------------------------------- + +test_that("join_keys cannot set join_keys with incompatible keys", { + # different keys + expect_error( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d1", "d2", keys = c("A" = "B", "C" = "D", "E" = "F")) + ) + ) + + expect_error( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d1", "d2", keys = character(0)) + ) + ) + + expect_error( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d2", "d1", keys = character(0)) + ) + ) + + expect_error( + join_keys( + join_key("d1", "d2", keys = character(0)), + join_key("d2", "d1", keys = c("A" = "B", "C" = "D")) + ) + ) + + expect_error( + join_keys( + join_key("d1", "d2", keys = c("a" = "B", "C" = "D")), + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) + ) + ) +}) + +test_that("join_keys can create join_keys with compatible information", { + # different datasets + expect_silent( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d1", "d3", keys = c("A" = "B", "C" = "D")) + ) + ) + + # same keys + expect_silent( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) + ) + ) + + # reordering keys still matches + expect_silent( + join_keys( + join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), + join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) + ) + ) + + # can match with empty + expect_silent( + join_keys( + join_key("d1", "d2", keys = character(0)), + join_key("d1", "d2", keys = character(0)) + ) + ) + + expect_silent( + join_keys( + join_key("d2", "d1", keys = character(0)), + join_key("d2", "d1", keys = character(0)) + ) + ) + + # swapping dataset order still matches + expect_silent( + join_keys( + join_key("d2", "d1", keys = c("B" = "A", "D" = "C")), + join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) + ) + ) +}) + +test_that("join_keys cannot create JoinKeys with invalid arguments", { + # not using join_key + expect_error(join_keys("d1", "d2", "A")) + # key sets with the same pair of datasets but different values + expect_error(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d1", "B"))) + expect_error(join_keys(join_key("d1", "d2", c("A" = "X")), join_key("d2", "d1", c("A" = "X")))) +}) + +test_that("join_keys can create JoinKeys with valid arguments", { + # no keys + expect_silent(join_keys()) + # list of keys + expect_silent(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d3", "B"))) + # single key out of list + expect_silent(join_keys(join_key("d1", "d2", "A"))) + # key sets with the same pair of datasets and the same values + expect_silent(join_keys(join_key("d1", "d2", c("A" = "C")), join_key("d2", "d1", c("C" = "A")))) + expect_silent(join_keys(join_key("d1", "d2", "X"), join_key("d2", "d1", "X"))) +}) + +test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { + my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) + expect_equal(my_keys["d2", "d1"], c("C" = "A")) +}) + + +test_that("join_keys[ can get all keys for a given dataset", { + my_keys <- join_keys( + join_key("d1", "d2", c("A" = "C")), + join_key("d1", "d3", c("A" = "B", "S" = "T")), + join_key("d2", "d3", c("C" = "U", "L" = "M")) + ) + expect_equal(my_keys[dataset_1 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) + expect_equal(my_keys[dataset_2 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) + expect_equal(my_keys[dataset_1 = "d3"], list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))) +}) + + +test_that("join_keys can get all keys from JoinKeys", { + my_keys <- join_keys( + join_key("d1", "d2", c("A" = "C")), + join_key("d1", "d3", c("A" = "B", "S" = "T")), + join_key("d2", "d3", c("C" = "U", "L" = "M")) + ) + + all_keys <- my_keys + expect_equal(names(all_keys), c("d1", "d2", "d3")) + expect_equal(my_keys[dataset_1 = "d1"], all_keys[["d1"]]) +}) + +test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { + test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) + expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) +}) + +test_that("join_keys if no keys between pair of datasets then getting them returns character(0)", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + expect_equal(my_keys["d1", "d3"], character(0)) + expect_equal(my_keys["d1", "d4"], character(0)) +}) + +# ----------------------------------------------------------------------------- +# +# mutate_join_keys + +test_that("mutate_join_keys.JoinKeys can mutate existing keys", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + new_keys <- mutate_join_keys(my_keys, "d1", "d2", c("X" = "Y")) + expect_equal(new_keys["d1", "d2"], c("X" = "Y")) +}) + +test_that("mutate_join_keys.JoinKeys mutating non-existing keys adds them", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) + expect_equal(new_keys["d3", "d2"], c("Y" = "X")) +}) + +test_that("mutate_join_keys.JoinKeys can remove keys by setting them to character(0)", { + my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) + new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) + expect_equal(new_keys["d1", "d2"], character(0)) +}) + +# ----------------------------------------------------------------------------- +# +# split_join_keys + +testthat::test_that("split_join_keys method returns empty list when object itself is empty", { + x <- join_keys() + testthat::expect_identical(split_join_keys(x), list()) +}) + +testthat::test_that("split_join_keys method returns a named list of JoinKeys objects with an element for each dataset", { + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + res <- split_join_keys(x) + testthat::expect_true(inherits(res, "list")) + testthat::expect_equal(length(res), 5) + testthat::expect_equal(names(res), c("A", "B", "C", "Z", "Y")) + checkmate::expect_list(res, types = "JoinKeys") + + testthat::expect_equal(names(res$A), c("A", "B", "C")) + testthat::expect_equal(names(res$B), c("B", "A")) + testthat::expect_equal(names(res$C), c("C", "A")) + testthat::expect_equal(names(res$Z), c("Z", "Y")) + testthat::expect_equal(names(res$Y), c("Y", "Z")) +}) + +testthat::test_that( + "split_join_keys method returns an updated list after the state of the object is modified by mutate_join_keys", + { + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + res <- split_join_keys(x) + + x2 <- mutate_join_keys(x, "A", "B", c("a" = "b", "aa" = "bb")) + res2 <- split_join_keys(x2) + + testthat::expect_false(identical(res, res2)) + testthat::expect_identical(res2$A$A$B, c("a" = "b", "aa" = "bb")) + + # adding new datasets + x3 <- mutate_join_keys(x2, "D", "G", c("d" = "g")) + res3 <- split_join_keys(x3) + testthat::expect_false(identical(res, res3)) + testthat::expect_false(identical(res2, res3)) + testthat::expect_identical(res3$D$D$G, c("d" = "g")) + testthat::expect_identical(res3$D$G$D, c("g" = "d")) + testthat::expect_identical(names(res3$D), c("D", "G")) + } +) + +testthat::test_that("split_join_keys method does not modify self", { + x <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + previous_self <- x + no_use_output <- split_join_keys(x) + testthat::expect_equal(previous_self, x) +}) + +# ----------------------------------------------------------------------------- +# +# merge_join_keys + +testthat::test_that("merge_join_keys can handle edge case: calling object is empty", { + x <- join_keys() + y <- join_keys() + + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + testthat::expect_silent(merge_join_keys(x, y)) + testthat::expect_identical(join_keys(x), join_keys(x)) +}) + +testthat::test_that("merge_join_keys can handle edge case: argument is an empty object", { + x <- join_keys() + y <- join_keys() + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, x)) + testthat::expect_identical(previous_output, join_keys(y)) +}) + +testthat::test_that("merge_join_keys can handle edge case: argument is a list of empty objects", { + x <- join_keys() + y <- join_keys() + + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x, x))) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_silent(merge_join_keys(y, list(x, x, x))) + testthat::expect_identical(previous_output, join_keys(y)) +}) + +testthat::test_that( + "merge_join_keys throws error when improper argument is passed in without modifying the caller", + { + y <- join_keys() + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + previous_output <- join_keys(y) + testthat::expect_error(y <- merge_join_keys(y)) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(y, 1)) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(y, "A")) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(y, list())) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(list(1))) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys(y, list("A"))) + testthat::expect_identical(previous_output, join_keys(y)) + } +) + +testthat::test_that("merge_join_keys does nothing when argument is a JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, x)) + testthat::expect_identical(previous_output, join_keys(y)) +}) + +testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x))) + testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_silent(merge_join_keys(y, list(x, x))) + testthat::expect_identical(previous_output, join_keys(y)) +}) + +testthat::test_that("merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) + testthat::expect_identical(previous_output, join_keys(y)) +}) + +testthat::test_that("merge_join_keys clones data when argument is a list of one JoinKeys object that is a superset", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")), + join_key("ZZ", "YY", c("zz" = "yy")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + + previous_output <- join_keys(y) + testthat::expect_silent(y <- merge_join_keys(y, list(x))) + testthat::expect_false(identical(previous_output, join_keys(y))) + testthat::expect_identical(join_keys(x), join_keys(y)) +}) + +testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object that is a subset", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")), + join_key("ZZ", "YY", c("zz" = "yy")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + previous_output <- join_keys(x) + testthat::expect_silent(x <- merge_join_keys(x, list(y))) + testthat::expect_identical(previous_output, join_keys(x)) +}) + +testthat::test_that("merge_join_keys merges mutually exclusive data", { + x <- join_keys() + y <- join_keys() + + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")) + ) + join_keys(y) <- list( + join_key("Z", "Y", c("z" = "y")) + ) + + z <- join_keys() + z <- merge_join_keys(z, list(x, y)) + manual_join <- c(join_keys(x), join_keys(y)) + class(manual_join) <- class(new_join_keys()) + testthat::expect_identical(manual_join, join_keys(z)) + + x <- merge_join_keys(x, y) + y <- merge_join_keys(y, x) + + testthat::expect_identical(join_keys(x), join_keys(z)) + testthat::expect_true(all(join_keys(y) %in% join_keys(z)) && all(join_keys(z) %in% join_keys(y))) + testthat::expect_true(all(join_keys(y) %in% join_keys(x)) && all(join_keys(x) %in% join_keys(y))) + + testthat::expect_identical(names(join_keys(z)), c("A", "B", "Z", "Y")) + testthat::expect_equal(length(join_keys(z)), 4) + testthat::expect_identical(join_keys(z)$A$B, c("a" = "b")) + testthat::expect_identical(join_keys(z)$B$A, c("b" = "a")) + testthat::expect_identical(join_keys(z)$Z$Y, c("z" = "y")) + testthat::expect_identical(join_keys(z)$Y$Z, c("y" = "z")) +}) + +# ----------------------------------------------------------------------------- +# +# print.JoinKeys + +testthat::test_that("print.JoinKeys for empty set", { + jk <- join_keys() + testthat::expect_output( + print(jk), + "An empty JoinKeys object." + ) +}) + +testthat::test_that("print.JoinKeys for a non-empty set", { + jk <- join_keys() + join_keys(jk) <- list(join_key("DF1", "DF2", c("id" = "fk"))) + testthat::expect_output( + print(jk), + "A JoinKeys object containing foreign keys between 2 datasets:" + ) +}) + +testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they are empty", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "fk"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_identical( + ss <- parents(jk), + list(df1 = character(0), df2 = "df1") + ) +}) + +# ----------------------------------------------------------------------------- +# +# cdisc_join_keys + +test_that("cdisc_join_keys will generate JoinKeys for named list with non-named elements", { + new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) + jk <- join_keys(new_dataset) + + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will generate JoinKeys for character list", { + new_dataset <- cdisc_join_keys("ADSL", "ADTTE") + jk <- join_keys(new_dataset) + + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will generate JoinKeys for named list", { + new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) + jk <- join_keys(new_dataset) + + expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { + datasets <- names(default_cdisc_keys) + + internal_keys <- default_cdisc_keys[["ADTTE"]] + jk <- cdisc_join_keys("ADTTE") + primary_keys <- unname(jk["ADTTE", "ADTTE"]) + + expect_equal(primary_keys, internal_keys$primary) + + foreign_keys <- unname(jk["ADTTE", internal_keys$parent]) + expect_equal(foreign_keys, internal_keys$foreign) +}) + +test_that("cdisc_join_keys will retrieve known primary and foreign keys", { + datasets <- names(default_cdisc_keys) + + vapply( + datasets, + function(.x) { + internal_keys <- default_cdisc_keys[[.x]] + jk <- cdisc_join_keys(.x) + primary_keys <- unname(jk[.x, .x]) + expect_equal(primary_keys, internal_keys$primary) + if (!is.null(internal_keys$foreign)) { + foreign_keys <- unname(jk[.x, internal_keys$parent]) + expect_equal(foreign_keys, internal_keys$foreign) + } + character(0) + }, + character(0) + ) +}) + +test_that("cdisc_join_keys will retrieve known primary keys", { + datasets <- names(default_cdisc_keys) + + vapply( + datasets, + function(.x) { + jk <- cdisc_join_keys(.x) + expect_equal(unname(jk[.x, .x]), get_cdisc_keys(.x)) + character(0) + }, + character(0) + ) +}) + +test_that("cdisc_join_keys does nothing with TealDataset", { + adae_cf <- callable_function( + function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) + ) + adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) + expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) +}) + +# ----------------------------------------------------------------------------- +# +# Subset-JoinKeys + +test_that("[<-.JoinKeys assigns new relationship pair", { + jk <- join_keys(join_key("ds1", keys = c("id"))) + + expect_length(jk["ds1", "ds2"], 0) + + jk["ds1", "ds2"] <- c("id") + expect_identical(jk["ds1", "ds2"], c(id = "id")) + expect_identical(get_join_key(jk, "ds1", "ds2"), jk["ds1", "ds2"]) +}) + +test_that("[<-.JoinKeys modifies existing relationship pair", { + jk <- join_keys(join_key("ds1", keys = c("id"))) + + jk["ds1", "ds1"] <- c("Species") + expect_failure(expect_identical(jk["ds1", "ds1"], c(id = "id"))) + expect_identical(get_join_key(jk, "ds1", "ds1"), c(Species = "Species")) +}) From 330e6f2eb29f295c20fa36a8813933c69253f3f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 16:00:15 +0100 Subject: [PATCH 013/152] docs: slight improvement on examples --- R/join_keys.R | 14 ++++++++++---- man/join_keys.Rd | 10 ++++++---- man/mutate_join_keys.Rd | 6 +++++- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index ab2901773..4f221845c 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -14,7 +14,7 @@ #' @export #' #' @examples -#' # setting join keys +#' # Setting join keys ---- #' #' jk <- join_keys( #' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), @@ -68,7 +68,7 @@ join_keys <- function(...) { #' @export #' @examples #' -#' # Using the setter (assignment) +#' # Using the setter (assignment) ---- #' #' jk <- join_keys() #' join_keys(jk) @@ -115,6 +115,8 @@ join_keys <- function(...) { #' @export #' @examples #' +#' # Setter for JoinKeys within teal_data ---- +#' #' td <- teal_data() #' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td)["ds2", "ds2"] <- "key2" @@ -146,7 +148,7 @@ join_keys <- function(...) { #' #' @examples #' -#' # Getter for JoinKeys +#' # Getter for JoinKeys ---- #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") @@ -195,7 +197,7 @@ join_keys <- function(...) { #' #' @examples #' -#' # Setter via index +#' # Setter via index ---- #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") @@ -235,6 +237,9 @@ mutate_join_keys <- function(x, dataset_1, dataset_2, value) { #' @rdname mutate_join_keys #' @export #' @examples +#' +#' # JoinKeys ---- +#' #' jk <- join_keys() #' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) #' mutate_join_keys(jk, "ds2", "ds3", "another") @@ -260,6 +265,7 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { #' @rdname mutate_join_keys #' @export #' @examples +#' #' # teal_data ---- #' #' ADSL <- teal.data::example_cdisc_data("ADSL") diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 1dcc72c83..491eba1ca 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -65,7 +65,7 @@ When \code{dataset_2} is omitted, it will create a primary key with \code{datase # Default CDISC join keys cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") -# setting join keys +# Setting join keys ==== jk <- join_keys( join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), @@ -79,7 +79,7 @@ jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") jk -# Using the setter (assignment) +# Using the setter (assignment) ==== jk <- join_keys() join_keys(jk) @@ -87,12 +87,14 @@ join_keys(jk) <- join_key("ds1", "ds2", "some_col") join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" +# Setter for JoinKeys within teal_data ==== + td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td)["ds2", "ds2"] <- "key2" join_keys(td)["ds3", "ds2"] <- "key3" -# Getter for JoinKeys +# Getter for JoinKeys ==== jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") @@ -100,7 +102,7 @@ jk["ds1", "ds2"] jk["ds1"] jk[["ds1"]] -# Setter via index +# Setter via index ==== jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index b5defd4b5..90cb3a9e0 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -29,10 +29,14 @@ modified \code{JoinKeys} object Mutate \code{JoinKeys} with a new values } \examples{ + +# JoinKeys ==== + jk <- join_keys() join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) mutate_join_keys(jk, "ds2", "ds3", "another") -# teal_data ---- + +# teal_data ==== ADSL <- teal.data::example_cdisc_data("ADSL") ADRS <- teal.data::example_cdisc_data("ADRS") From b093dd7c0fa377ff0203c5dd01827522b929392f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 18:21:33 +0100 Subject: [PATCH 014/152] docs: missed 1 exported function --- NAMESPACE | 1 + R/join_keys.R | 36 ++++++++++++++++-------------------- R/parents.R | 12 ++++++------ man/assert_parent_child.Rd | 1 + man/join_keys.Rd | 20 +++++++++----------- man/join_pair.Rd | 7 +------ man/mutate_join_keys.Rd | 7 ++++--- man/parents.Rd | 4 ++-- 8 files changed, 40 insertions(+), 48 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a92c3910a..2a1ff8aa7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -71,6 +71,7 @@ export("col_labels<-") export("data_label<-") export("datanames<-") export("get_join_keys<-") +export("join_keys<-") export("parents<-") export(as_cdisc) export(callable_code) diff --git a/R/join_keys.R b/R/join_keys.R index 4f221845c..220adc89b 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -6,7 +6,9 @@ #' #' @details Note that join keys are symmetric although the relationship only needs #' to be specified once. -# +#' +#' @name join_keys +#' #' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. #' #' @return `JoinKeys` @@ -48,22 +50,20 @@ join_keys <- function(...) { res } -#' @details -#' The setter assignment `join_keys() <- ...` will only work for an empty -#' `JoinKey` object, otherwise `mutate_join_keys()` must be used. #' @rdname join_keys +#' @details +#' The setter assignment `join_keys(obj) <- ...` will merge obj and `...` if obj +#' is not empty. #' #' @param join_keys_obj (`JoinKeys`) empty object to set the new relationship pairs. #' @param value (`JoinKeySet` or list of `JoinKeySet`) relationship pairs to add #' to `JoinKeys` list. +#' +#' @export `join_keys<-` <- function(join_keys_obj, value) { UseMethod("join_keys<-", join_keys_obj) } -#' @details -#' The setter assignment `join_keys() <- ...` will only work for an empty -#' `JoinKey` object, otherwise `mutate_join_keys()` must be used. -#' #' @rdname join_keys #' @export #' @examples @@ -71,10 +71,10 @@ join_keys <- function(...) { #' # Using the setter (assignment) ---- #' #' jk <- join_keys() -#' join_keys(jk) #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") #' join_keys(jk)["ds1", "ds3"] <- "some_col3" +#' jk `join_keys<-.JoinKeys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) @@ -121,6 +121,7 @@ join_keys <- function(...) { #' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td)["ds2", "ds2"] <- "key2" #' join_keys(td)["ds3", "ds2"] <- "key3" +#' join_keys(td) `join_keys<-.teal_data` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) @@ -135,11 +136,10 @@ join_keys <- function(...) { join_keys_obj } +#' @rdname join_keys #' @details #' Getter for JoinKeys that returns the relationship between pairs of datasets. #' -#' @rdname join_keys -#' #' @param join_keys_obj (`JoinKeys`) object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. #' @param dataset_2 (`character`) name of second dataset. @@ -185,12 +185,11 @@ join_keys <- function(...) { result } +#' @rdname join_keys #' @details #' Setter via index directly (bypassing the need to use `join_key()`). #' When `dataset_2` is omitted, it will create a primary key with `dataset_2 = dataset_1`. #' -#' @rdname join_keys -#' #' @param value (`character` vector) value to assign. #' #' @export @@ -216,7 +215,6 @@ join_keys <- function(...) { join_keys_obj } -# wrappers ==== #' Mutate `JoinKeys` with a new values #' #' @description `r lifecycle::badge("experimental")` @@ -241,7 +239,7 @@ mutate_join_keys <- function(x, dataset_1, dataset_2, value) { #' # JoinKeys ---- #' #' jk <- join_keys() -#' join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' mutate_join_keys(jk, "ds2", "ds3", "another") mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { checkmate::assert_string(dataset_1) @@ -278,6 +276,7 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { #' join_keys(x)["ADSL", "ADRS"] #' #' join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) +#' join_keys(x)["ADSL", "ADRS"] mutate_join_keys.teal_data <- function(x, dataset_1, dataset_2, value) { # nolint join_keys(x) <- mutate_join_keys(join_keys(x), dataset_1, dataset_2, value) join_keys(x) @@ -504,11 +503,7 @@ add_key <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { #' @param join_keys_obj (`JoinKeys`) Object with existing pairs. #' @param join_key_obj (`JoinKeySet`) relationship pair to add. #' -#' @examples -#' jk <- join_keys() -#' jk <- join_pair(jk, join_key("ds1", "ds2", "value")) -#' jk <- join_pair(jk, join_key("ds3", "ds2", "value")) -#' jk +#' @keywords internal join_pair <- function(join_keys_obj, join_key_obj) { assert_join_keys(join_keys_obj) checkmate::assert_class(join_key_obj, "JoinKeySet") @@ -590,6 +585,7 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { #' #' @return `join_keys_obj` invisibly #' +#' @keywords internal assert_parent_child <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) jk_parents <- parents(jk) diff --git a/R/parents.R b/R/parents.R index 6caf3b36b..1392e9f33 100644 --- a/R/parents.R +++ b/R/parents.R @@ -56,17 +56,17 @@ parents.JoinKeys <- function(join_keys_obj) { #' @examples #' jk <- join_keys() #' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") -#' parents(jk)["ADTTE"] <- "ADSL" -#' parents(jk)["ADTTE"] <- "ADSL2" +#' parents(jk)["ds5"] <- "ds6" +#' parents(jk)["ds6"] <- "ds7" `parents<-.JoinKeys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } checkmate::assert_list(value, types = "character", names = "named", min.len = 1) - new_parents <- attr(join_keys_obj, "__parents__") + old_parents <- attr(join_keys_obj, "__parents__") for (dataset in names(value)) { - parent <- new_parents[[dataset]] + parent <- old_parents[[dataset]] checkmate::assert( checkmate::check_null(parent), checkmate::check_true( @@ -77,10 +77,10 @@ parents.JoinKeys <- function(join_keys_obj) { "Please check the difference between provided datasets parents and provided join_keys parents." ) if (is.null(parent)) { - new_parents[[dataset]] <- value[[dataset]] + old_parents[[dataset]] <- value[[dataset]] } } - attr(join_keys_obj, "__parents__") <- new_parents + attr(join_keys_obj, "__parents__") <- old_parents join_keys_obj } diff --git a/man/assert_parent_child.Rd b/man/assert_parent_child.Rd index 6200b646b..d69d824aa 100644 --- a/man/assert_parent_child.Rd +++ b/man/assert_parent_child.Rd @@ -15,3 +15,4 @@ assert_parent_child(join_keys_obj) \description{ Helper function checks the parent-child relations are valid } +\keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 491eba1ca..84910d327 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -49,11 +49,8 @@ set the default join keys for CDISC datasets. Note that join keys are symmetric although the relationship only needs to be specified once. -The setter assignment \code{join_keys() <- ...} will only work for an empty -\code{JoinKey} object, otherwise \code{mutate_join_keys()} must be used. - -The setter assignment \code{join_keys() <- ...} will only work for an empty -\code{JoinKey} object, otherwise \code{mutate_join_keys()} must be used. +The setter assignment \code{join_keys(obj) <- ...} will merge obj and \code{...} if obj +is not empty. Getter for JoinKeys that returns the relationship between pairs of datasets. @@ -65,7 +62,7 @@ When \code{dataset_2} is omitted, it will create a primary key with \code{datase # Default CDISC join keys cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") -# Setting join keys ==== +# Setting join keys ---- jk <- join_keys( join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), @@ -79,22 +76,23 @@ jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") jk -# Using the setter (assignment) ==== +# Using the setter (assignment) ---- jk <- join_keys() -join_keys(jk) join_keys(jk) <- join_key("ds1", "ds2", "some_col") join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" +jk -# Setter for JoinKeys within teal_data ==== +# Setter for JoinKeys within teal_data ---- td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td)["ds2", "ds2"] <- "key2" join_keys(td)["ds3", "ds2"] <- "key3" +join_keys(td) -# Getter for JoinKeys ==== +# Getter for JoinKeys ---- jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") @@ -102,7 +100,7 @@ jk["ds1", "ds2"] jk["ds1"] jk[["ds1"]] -# Setter via index ==== +# Setter via index ---- jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") diff --git a/man/join_pair.Rd b/man/join_pair.Rd index fbcfc3b3e..b4bbc8996 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -14,9 +14,4 @@ join_pair(join_keys_obj, join_key_obj) \description{ Helper function to add a new pair to a \code{JoinKeys} object } -\examples{ -jk <- join_keys() -jk <- join_pair(jk, join_key("ds1", "ds2", "value")) -jk <- join_pair(jk, join_key("ds3", "ds2", "value")) -jk -} +\keyword{internal} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 90cb3a9e0..5f13ad0a5 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -30,13 +30,13 @@ Mutate \code{JoinKeys} with a new values } \examples{ -# JoinKeys ==== +# JoinKeys ---- jk <- join_keys() -join_keys(jk) <- list(ds1 = list(ds2 = "some_col")) +join_keys(jk) <- join_key("ds1", "ds2", "some_col") mutate_join_keys(jk, "ds2", "ds3", "another") -# teal_data ==== +# teal_data ---- ADSL <- teal.data::example_cdisc_data("ADSL") ADRS <- teal.data::example_cdisc_data("ADRS") @@ -48,4 +48,5 @@ x <- cdisc_data( join_keys(x)["ADSL", "ADRS"] join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) +join_keys(x)["ADSL", "ADRS"] } diff --git a/man/parents.Rd b/man/parents.Rd index a6fe26609..0f1446842 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -33,6 +33,6 @@ jk <- join_keys() parents(jk) <- list(ADSL = "ADTTE") jk <- join_keys() parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") -parents(jk)["ADTTE"] <- "ADSL" -parents(jk)["ADTTE"] <- "ADSL2" +parents(jk)["ds5"] <- "ds6" +parents(jk)["ds6"] <- "ds7" } From a5d8a07678aa90f49cc84bde8f8c72cbcaa9481b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 18:59:48 +0100 Subject: [PATCH 015/152] remove former tmp class --- R/join_keys.R | 70 +++++++++++++++++---------------------------- man/get_join_key.Rd | 2 +- 2 files changed, 28 insertions(+), 44 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 220adc89b..28c253118 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,33 +156,7 @@ join_keys <- function(...) { #' jk["ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { - if (checkmate::test_integerish(dataset_1, len = 2)) { - # if dataset_1 is an index integet vector, then return itself - # trick to make the following work: join_keys(jk)["ds1", "ds2"] <- "key" - return(join_keys_obj) - } - checkmate::assert_string(dataset_1, null.ok = TRUE) - if (missing(dataset_2)) { - # protection if dataset_2 is passed through by a function - dataset_2 <- NULL - } - checkmate::assert_string(dataset_2, null.ok = TRUE) - - if (is.null(dataset_1) && is.null(dataset_2)) { - return(join_keys_obj) - } - if (is.null(dataset_2)) { - return(join_keys_obj[[dataset_1]]) - } - if (is.null(dataset_1)) { - return(join_keys_obj[[dataset_2]]) - } - - result <- join_keys_obj[[dataset_1]][[dataset_2]] - if (is.null(result)) { - return(character(0)) - } - result + get_join_key(join_keys_obj, dataset_1, dataset_2) } #' @rdname join_keys @@ -208,11 +182,7 @@ join_keys <- function(...) { #' jk["ds1"] <- "primary_key" #' jk `[<-.JoinKeys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { - join_keys_obj <- add_key(join_keys_obj, dataset_1, dataset_2, value) - - class(join_keys_obj) <- unique(c(class(join_keys_obj), "tmp_assignment")) - - join_keys_obj + add_key(join_keys_obj, dataset_1, dataset_2, value) } #' Mutate `JoinKeys` with a new values @@ -436,22 +406,36 @@ new_join_keys <- function() { #' `JoinKeys` object #' #' @keywords internal -get_join_key <- function(join_keys_obj, dataset_1, dataset_2) { - jk <- join_keys(join_keys_obj) - - assert_join_keys(jk) - - if (missing(dataset_1) && missing(dataset_2)) { - return(jk) +get_join_key <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { + if (checkmate::test_integerish(dataset_1, len = 2)) { + # if dataset_1 is an index integet vector, then return itself + # trick to make the following work: join_keys(jk)["ds1", "ds2"] <- "key" + return(join_keys_obj) } + checkmate::assert_string(dataset_1, null.ok = TRUE) if (missing(dataset_2)) { - return(jk[dataset_1]) + # protection if dataset_2 is passed through by a function + dataset_2 <- NULL } - if (missing(dataset_1)) { - return(jk[dataset_2]) + checkmate::assert_string(dataset_2, null.ok = TRUE) + assert_join_keys(join_keys_obj) + + if (is.null(dataset_1) && is.null(dataset_2)) { + return(join_keys_obj) + } + if (is.null(dataset_2)) { + return(join_keys_obj[[dataset_1]]) + } + if (is.null(dataset_1)) { + return(join_keys_obj[[dataset_2]]) } - jk[dataset_1, dataset_2] + result <- join_keys_obj[[dataset_1]][[dataset_2]] + + if (is.null(result)) { + return(character(0)) + } + result } #' Internal assignment of value to a JoinKeys object diff --git a/man/get_join_key.Rd b/man/get_join_key.Rd index 3c842ce73..85e1db769 100644 --- a/man/get_join_key.Rd +++ b/man/get_join_key.Rd @@ -4,7 +4,7 @@ \alias{get_join_key} \title{Get value of a single relationship pair} \usage{ -get_join_key(join_keys_obj, dataset_1, dataset_2) +get_join_key(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) } \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) object that holds the relationship keys.} From 2da33f66f543ed8937427567274c0b5e8a2e1185 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 2 Nov 2023 19:02:56 +0100 Subject: [PATCH 016/152] minor change to examples --- R/join_keys.R | 4 ++-- man/join_keys.Rd | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 28c253118..40a9afd20 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -120,7 +120,7 @@ join_keys <- function(...) { #' td <- teal_data() #' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td)["ds2", "ds2"] <- "key2" -#' join_keys(td)["ds3", "ds2"] <- "key3" +#' join_keys(td) <- join_keys(join_key("ds3", "ds2", "key3")) #' join_keys(td) `join_keys<-.teal_data` <- function(join_keys_obj, value) { if (missing(value)) { @@ -129,7 +129,7 @@ join_keys <- function(...) { if (test_join_keys(value)) { join_keys_obj@join_keys <- merge_join_keys(join_keys_obj@join_keys, value) - return(join_keys_obj@join_keys) + return(join_keys_obj) } join_keys_obj@join_keys$set(value) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 84910d327..eb1cf7c72 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -89,7 +89,7 @@ jk td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td)["ds2", "ds2"] <- "key2" -join_keys(td)["ds3", "ds2"] <- "key3" +join_keys(td) <- join_keys(join_key("ds3", "ds2", "key3")) join_keys(td) # Getter for JoinKeys ---- From 797f9d1487b8fccbaa5a8935b96af2cd32a80875 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 3 Nov 2023 15:54:22 +0100 Subject: [PATCH 017/152] Add [[ and [[<- custom methods for JoinKeys --- NAMESPACE | 2 + R/join_keys.R | 221 +++++++++++++++++++++++++------- inst/WORDLIST | 1 + man/assert_join_keys.Rd | 26 +++- man/assert_join_keys_alike.Rd | 29 +++++ man/join_keys.Rd | 22 ++++ man/merge_join_keys.Rd | 1 + tests/testthat/test-join_keys.R | 2 +- tests/testthat/test-parents.R | 5 + 9 files changed, 256 insertions(+), 53 deletions(-) create mode 100644 man/assert_join_keys_alike.Rd diff --git a/NAMESPACE b/NAMESPACE index 2a1ff8aa7..49df5e6ad 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,8 @@ S3method("[",JoinKeys) S3method("[<-",JoinKeys) +S3method("[[",JoinKeys) +S3method("[[<-",JoinKeys) S3method("join_keys<-",JoinKeys) S3method("join_keys<-",teal_data) S3method("parents<-",JoinKeys) diff --git a/R/join_keys.R b/R/join_keys.R index 40a9afd20..f13fee7ce 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,6 +156,14 @@ join_keys <- function(...) { #' jk["ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { + if (checkmate::test_integerish(dataset_1)) { + return(NextMethod("[", join_keys_obj)) + } else if (length(dataset_1) > 1) { + res <- lapply(dataset_1, function(x) get_join_key(join_keys_obj, x, dataset_2)) + names(res) <- dataset_1 + class(res) <- class(new_join_keys()) + return(res) + } get_join_key(join_keys_obj, dataset_1, dataset_2) } @@ -182,9 +190,105 @@ join_keys <- function(...) { #' jk["ds1"] <- "primary_key" #' jk `[<-.JoinKeys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { + if (checkmate::test_integerish(dataset_1)) { + stop(paste( + "Assigment via index number is not supported with JoinKeys object,", + "please use a dataset name as index and one at a time." + )) + } else if (length(dataset_1) > 1) { + stop(paste( + "Assigment of multiple JoinKeys at the same time is not supported,", + "please do one at a time." + )) + } add_key(join_keys_obj, dataset_1, dataset_2, value) } +#' @rdname join_keys +#' @export +#' @examples +#' +#' jk <- join_keys(join_key("ds1", "ds2", "key")) +#' jk[["ds1"]] +#' jk[["ds1", "ds2"]] +`[[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { + if (!is.null(dataset_1) && !is.null(dataset_2)) { + return(join_keys_obj[[dataset_1]][[dataset_2]]) + } + NextMethod("[[", jk) +} + +#' @rdname join_keys +#' @export +#' @examples +#' +#' jk <- join_keys() +#' jk[["ds1"]] <- list() +#' jk[["ds2"]][["ds3"]] <- "key" +#' jk[["ds3", "ds4"]] <- "new_key" +#' +#' jk <- join_keys() +#' jk[["ds1"]] <- list() +#' jk[["ds2"]][["ds3"]] <- "key" +#' jk[["ds4"]] <- list(ds5 = "new") +#' jk[["ds6", "ds7"]] <- "yada" +#' jk[["ds8", "ds9"]] <- c(A = "B", "C") +`[[<-.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { + checkmate::assert_string(dataset_1) + checkmate::assert_string(dataset_2, null.ok = TRUE) + + # Accepting 2 subscripts + if (!is.null(dataset_2)) { + checkmate::assert_character(value) + # Normalize value + new_join_key <- join_key(dataset_1, dataset_2, value) + dataset_1 <- new_join_key$dataset_1 + dataset_2 <- new_join_key$dataset_2 + value <- new_join_key$keys + + if (is.null(join_keys_obj[[dataset_1]])) { + join_keys_obj[[dataset_1]] <- list() + } + join_keys_obj[[dataset_1]][[dataset_2]] <- value + return(join_keys_obj) + } + + # Accepting 1 subscript with valid `value` formal + checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) + + join_keys_obj <- NextMethod("[[<-", jk) + + # Keep original parameters as variables will be overwritten for `NextMethod` call + original_value <- value + ds1 <- dataset_1 + + # Iterate on all new values to create symmetrical pair + for (ds2 in names(value)) { + if (ds2 == ds1) next + + value <- rlang::`%||%`(join_keys_obj[[ds2]], list()) + new_value <- original_value[[ds2]] + if ( + checkmate::test_character(new_value, min.len = 1) && + all(is.null(names(new_value))) + ) { + new_value <- setNames(new_value, new_value) + } else if ( + checkmate::test_character(new_value, min.len = 1) + ) { + # Invert key + new_value <- setNames(names(new_value), new_value) + } + + # Change variables for NextMethod call + dataset_1 <- ds2 + value[[ds1]] <- new_value + join_keys_obj <- NextMethod("[[<-", join_keys_obj) + } + + join_keys_obj +} + #' Mutate `JoinKeys` with a new values #' #' @description `r lifecycle::badge("experimental")` @@ -329,6 +433,7 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' jk2["ds1", "ds3"] <- "new_col" #' #' merge_join_keys(jk1, jk2) +#' merge_join_keys(jk1, list(jk2)) merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { assert_join_keys(join_keys_obj) @@ -336,6 +441,8 @@ merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { new_join_keys <- list(new_join_keys) } + lapply(new_join_keys, assert_join_keys_alike) + checkmate::assert_list(new_join_keys, types = c("JoinKeys"), min.len = 1) result <- join_keys_obj @@ -388,9 +495,10 @@ print.JoinKeys <- function(x, ...) { #' #' @keywords internal new_join_keys <- function() { - result <- list() - class(result) <- c("JoinKeys", "list") - result + structure( + list(), + class = c("JoinKeys", "list") + ) } #' Get value of a single relationship pair @@ -407,11 +515,6 @@ new_join_keys <- function() { #' #' @keywords internal get_join_key <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { - if (checkmate::test_integerish(dataset_1, len = 2)) { - # if dataset_1 is an index integet vector, then return itself - # trick to make the following work: join_keys(jk)["ds1", "ds2"] <- "key" - return(join_keys_obj) - } checkmate::assert_string(dataset_1, null.ok = TRUE) if (missing(dataset_2)) { # protection if dataset_2 is passed through by a function @@ -446,39 +549,9 @@ get_join_key <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { add_key <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2, null.ok = TRUE) + checkmate::assert_character(value) - # Normalize value - new_join_key <- join_key(dataset_1, dataset_2, value) - dataset_1 <- new_join_key$dataset_1 - dataset_2 <- new_join_key$dataset_2 - value <- new_join_key$keys - - # Create pair ds_1 -> ds_2 - if (is.null(join_keys_obj[[dataset_1]])) join_keys_obj[[dataset_1]] <- list() - - join_keys_obj[[dataset_1]][[dataset_2]] <- value - - # Primary key, do nothing else - if (identical(dataset_1, dataset_2)) { - return(join_keys_obj) - } - - # Create symmetrical pair ds_2 -> ds_1 - if (is.null(join_keys_obj[[dataset_2]])) join_keys_obj[[dataset_2]] <- list() - - if ( - checkmate::test_character(value, min.len = 1) && - all(is.null(names(value))) - ) { - value <- setNames(names(value), value) - } else if ( - checkmate::test_character(value, min.len = 1) - ) { - # Invert key - value <- setNames(names(value), value) - } - - join_keys_obj[[dataset_2]][[dataset_1]] <- value + join_keys_obj[[dataset_1, dataset_2]] <- value join_keys_obj } @@ -500,27 +573,81 @@ join_pair <- function(join_keys_obj, join_key_obj) { join_keys_obj } -#' Check the JoinKeys class membership of an argument +#' Assert the JoinKeys class membership of an argument #' @inheritParams checkmate::assert_class -#' @param extra_classes (`character` vector) with extra classes to check. Can be used #' #' @return `x` invisibly #' #' @keywords internal -assert_join_keys <- function(x, .var.name = checkmate::vname(x)) { - checkmate::assert_class(x, classes = c("JoinKeys"), .var.name = .var.name) +assert_join_keys <- function(x, .var.name = checkmate::vname(x), add = NULL) { + if (missing(x)) { + stop(sprintf("argument \"%s\" is missing, with no default", .var.name)) + } + + res <- check_join_keys(x) + checkmate::makeAssertion(x, res, var.name = .var.name, add) +} + +#' @rdname assert_join_keys_alike +#' @examples +check_join_keys <- function(x) { + checkmate::check_class(x, classes = c("JoinKeys", "list")) } #' @rdname assert_join_keys #' @keywords internal test_join_keys <- function(x) { - checkmate::test_class(x, classes = c("JoinKeys")) + checkmate::makeTest(check_join_keys(x)) } #' @rdname assert_join_keys #' @keywords internal -expect_join_keys <- function(x) { - checkmate::expect_class(x, classes = c("JoinKeys")) +expect_join_keys <- function(x, info = NULL, label = vname(x)) { + checkmate::makeExpectation(x, check_join_keys(x), info = info, label = label) +} + +#' Assert the JoinKeys class membership of an argument +#' @inheritParams checkmate::assert_class +#' +#' @return `x` invisibly +#' +#' @keywords internal +assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NULL) { + if (missing(x)) { + stop(sprintf("argument \"%s\" is missing, with no default", .var.name)) + } + res <- check_join_keys_alike(x) + + checkmate::makeAssertion(x, res, var.name = .var.name, add) +} + +#' @rdname assert_join_keys +#' @examples +#' check_join_keys_alike(list("ds1" = list("key"))) +#' check_join_keys_alike(list("ds1" = list(ds2 = "key"))) +check_join_keys_alike <- function(x) { + result <- checkmate::check_list(x, names = "named", types = "list") + if (checkmate::test_string(result)) { + return(result) + } + result <- all( + vapply( + x, + function(el) { + checkmate::test_list(el, types = "character", names = "named") + }, + logical(1) + ) + ) + if (isFALSE(all(result))) { + return( + paste( + "Elements of list may only be named lists with a vector of type `character`", + "(that may be named or partially named)" + ) + ) + } + result } #' Helper function to assert if two key sets contain incompatible keys diff --git a/inst/WORDLIST b/inst/WORDLIST index b1ea8634f..e33bd1f7e 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -14,4 +14,5 @@ Reproducibility reproducibility returens SCDA +testthat UI diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd index d073530f8..512ae9025 100644 --- a/man/assert_join_keys.Rd +++ b/man/assert_join_keys.Rd @@ -4,13 +4,16 @@ \alias{assert_join_keys} \alias{test_join_keys} \alias{expect_join_keys} -\title{Check the JoinKeys class membership of an argument} +\alias{check_join_keys_alike} +\title{Assert the JoinKeys class membership of an argument} \usage{ -assert_join_keys(x, .var.name = checkmate::vname(x)) +assert_join_keys(x, .var.name = checkmate::vname(x), add = NULL) test_join_keys(x) -expect_join_keys(x) +expect_join_keys(x, info = NULL, label = vname(x)) + +check_join_keys_alike(x) } \arguments{ \item{x}{[any]\cr @@ -20,12 +23,25 @@ Object to check.} Name of the checked object to print in assertions. Defaults to the heuristic implemented in \code{\link[checkmate]{vname}}.} -\item{extra_classes}{(\code{character} vector) with extra classes to check. Can be used} +\item{add}{[\code{AssertCollection}]\cr +Collection to store assertion messages. See \code{\link[checkmate]{AssertCollection}}.} + +\item{info}{[\code{character(1)}]\cr +Extra information to be included in the message for the testthat reporter. +See \code{\link[testthat]{expect_that}}.} + +\item{label}{[\code{character(1)}]\cr +Name of the checked object to print in messages. Defaults to +the heuristic implemented in \code{\link[checkmate]{vname}}.} } \value{ \code{x} invisibly } \description{ -Check the JoinKeys class membership of an argument +Assert the JoinKeys class membership of an argument +} +\examples{ +check_join_keys_alike(list("ds1" = list("key"))) +check_join_keys_alike(list("ds1" = list(ds2 = "key"))) } \keyword{internal} diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd new file mode 100644 index 000000000..e4ce72646 --- /dev/null +++ b/man/assert_join_keys_alike.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{check_join_keys} +\alias{check_join_keys} +\alias{assert_join_keys_alike} +\title{Assert the JoinKeys class membership of an argument} +\usage{ +check_join_keys(x) + +assert_join_keys_alike(x, .var.name = checkmate::vname(x), add = NULL) +} +\arguments{ +\item{x}{[any]\cr +Object to check.} + +\item{.var.name}{[\code{character(1)}]\cr +Name of the checked object to print in assertions. Defaults to +the heuristic implemented in \code{\link[checkmate]{vname}}.} + +\item{add}{[\code{AssertCollection}]\cr +Collection to store assertion messages. See \code{\link[checkmate]{AssertCollection}}.} +} +\value{ +\code{x} invisibly +} +\description{ +Assert the JoinKeys class membership of an argument +} +\keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index eb1cf7c72..11455c31c 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -8,6 +8,8 @@ \alias{join_keys<-.teal_data} \alias{[.JoinKeys} \alias{[<-.JoinKeys} +\alias{[[.JoinKeys} +\alias{[[<-.JoinKeys} \title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} \usage{ cdisc_join_keys(...) @@ -23,6 +25,10 @@ join_keys(join_keys_obj) <- value \method{[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) \method{[}{JoinKeys}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value + +\method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) + +\method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value } \arguments{ \item{...}{optional, a \code{JoinKeySet} objects created using the \code{join_key} function.} @@ -111,4 +117,20 @@ jk["ds1", "ds2"] <- "(new) pair key" # Creates primary key by only defining `dataset_1` jk["ds1"] <- "primary_key" jk + +jk <- join_keys(join_key("ds1", "ds2", "key")) +jk[["ds1"]] +jk[["ds1", "ds2"]] + +jk <- join_keys() +jk[["ds1"]] <- list() +jk[["ds2"]][["ds3"]] <- "key" +jk[["ds3", "ds4"]] <- "new_key" + +jk <- join_keys() +jk[["ds1"]] <- list() +jk[["ds2"]][["ds3"]] <- "key" +jk[["ds4"]] <- list(ds5 = "new") +jk[["ds6", "ds7"]] <- "yada" +jk[["ds8", "ds9"]] <- c(A = "B", "C") } diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index 5cadc5ec5..4d96d2b7a 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -31,4 +31,5 @@ jk2 <- join_keys() jk2["ds1", "ds3"] <- "new_col" merge_join_keys(jk1, jk2) +merge_join_keys(jk1, list(jk2)) } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index bd27355ac..93a91b9fc 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -556,7 +556,7 @@ testthat::test_that("merge_join_keys merges mutually exclusive data", { testthat::expect_true(all(join_keys(y) %in% join_keys(z)) && all(join_keys(z) %in% join_keys(y))) testthat::expect_true(all(join_keys(y) %in% join_keys(x)) && all(join_keys(x) %in% join_keys(y))) - testthat::expect_identical(names(join_keys(z)), c("A", "B", "Z", "Y")) + testthat::expect_identical(names(z), c("A", "B", "Z", "Y")) testthat::expect_equal(length(join_keys(z)), 4) testthat::expect_identical(join_keys(z)$A$B, c("a" = "b")) testthat::expect_identical(join_keys(z)$B$A, c("b" = "a")) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 080847371..0805bff9a 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -189,7 +189,10 @@ testthat::test_that("assert_parent_child throws error if no join_keys exist for join_keys(jk) <- list( join_key("df1", "df1", c("id" = "id")) ) + # Change class as trick to allow for corrupt JoinKeys + class(jk) <- "list" jk[["df2"]][["df1"]] <- "id" + class(jk) <- class(new_join_keys()) parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") testthat::expect_error( assert_parent_child(jk), @@ -202,7 +205,9 @@ testthat::test_that("assert_parent_child throws error if no join_keys exist for join_keys(jk) <- list( join_key("df1", "df1", c("id" = "id")) ) + class(jk) <- "list" jk[["df1"]][["df2"]] <- "id" + class(jk) <- class(new_join_keys()) parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") testthat::expect_error( assert_parent_child(jk), From 9f4bc3338deec7a3c59118f02722f79683099095 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 3 Nov 2023 15:57:52 +0100 Subject: [PATCH 018/152] implement suggestion by @gogonzo on merge function --- R/join_keys.R | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index f13fee7ce..4b4fac088 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -445,17 +445,12 @@ merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { checkmate::assert_list(new_join_keys, types = c("JoinKeys"), min.len = 1) - result <- join_keys_obj - - for (jk in new_join_keys) { - for (dataset_1 in names(jk)) { - for (dataset_2 in names(jk[[dataset_1]])) { - result[[dataset_1]][[dataset_2]] <- jk[[dataset_1]][[dataset_2]] - } - } + for (el in new_join_keys) { + join_keys_obj <- modifyList(join_keys_obj, el) } + logger::log_trace("JoinKeys keys merged.") - return(result) + return(join_keys_obj) } #' Prints `JoinKeys`. From 5d9d73addb185843409a2bbb70e1e8776ce6b2d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 3 Nov 2023 17:16:00 +0100 Subject: [PATCH 019/152] minor fix to prevent normalization on direct assignment --- R/join_keys.R | 27 ++++++++------------------- man/add_key.Rd | 21 --------------------- 2 files changed, 8 insertions(+), 40 deletions(-) delete mode 100644 man/add_key.Rd diff --git a/R/join_keys.R b/R/join_keys.R index 4b4fac088..9451e3523 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -161,7 +161,6 @@ join_keys <- function(...) { } else if (length(dataset_1) > 1) { res <- lapply(dataset_1, function(x) get_join_key(join_keys_obj, x, dataset_2)) names(res) <- dataset_1 - class(res) <- class(new_join_keys()) return(res) } get_join_key(join_keys_obj, dataset_1, dataset_2) @@ -201,7 +200,9 @@ join_keys <- function(...) { "please do one at a time." )) } - add_key(join_keys_obj, dataset_1, dataset_2, value) + + join_keys_obj[[dataset_1, dataset_2]] <- value + join_keys_obj } #' @rdname join_keys @@ -240,6 +241,7 @@ join_keys <- function(...) { # Accepting 2 subscripts if (!is.null(dataset_2)) { checkmate::assert_character(value) + # Normalize value new_join_key <- join_key(dataset_1, dataset_2, value) dataset_1 <- new_join_key$dataset_1 @@ -268,9 +270,10 @@ join_keys <- function(...) { value <- rlang::`%||%`(join_keys_obj[[ds2]], list()) new_value <- original_value[[ds2]] + if ( checkmate::test_character(new_value, min.len = 1) && - all(is.null(names(new_value))) + is.null(names(new_value)) ) { new_value <- setNames(new_value, new_value) } else if ( @@ -536,20 +539,6 @@ get_join_key <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { result } -#' Internal assignment of value to a JoinKeys object -#' -#' @inheritParams join_keys -#' -#' @keywords internal -add_key <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2, null.ok = TRUE) - checkmate::assert_character(value) - - join_keys_obj[[dataset_1, dataset_2]] <- value - join_keys_obj -} - #' Helper function to add a new pair to a `JoinKeys` object #' #' @param join_keys_obj (`JoinKeys`) Object with existing pairs. @@ -564,7 +553,7 @@ join_pair <- function(join_keys_obj, join_key_obj) { dataset_2 <- join_key_obj$dataset_2 keys <- join_key_obj$keys - join_keys_obj <- add_key(join_keys_obj, dataset_1, dataset_2, keys) + join_keys_obj[[dataset_1]][[dataset_2]] <- keys join_keys_obj } @@ -584,7 +573,7 @@ assert_join_keys <- function(x, .var.name = checkmate::vname(x), add = NULL) { } #' @rdname assert_join_keys_alike -#' @examples +#' @keywords internal check_join_keys <- function(x) { checkmate::check_class(x, classes = c("JoinKeys", "list")) } diff --git a/man/add_key.Rd b/man/add_key.Rd deleted file mode 100644 index 4a21dfe89..000000000 --- a/man/add_key.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{add_key} -\alias{add_key} -\title{Internal assignment of value to a JoinKeys object} -\usage{ -add_key(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) -} -\arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} - -\item{dataset_1}{(\code{character}) name of first dataset.} - -\item{dataset_2}{(\code{character}) name of second dataset.} - -\item{value}{(\code{character} vector) value to assign.} -} -\description{ -Internal assignment of value to a JoinKeys object -} -\keyword{internal} From 1e7fbfe11851f51be44a7d6506438362d4cd4021 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 3 Nov 2023 17:28:37 +0100 Subject: [PATCH 020/152] add some fallbacks to respect previous tests --- R/join_keys.R | 59 +++++++++------------------------ tests/testthat/test-join_keys.R | 4 +-- 2 files changed, 18 insertions(+), 45 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 9451e3523..e63225f4d 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -159,11 +159,24 @@ join_keys <- function(...) { if (checkmate::test_integerish(dataset_1)) { return(NextMethod("[", join_keys_obj)) } else if (length(dataset_1) > 1) { - res <- lapply(dataset_1, function(x) get_join_key(join_keys_obj, x, dataset_2)) + res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) names(res) <- dataset_1 return(res) + } else if ( + (missing(dataset_1) && missing(dataset_2)) || + (is.null(dataset_1) && is.null(dataset_2)) + ) { + + } else if (missing(dataset_1) || is.null(dataset_1)) { + return(join_keys_obj[[dataset_2]]) + } else if (missing(dataset_2) || is.null(dataset_2)) { + return(join_keys_obj[[dataset_1]]) + } + result <- join_keys_obj[[dataset_1]][[dataset_2]] + if (is.null(result)) { + return(character(0)) } - get_join_key(join_keys_obj, dataset_1, dataset_2) + result } #' @rdname join_keys @@ -394,7 +407,7 @@ split_join_keys.JoinKeys <- function(join_keys_obj) { function(dataset_1) { lapply( names(join_keys_obj[[dataset_1]]), - function(dataset_2) join_key(dataset_1, dataset_2, get_join_key(join_keys_obj, dataset_1, dataset_2)) + function(dataset_2) join_key(dataset_1, dataset_2, join_keys_obj[[dataset_1]][[dataset_2]]) ) } ) @@ -499,46 +512,6 @@ new_join_keys <- function() { ) } -#' Get value of a single relationship pair -#' -#' @param join_keys_obj (`JoinKeys`) object that holds the relationship keys. -#' @param dataset_1 (`character(1)`) one of the datasets to retrieve keys ( -#' order of the datasets is irrelevant). -#' @param dataset_2 (`character(1)`) the other dataset to retrieve keys (the -#' order of the datasets is irrelevant). -#' -#' @return Character vector with keys or (if one of the datasets is omitted) a -#' list of relationship pairs. If both datasets are omitted it returens the -#' `JoinKeys` object -#' -#' @keywords internal -get_join_key <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { - checkmate::assert_string(dataset_1, null.ok = TRUE) - if (missing(dataset_2)) { - # protection if dataset_2 is passed through by a function - dataset_2 <- NULL - } - checkmate::assert_string(dataset_2, null.ok = TRUE) - assert_join_keys(join_keys_obj) - - if (is.null(dataset_1) && is.null(dataset_2)) { - return(join_keys_obj) - } - if (is.null(dataset_2)) { - return(join_keys_obj[[dataset_1]]) - } - if (is.null(dataset_1)) { - return(join_keys_obj[[dataset_2]]) - } - - result <- join_keys_obj[[dataset_1]][[dataset_2]] - - if (is.null(result)) { - return(character(0)) - } - result -} - #' Helper function to add a new pair to a `JoinKeys` object #' #' @param join_keys_obj (`JoinKeys`) Object with existing pairs. diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 93a91b9fc..799d22a8f 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -698,7 +698,7 @@ test_that("[<-.JoinKeys assigns new relationship pair", { jk["ds1", "ds2"] <- c("id") expect_identical(jk["ds1", "ds2"], c(id = "id")) - expect_identical(get_join_key(jk, "ds1", "ds2"), jk["ds1", "ds2"]) + expect_identical(jk[["ds1"]][["ds2"]], jk["ds1", "ds2"]) }) test_that("[<-.JoinKeys modifies existing relationship pair", { @@ -706,5 +706,5 @@ test_that("[<-.JoinKeys modifies existing relationship pair", { jk["ds1", "ds1"] <- c("Species") expect_failure(expect_identical(jk["ds1", "ds1"], c(id = "id"))) - expect_identical(get_join_key(jk, "ds1", "ds1"), c(Species = "Species")) + expect_identical(jk[["ds1"]][["ds1"]], c(Species = "Species")) }) From 70e748258498f62cf56ccfdd078de5b179ca1f7d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 6 Nov 2023 13:59:47 +0100 Subject: [PATCH 021/152] tests: add some test to subsetting operations --- R/join_keys.R | 6 +-- man/get_join_key.Rd | 26 ----------- tests/testthat/test-join_keys.R | 78 +++++++++++++++++++++++++++++++++ 3 files changed, 81 insertions(+), 29 deletions(-) delete mode 100644 man/get_join_key.Rd diff --git a/R/join_keys.R b/R/join_keys.R index e63225f4d..dd0a4dcd2 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,7 +156,7 @@ join_keys <- function(...) { #' jk["ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { - if (checkmate::test_integerish(dataset_1)) { + if (checkmate::test_integerish(dataset_1) || length(dataset_1) > 0) { return(NextMethod("[", join_keys_obj)) } else if (length(dataset_1) > 1) { res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) @@ -210,7 +210,7 @@ join_keys <- function(...) { } else if (length(dataset_1) > 1) { stop(paste( "Assigment of multiple JoinKeys at the same time is not supported,", - "please do one at a time." + "please only assign one pair at a time." )) } @@ -487,7 +487,7 @@ print.JoinKeys <- function(x, ...) { )) # Hide parents attr(keys_list, "__parents__") <- NULL - print.default(keys_list) + print.default(keys_list[sort(names(keys_list))]) } else { cat("An empty JoinKeys object.") } diff --git a/man/get_join_key.Rd b/man/get_join_key.Rd deleted file mode 100644 index 85e1db769..000000000 --- a/man/get_join_key.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{get_join_key} -\alias{get_join_key} -\title{Get value of a single relationship pair} -\usage{ -get_join_key(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) -} -\arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object that holds the relationship keys.} - -\item{dataset_1}{(\code{character(1)}) one of the datasets to retrieve keys ( -order of the datasets is irrelevant).} - -\item{dataset_2}{(\code{character(1)}) the other dataset to retrieve keys (the -order of the datasets is irrelevant).} -} -\value{ -Character vector with keys or (if one of the datasets is omitted) a -list of relationship pairs. If both datasets are omitted it returens the -\code{JoinKeys} object -} -\description{ -Get value of a single relationship pair -} -\keyword{internal} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 799d22a8f..bffea36cc 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -38,6 +38,84 @@ test_that("join_keys<-.JoinKeys to set via multiple lists that progressively mer expect_length(obj, 6) }) +# ----------------------------------------------------------------------------- +# +# [[ and [[<- +# +test_that("[[<-.JoinKeys is equivalent to using the constructor (double subscript)", { + jk <- join_keys( + join_key("d1", "d2", c("A" = "B", "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + + jk2 <- join_keys() + + jk2[["d1", "d2"]] <- c("A" = "B", "C") + jk2[["d3", "d4"]] <- c("D", "E") + jk2[["d5", "d6"]] <- c("F", "K" = "k") + + expect_identical(jk, jk2) +}) + +test_that("[[<-.JoinKeys is equivalent to using the constructor (single subscript)", { + jk <- join_keys( + join_key("d1", "d2", c("A" = "B", "C" = "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + + jk2 <- join_keys() + + jk2[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") + jk2[["d3"]][["d4"]] <- c("D" = "D", "E" = "E") + jk2[["d5"]][["d6"]] <- c("F" = "F", "K" = "k") + + expect_identical(jk, jk2) +}) + +test_that("[<-.JoinKeys is equivalent to using the constructor (double subscript)", { + jk <- join_keys( + join_key("d1", "d2", c("A", "B")), + join_key("d3", "d4", c("C", "D")), + join_key("d5", "d6", c("E", "F")) + ) + + jk2 <- join_keys() + + jk2["d1", "d2"] <- c("A", "B") + jk2["d3", "d4"] <- c("C", "D") + jk2["d5", "d6"] <- c("E", "F") + + expect_identical(jk, jk2) +}) + +test_that("[.JoinKeys can subscript multiple values by index or name", { + jk <- join_keys( + join_key("d1", "d2", c("A" = "B", "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + + expect_length(jk[1:2], 2) + expect_length(jk[c("d1", "d5")], 2) + + expect_identical(jk[c("d1", "d5")], c(jk["d1"], jk["d5"])) + + expect_identical(jk[2], jk["d2"]) + expect_identical(jk[c(1, 3)], c(jk["d1"], jk["d3"])) +}) + +test_that("[<-.JoinKeys cannot subscript multiple values", { + jk <- join_keys( + join_key("d1", "d2", c("A" = "B", "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + + expect_error(jk[1:2] <- NULL) +}) + # ----------------------------------------------------------------------------- # # mutate_join_keys (empty value name) From d471449eaf604a3a80b5a7257d57a57b18b94dad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 6 Nov 2023 14:44:25 +0100 Subject: [PATCH 022/152] fix: bug with previous commit --- R/join_keys.R | 16 ++++++++++------ tests/testthat/test-join_keys.R | 6 +++--- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index dd0a4dcd2..6b2d0175b 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,20 +156,24 @@ join_keys <- function(...) { #' jk["ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { - if (checkmate::test_integerish(dataset_1) || length(dataset_1) > 0) { + if (missing(dataset_1)) dataset_1 <- NULL + if (missing(dataset_2)) dataset_2 <- NULL + if ( + checkmate::test_integerish(dataset_1) || + (length(dataset_1) >= 2 && is.null(dataset_2)) + ) { return(NextMethod("[", join_keys_obj)) - } else if (length(dataset_1) > 1) { + } else if (length(dataset_1) >= 2) { res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) names(res) <- dataset_1 return(res) } else if ( - (missing(dataset_1) && missing(dataset_2)) || - (is.null(dataset_1) && is.null(dataset_2)) + (is.null(dataset_1) && is.null(dataset_2)) ) { - } else if (missing(dataset_1) || is.null(dataset_1)) { + } else if (is.null(dataset_1)) { return(join_keys_obj[[dataset_2]]) - } else if (missing(dataset_2) || is.null(dataset_2)) { + } else if (is.null(dataset_2)) { return(join_keys_obj[[dataset_1]]) } result <- join_keys_obj[[dataset_1]][[dataset_2]] diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index bffea36cc..550721a80 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -100,10 +100,10 @@ test_that("[.JoinKeys can subscript multiple values by index or name", { expect_length(jk[1:2], 2) expect_length(jk[c("d1", "d5")], 2) - expect_identical(jk[c("d1", "d5")], c(jk["d1"], jk["d5"])) + expect_identical(jk[c("d1", "d5")], list(d1 = jk["d1"], d5 = jk["d5"])) - expect_identical(jk[2], jk["d2"]) - expect_identical(jk[c(1, 3)], c(jk["d1"], jk["d3"])) + expect_identical(jk[2], list(d2 = jk["d2"])) + expect_identical(jk[c(1, 3)], list(d1 = jk["d1"], d3 = jk["d3"])) }) test_that("[<-.JoinKeys cannot subscript multiple values", { From d2af13f4500527c7de67d7c9155b64d6e6110151 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 6 Nov 2023 14:46:45 +0100 Subject: [PATCH 023/152] change join_key to have inner representation similar to API --- R/cdisc_join_keys.R | 2 +- R/join_key.R | 33 ++++++++++++++++++++++++----- R/join_keys.R | 38 +++++++++++++++++++++------------- man/dataset_1.JoinKeySet.Rd | 24 +++++++++++++++++++++ man/join_key.Rd | 3 +++ tests/testthat/test-join_key.R | 4 ++-- 6 files changed, 82 insertions(+), 22 deletions(-) create mode 100644 man/dataset_1.JoinKeySet.Rd diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index aaa89a766..a22036862 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -21,7 +21,7 @@ cdisc_join_keys <- function(...) { name <- names(data_objects)[ix] if (checkmate::test_class(item, "JoinKeySet")) { - jk[item$dataset_1, item$dataset_2] <- item$keys + jk[dataset_1.JoinKeySet(item), dataset_2.JoinKeySet(item)] <- keys.JoinKeySet(item) } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { diff --git a/R/join_key.R b/R/join_key.R index 63b4f48b5..2f951156e 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -18,6 +18,9 @@ #' @seealso [join_keys()] #' #' @export +#' +#' @examples +#' join_key("d1", "d2", c("A" = "B")) join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) @@ -42,11 +45,31 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { } structure( - list( - dataset_1 = dataset_1, - dataset_2 = dataset_2, - keys = keys - ), + setNames(list(setNames(list(keys), dataset_2)), dataset_1), class = "JoinKeySet" ) } + +#' Getter for attributes in `JoinKeySet` object +#' +#' Internal methods for `JoinKeySet` operations +#' +#' @param join_key_object (`JoinKeySet`) object to retrieve attribute from. +#' @return `dataset_1`, `dataset_2` or `key` as `character(1)` +#' +#' @keywords internal +dataset_1.JoinKeySet <- function(join_key_object) { + names(join_key_object) +} + +#' @rdname dataset_1.JoinKeySet +#' @keywords internal +dataset_2.JoinKeySet <- function(join_key_object) { + names(join_key_object[[1]]) +} + +#' @rdname dataset_1.JoinKeySet +#' @keywords internal +keys.JoinKeySet <- function(join_key_object) { + join_key_object[[1]][[1]] +} diff --git a/R/join_keys.R b/R/join_keys.R index 6b2d0175b..cddea3503 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,6 +156,7 @@ join_keys <- function(...) { #' jk["ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { + # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL if (missing(dataset_2)) dataset_2 <- NULL if ( @@ -261,9 +262,9 @@ join_keys <- function(...) { # Normalize value new_join_key <- join_key(dataset_1, dataset_2, value) - dataset_1 <- new_join_key$dataset_1 - dataset_2 <- new_join_key$dataset_2 - value <- new_join_key$keys + dataset_1 <- dataset_1.JoinKeySet(new_join_key) + dataset_2 <- dataset_2.JoinKeySet(new_join_key) + value <- keys.JoinKeySet(new_join_key) if (is.null(join_keys_obj[[dataset_1]])) { join_keys_obj[[dataset_1]] <- list() @@ -526,9 +527,9 @@ join_pair <- function(join_keys_obj, join_key_obj) { assert_join_keys(join_keys_obj) checkmate::assert_class(join_key_obj, "JoinKeySet") - dataset_1 <- join_key_obj$dataset_1 - dataset_2 <- join_key_obj$dataset_2 - keys <- join_key_obj$keys + dataset_1 <- dataset_1.JoinKeySet(join_key_obj) + dataset_2 <- dataset_2.JoinKeySet(join_key_obj) + keys <- keys.JoinKeySet(join_key_obj) join_keys_obj[[dataset_1]][[dataset_2]] <- keys join_keys_obj @@ -622,28 +623,37 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { ) } + dataset_1_one <- dataset_1.JoinKeySet(join_key_1) + dataset_2_one <- dataset_2.JoinKeySet(join_key_1) + keys_one <- keys.JoinKeySet(join_key_1) + + dataset_1_two <- dataset_1.JoinKeySet(join_key_2) + dataset_2_two <- dataset_2.JoinKeySet(join_key_2) + keys_two <- keys.JoinKeySet(join_key_2) + + # if first datasets and the second datasets match and keys # must contain the same named elements - if (join_key_1$dataset_1 == join_key_2$dataset_1 && join_key_1$dataset_2 == join_key_2$dataset_2) { - if (!identical(sort(join_key_1$keys), sort(join_key_2$keys))) { - error_message(join_key_1$dataset_1, join_key_1$dataset_2) + if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) { + if (!identical(sort(keys_one), sort(keys_two))) { + error_message(dataset_1_one, dataset_2_one) } } # if first dataset of join_key_1 matches second dataset of join_key_2 # and the first dataset of join_key_2 must match second dataset of join_key_1 # and keys must contain the same elements but with names and values swapped - if (join_key_1$dataset_1 == join_key_2$dataset_2 && join_key_1$dataset_2 == join_key_2$dataset_1) { + if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) { # have to handle empty case differently as names(character(0)) is NULL - if (length(join_key_1$keys) == 0 && length(join_key_2$keys) == 0) { + if (length(keys_one) == 0 && length(keys_two) == 0) { return(TRUE) } if ( - xor(length(join_key_1$keys) == 0, length(join_key_2$keys) == 0) || - !identical(sort(join_key_1$keys), sort(setNames(names(join_key_2$keys), join_key_2$keys))) + xor(length(keys_one) == 0, length(keys_two) == 0) || + !identical(sort(keys_one), sort(setNames(names(keys_two), keys_two))) ) { - error_message(join_key_1$dataset_1, join_key_1$dataset_2) + error_message(dataset_1_one, dataset_2_one) } } diff --git a/man/dataset_1.JoinKeySet.Rd b/man/dataset_1.JoinKeySet.Rd new file mode 100644 index 000000000..b06684600 --- /dev/null +++ b/man/dataset_1.JoinKeySet.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_key.R +\name{dataset_1.JoinKeySet} +\alias{dataset_1.JoinKeySet} +\alias{dataset_2.JoinKeySet} +\alias{keys.JoinKeySet} +\title{Getter for attributes in \code{JoinKeySet} object} +\usage{ +dataset_1.JoinKeySet(join_key_object) + +dataset_2.JoinKeySet(join_key_object) + +keys.JoinKeySet(join_key_object) +} +\arguments{ +\item{join_key_object}{(\code{JoinKeySet}) object to retrieve attribute from.} +} +\value{ +\code{dataset_1}, \code{dataset_2} or \code{key} as \code{character(1)} +} +\description{ +Internal methods for \code{JoinKeySet} operations +} +\keyword{internal} diff --git a/man/join_key.Rd b/man/join_key.Rd index 24a74efbd..f5b51bb39 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -27,6 +27,9 @@ object of class \code{JoinKeySet} to be passed into \code{join_keys} function. \code{join_key()} will create a relationship for the variables on a pair of datasets. } +\examples{ +join_key("d1", "d2", c("A" = "B")) +} \seealso{ \code{\link[=join_keys]{join_keys()}} } diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R index 3a1961fb0..5fbd2999e 100644 --- a/tests/testthat/test-join_key.R +++ b/tests/testthat/test-join_key.R @@ -43,8 +43,8 @@ test_that("join_key does not throw error with valid arguments", { test_that("join_key will fill empty names with value", { # keys of length 0 jk <- join_key("d1", "d2", keys = c("A" = "B", "C")) - expect_identical(jk$keys, setNames(c("B", "C"), c("A", "C"))) + expect_identical(keys.JoinKeySet(jk), setNames(c("B", "C"), c("A", "C"))) jk <- join_key("d1", "d2", keys = c("B", "C")) - expect_identical(jk$keys, setNames(c("B", "C"), c("B", "C"))) + expect_identical(keys.JoinKeySet(jk), setNames(c("B", "C"), c("B", "C"))) }) From fa5b990c160330b4b06634ec29a3e6e2d1995dca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 10:27:21 +0100 Subject: [PATCH 024/152] fix: r cmd check and pkgdown config --- R/join_keys.R | 11 ++++------- R/parents.R | 2 +- _pkgdown.yml | 4 +++- man/assert_join_keys.Rd | 6 +----- man/parent.Rd | 4 ++-- 5 files changed, 11 insertions(+), 16 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index cddea3503..a6585bb13 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -234,7 +234,7 @@ join_keys <- function(...) { if (!is.null(dataset_1) && !is.null(dataset_2)) { return(join_keys_obj[[dataset_1]][[dataset_2]]) } - NextMethod("[[", jk) + NextMethod("[[", join_keys_obj) } #' @rdname join_keys @@ -276,7 +276,7 @@ join_keys <- function(...) { # Accepting 1 subscript with valid `value` formal checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) - join_keys_obj <- NextMethod("[[<-", jk) + join_keys_obj <- NextMethod("[[<-", join_keys_obj) # Keep original parameters as variables will be overwritten for `NextMethod` call original_value <- value @@ -467,7 +467,7 @@ merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { checkmate::assert_list(new_join_keys, types = c("JoinKeys"), min.len = 1) for (el in new_join_keys) { - join_keys_obj <- modifyList(join_keys_obj, el) + join_keys_obj <- utils::modifyList(join_keys_obj, el) } logger::log_trace("JoinKeys keys merged.") @@ -564,7 +564,7 @@ test_join_keys <- function(x) { #' @rdname assert_join_keys #' @keywords internal -expect_join_keys <- function(x, info = NULL, label = vname(x)) { +expect_join_keys <- function(x, info = NULL, label = checkmate::vname(x)) { checkmate::makeExpectation(x, check_join_keys(x), info = info, label = label) } @@ -584,9 +584,6 @@ assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NUL } #' @rdname assert_join_keys -#' @examples -#' check_join_keys_alike(list("ds1" = list("key"))) -#' check_join_keys_alike(list("ds1" = list(ds2 = "key"))) check_join_keys_alike <- function(x) { result <- checkmate::check_list(x, names = "named", types = "list") if (checkmate::test_string(result)) { diff --git a/R/parents.R b/R/parents.R index 1392e9f33..4d825f450 100644 --- a/R/parents.R +++ b/R/parents.R @@ -1,4 +1,4 @@ -#' Getter for specific parent +#' Getter and setter for specific parent #' #' @param join_keys_obj (`JoinKeys`) object to retrieve. #' @param dataset_name (`character(1)`) diff --git a/_pkgdown.yml b/_pkgdown.yml index 4684fe812..0074c6087 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -122,6 +122,9 @@ reference: - get_labels - join_key - join_keys + - join_keys<- + - parents + - parents<- - python_code - read_script - validate_metadata @@ -134,7 +137,6 @@ reference: - CDISCTealDataConnector - CDISCTealDataset - CDISCTealDatasetConnector - - JoinKeys - MAETealDataset - PythonCodeClass - TealData diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd index 512ae9025..09f0f7b5b 100644 --- a/man/assert_join_keys.Rd +++ b/man/assert_join_keys.Rd @@ -11,7 +11,7 @@ assert_join_keys(x, .var.name = checkmate::vname(x), add = NULL) test_join_keys(x) -expect_join_keys(x, info = NULL, label = vname(x)) +expect_join_keys(x, info = NULL, label = checkmate::vname(x)) check_join_keys_alike(x) } @@ -40,8 +40,4 @@ the heuristic implemented in \code{\link[checkmate]{vname}}.} \description{ Assert the JoinKeys class membership of an argument } -\examples{ -check_join_keys_alike(list("ds1" = list("key"))) -check_join_keys_alike(list("ds1" = list(ds2 = "key"))) -} \keyword{internal} diff --git a/man/parent.Rd b/man/parent.Rd index 6f6026b65..fbfd33146 100644 --- a/man/parent.Rd +++ b/man/parent.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/parents.R \name{parent} \alias{parent} -\title{Getter for specific parent} +\title{Getter and setter for specific parent} \usage{ parent(join_keys_obj, dataset_name) } @@ -12,7 +12,7 @@ parent(join_keys_obj, dataset_name) \item{dataset_name}{(\code{character(1)})} } \description{ -Getter for specific parent +Getter and setter for specific parent } \examples{ jk <- join_keys() From 57e338beae603f69a95f338abbc202ef5894f9d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 11:26:26 +0100 Subject: [PATCH 025/152] Apply suggestions from code review MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Dawid Kałędkowski <6959016+gogonzo@users.noreply.github.com> Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- R/join_keys.R | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index a6585bb13..d45eed69f 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -290,8 +290,7 @@ join_keys <- function(...) { new_value <- original_value[[ds2]] if ( - checkmate::test_character(new_value, min.len = 1) && - is.null(names(new_value)) + checkmate::test_character(new_value, min.len = 1, names = "unnamed") ) { new_value <- setNames(new_value, new_value) } else if ( @@ -343,14 +342,6 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { res <- join_pair(x, join_key(dataset_1, dataset_2, value)) - logger::log_trace( - sprintf( - "JoinKeys updated the keys between %s and %s to %s", - dataset_1, - dataset_2, - paste(value, collapse = ", ") - ) - ) res } From 1d0e55e787f7257d1b91038b62cb41f77debc597 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 11:39:08 +0100 Subject: [PATCH 026/152] pr: importing `%||%` --- NAMESPACE | 1 + R/join_keys.R | 6 ++---- R/parents.R | 2 +- R/teal.data.R | 1 + 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 49df5e6ad..eae7cbaf1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -147,5 +147,6 @@ import(shiny) import(teal.code) importFrom(digest,digest) importFrom(logger,log_trace) +importFrom(rlang,`%||%`) importFrom(shinyjs,useShinyjs) importFrom(stats,setNames) diff --git a/R/join_keys.R b/R/join_keys.R index d45eed69f..8dc5bc9c6 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -286,12 +286,10 @@ join_keys <- function(...) { for (ds2 in names(value)) { if (ds2 == ds1) next - value <- rlang::`%||%`(join_keys_obj[[ds2]], list()) + value <- join_keys_obj[[ds2]] %||% list() new_value <- original_value[[ds2]] - if ( - checkmate::test_character(new_value, min.len = 1, names = "unnamed") - ) { + if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { new_value <- setNames(new_value, new_value) } else if ( checkmate::test_character(new_value, min.len = 1) diff --git a/R/parents.R b/R/parents.R index 4d825f450..1991e1b4d 100644 --- a/R/parents.R +++ b/R/parents.R @@ -35,7 +35,7 @@ parents <- function(join_keys_obj) { #' jk <- join_keys() #' parents(jk) parents.JoinKeys <- function(join_keys_obj) { - rlang::`%||%`(attr(join_keys_obj, "__parents__"), list()) + attr(join_keys_obj, "__parents__") %||% list() } #' @rdname parents diff --git a/R/teal.data.R b/R/teal.data.R index 70bd1af1a..c62eef361 100644 --- a/R/teal.data.R +++ b/R/teal.data.R @@ -11,6 +11,7 @@ # Fix R CMD check notes #' @import shiny +#' @importFrom rlang `%||%` #' @importFrom digest digest #' @importFrom stats setNames #' @importFrom shinyjs useShinyjs From 7ecf89594800f72a32797f39575bcd1ee25c6ce5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 11:54:14 +0100 Subject: [PATCH 027/152] rename JoinKeySet getters to a sane name --- R/cdisc_join_keys.R | 2 +- R/get_keys.R | 1 + R/join_key.R | 10 ++++---- R/join_keys.R | 24 +++++++++---------- ...taset_1.JoinKeySet.Rd => get_dataset_1.Rd} | 14 +++++------ tests/testthat/test-join_key.R | 4 ++-- 6 files changed, 28 insertions(+), 27 deletions(-) rename man/{dataset_1.JoinKeySet.Rd => get_dataset_1.Rd} (65%) diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index a22036862..77920d241 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -21,7 +21,7 @@ cdisc_join_keys <- function(...) { name <- names(data_objects)[ix] if (checkmate::test_class(item, "JoinKeySet")) { - jk[dataset_1.JoinKeySet(item), dataset_2.JoinKeySet(item)] <- keys.JoinKeySet(item) + jk[get_dataset_1(item), get_dataset_2(item)] <- get_keys(item) } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { diff --git a/R/get_keys.R b/R/get_keys.R index 5de4a4d09..6ccbd4d45 100644 --- a/R/get_keys.R +++ b/R/get_keys.R @@ -11,6 +11,7 @@ #' #' @export get_keys <- function(x, ...) { + # TODO: rename function `get_keys.JoinKeySet` to `get_keys` once this generic is removed UseMethod("get_keys") } diff --git a/R/join_key.R b/R/join_key.R index 2f951156e..72fe2b37f 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -58,18 +58,18 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { #' @return `dataset_1`, `dataset_2` or `key` as `character(1)` #' #' @keywords internal -dataset_1.JoinKeySet <- function(join_key_object) { +get_dataset_1 <- function(join_key_object) { names(join_key_object) } -#' @rdname dataset_1.JoinKeySet +#' @rdname get_dataset_1 #' @keywords internal -dataset_2.JoinKeySet <- function(join_key_object) { +get_dataset_2 <- function(join_key_object) { names(join_key_object[[1]]) } -#' @rdname dataset_1.JoinKeySet +#' @rdname get_dataset_1 #' @keywords internal -keys.JoinKeySet <- function(join_key_object) { +get_keys.JoinKeySet <- function(join_key_object) { join_key_object[[1]][[1]] } diff --git a/R/join_keys.R b/R/join_keys.R index 8dc5bc9c6..0294f8d30 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -262,9 +262,9 @@ join_keys <- function(...) { # Normalize value new_join_key <- join_key(dataset_1, dataset_2, value) - dataset_1 <- dataset_1.JoinKeySet(new_join_key) - dataset_2 <- dataset_2.JoinKeySet(new_join_key) - value <- keys.JoinKeySet(new_join_key) + dataset_1 <- get_dataset_1(new_join_key) + dataset_2 <- get_dataset_2(new_join_key) + value <- get_keys(new_join_key) if (is.null(join_keys_obj[[dataset_1]])) { join_keys_obj[[dataset_1]] <- list() @@ -516,9 +516,9 @@ join_pair <- function(join_keys_obj, join_key_obj) { assert_join_keys(join_keys_obj) checkmate::assert_class(join_key_obj, "JoinKeySet") - dataset_1 <- dataset_1.JoinKeySet(join_key_obj) - dataset_2 <- dataset_2.JoinKeySet(join_key_obj) - keys <- keys.JoinKeySet(join_key_obj) + dataset_1 <- get_dataset_1(join_key_obj) + dataset_2 <- get_dataset_2(join_key_obj) + keys <- get_keys(join_key_obj) join_keys_obj[[dataset_1]][[dataset_2]] <- keys join_keys_obj @@ -609,13 +609,13 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { ) } - dataset_1_one <- dataset_1.JoinKeySet(join_key_1) - dataset_2_one <- dataset_2.JoinKeySet(join_key_1) - keys_one <- keys.JoinKeySet(join_key_1) + dataset_1_one <- get_dataset_1(join_key_1) + dataset_2_one <- get_dataset_2(join_key_1) + keys_one <- get_keys(join_key_1) - dataset_1_two <- dataset_1.JoinKeySet(join_key_2) - dataset_2_two <- dataset_2.JoinKeySet(join_key_2) - keys_two <- keys.JoinKeySet(join_key_2) + dataset_1_two <- get_dataset_1(join_key_2) + dataset_2_two <- get_dataset_2(join_key_2) + keys_two <- get_keys(join_key_2) # if first datasets and the second datasets match and keys diff --git a/man/dataset_1.JoinKeySet.Rd b/man/get_dataset_1.Rd similarity index 65% rename from man/dataset_1.JoinKeySet.Rd rename to man/get_dataset_1.Rd index b06684600..8e8fd6076 100644 --- a/man/dataset_1.JoinKeySet.Rd +++ b/man/get_dataset_1.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_key.R -\name{dataset_1.JoinKeySet} -\alias{dataset_1.JoinKeySet} -\alias{dataset_2.JoinKeySet} -\alias{keys.JoinKeySet} +\name{get_dataset_1} +\alias{get_dataset_1} +\alias{get_dataset_2} +\alias{get_keys.JoinKeySet} \title{Getter for attributes in \code{JoinKeySet} object} \usage{ -dataset_1.JoinKeySet(join_key_object) +get_dataset_1(join_key_object) -dataset_2.JoinKeySet(join_key_object) +get_dataset_2(join_key_object) -keys.JoinKeySet(join_key_object) +\method{get_keys}{JoinKeySet}(join_key_object) } \arguments{ \item{join_key_object}{(\code{JoinKeySet}) object to retrieve attribute from.} diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R index 5fbd2999e..6b433b099 100644 --- a/tests/testthat/test-join_key.R +++ b/tests/testthat/test-join_key.R @@ -43,8 +43,8 @@ test_that("join_key does not throw error with valid arguments", { test_that("join_key will fill empty names with value", { # keys of length 0 jk <- join_key("d1", "d2", keys = c("A" = "B", "C")) - expect_identical(keys.JoinKeySet(jk), setNames(c("B", "C"), c("A", "C"))) + expect_identical(get_keys(jk), setNames(c("B", "C"), c("A", "C"))) jk <- join_key("d1", "d2", keys = c("B", "C")) - expect_identical(keys.JoinKeySet(jk), setNames(c("B", "C"), c("B", "C"))) + expect_identical(get_keys(jk), setNames(c("B", "C"), c("B", "C"))) }) From debb1f604dcef2e97de388a9db0239694d3d7341 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:01:07 +0100 Subject: [PATCH 028/152] pr: keep merge_join_keys internal --- NAMESPACE | 3 --- R/join_keys.R | 16 +++------------- man/merge_join_keys.Rd | 11 +---------- 3 files changed, 4 insertions(+), 26 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index eae7cbaf1..f618159f1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -46,8 +46,6 @@ S3method(load_datasets,TealData) S3method(load_datasets,TealDataConnector) S3method(load_datasets,TealDataset) S3method(load_datasets,TealDatasetConnector) -S3method(merge_join_keys,JoinKeys) -S3method(merge_join_keys,default) S3method(mutate_data,TealDataAbstract) S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) @@ -120,7 +118,6 @@ export(join_keys) export(load_dataset) export(load_datasets) export(mae_dataset) -export(merge_join_keys) export(mutate_data) export(mutate_dataset) export(mutate_join_keys) diff --git a/R/join_keys.R b/R/join_keys.R index 0294f8d30..477edc7d4 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -413,13 +413,13 @@ split_join_keys.JoinKeys <- function(join_keys_obj) { } #' @rdname merge_join_keys -#' @export +#' @keywords internal merge_join_keys <- function(join_keys_obj, new_join_keys) { UseMethod("merge_join_keys", join_keys_obj) } #' @rdname merge_join_keys -#' @export +#' @keywords internal merge_join_keys.default <- function(join_keys_obj, new_join_keys) { merge_join_keys(join_keys(join_keys_obj), new_join_keys) } @@ -433,17 +433,7 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' #' @return a new `JoinKeys` object with the resulting merge. #' -#' @export -#' -#' @examples -#' jk1 <- join_keys() -#' jk1["ds1", "ds2"] <- "some_col" -#' -#' jk2 <- join_keys() -#' jk2["ds1", "ds3"] <- "new_col" -#' -#' merge_join_keys(jk1, jk2) -#' merge_join_keys(jk1, list(jk2)) +#' @keywords internal merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { assert_join_keys(join_keys_obj) diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index 4d96d2b7a..e6cbdbe0c 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -23,13 +23,4 @@ a new \code{JoinKeys} object with the resulting merge. \description{ Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object } -\examples{ -jk1 <- join_keys() -jk1["ds1", "ds2"] <- "some_col" - -jk2 <- join_keys() -jk2["ds1", "ds3"] <- "new_col" - -merge_join_keys(jk1, jk2) -merge_join_keys(jk1, list(jk2)) -} +\keyword{internal} From e193ae1ce4bcad4f3874536b611d4111279cc8a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:07:31 +0100 Subject: [PATCH 029/152] pr: remove split_join_keys function --- NAMESPACE | 3 --- R/join_keys.R | 46 ------------------------------------------ man/split_join_keys.Rd | 29 -------------------------- 3 files changed, 78 deletions(-) delete mode 100644 man/split_join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index f618159f1..5415ec69c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -60,8 +60,6 @@ S3method(set_args,TealDatasetConnector) S3method(set_keys,TealDataAbstract) S3method(set_keys,TealDataset) S3method(set_keys,TealDatasetConnector) -S3method(split_join_keys,JoinKeys) -S3method(split_join_keys,default) S3method(to_relational_data,MultiAssayExperiment) S3method(to_relational_data,TealDataset) S3method(to_relational_data,TealDatasetConnector) @@ -134,7 +132,6 @@ export(script_cdisc_dataset_connector) export(script_dataset_connector) export(set_args) export(set_keys) -export(split_join_keys) export(teal_data) export(teal_data_file) export(to_relational_data) diff --git a/R/join_keys.R b/R/join_keys.R index 477edc7d4..c21c3961d 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -366,52 +366,6 @@ mutate_join_keys.teal_data <- function(x, dataset_1, dataset_2, value) { # nolin join_keys(x) } -#' @rdname split_join_keys -#' @export -split_join_keys <- function(join_keys_obj) { - UseMethod("split_join_keys", join_keys_obj) -} - -#' @rdname split_join_keys -#' @export -split_join_keys.default <- function(join_keys_obj) { - split_join_keys(join_keys(join_keys_obj)) -} - -#' Split the `JoinKeys` object into a named list of join keys objects with an element for each dataset -#' -#' @param join_keys_obj (`JoinKeys`) base object to get the keys from. -#' -#' @return (`list`) a list of `JoinKeys` object -#' -#' @rdname split_join_keys -#' -#' @export -#' -#' @examples -#' jk <- join_keys() -#' jk["ds1", "ds2"] <- "some_col" -#' jk["ds1", "ds3"] <- "new_col" -#' split_join_keys(jk) -split_join_keys.JoinKeys <- function(join_keys_obj) { - assert_join_keys(join_keys_obj) - - list_of_list_of_join_key_set <- lapply( - names(join_keys_obj), - function(dataset_1) { - lapply( - names(join_keys_obj[[dataset_1]]), - function(dataset_2) join_key(dataset_1, dataset_2, join_keys_obj[[dataset_1]][[dataset_2]]) - ) - } - ) - res <- lapply(list_of_list_of_join_key_set, function(.x) do.call(join_keys, .x)) - names(res) <- names(join_keys_obj) - - logger::log_trace("JoinKeys keys split.") - return(res) -} - #' @rdname merge_join_keys #' @keywords internal merge_join_keys <- function(join_keys_obj, new_join_keys) { diff --git a/man/split_join_keys.Rd b/man/split_join_keys.Rd deleted file mode 100644 index bf87d7baa..000000000 --- a/man/split_join_keys.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{split_join_keys} -\alias{split_join_keys} -\alias{split_join_keys.default} -\alias{split_join_keys.JoinKeys} -\title{Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset} -\usage{ -split_join_keys(join_keys_obj) - -\method{split_join_keys}{default}(join_keys_obj) - -\method{split_join_keys}{JoinKeys}(join_keys_obj) -} -\arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) base object to get the keys from.} -} -\value{ -(\code{list}) a list of \code{JoinKeys} object -} -\description{ -Split the \code{JoinKeys} object into a named list of join keys objects with an element for each dataset -} -\examples{ -jk <- join_keys() -jk["ds1", "ds2"] <- "some_col" -jk["ds1", "ds3"] <- "new_col" -split_join_keys(jk) -} From 2ab15c8de092545a7d0e6fbaaf125ee9e08eabdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:08:53 +0100 Subject: [PATCH 030/152] clean: minor cleanup after removal of log trace --- R/join_keys.R | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index c21c3961d..1c5319680 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -338,10 +338,7 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { checkmate::assert_string(dataset_2) checkmate::assert_character(value, any.missing = FALSE) - res <- join_pair(x, join_key(dataset_1, dataset_2, value)) - - - res + join_pair(x, join_key(dataset_1, dataset_2, value)) } #' @rdname mutate_join_keys From ac182f99ede7a5238426182f1dc50978f02f3b01 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 12:15:46 +0100 Subject: [PATCH 031/152] fix: remove tests with recently removed split_join_keys --- tests/testthat/test-join_keys.R | 70 --------------------------------- 1 file changed, 70 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 550721a80..d001ab3b1 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -358,76 +358,6 @@ test_that("mutate_join_keys.JoinKeys can remove keys by setting them to characte expect_equal(new_keys["d1", "d2"], character(0)) }) -# ----------------------------------------------------------------------------- -# -# split_join_keys - -testthat::test_that("split_join_keys method returns empty list when object itself is empty", { - x <- join_keys() - testthat::expect_identical(split_join_keys(x), list()) -}) - -testthat::test_that("split_join_keys method returns a named list of JoinKeys objects with an element for each dataset", { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - res <- split_join_keys(x) - testthat::expect_true(inherits(res, "list")) - testthat::expect_equal(length(res), 5) - testthat::expect_equal(names(res), c("A", "B", "C", "Z", "Y")) - checkmate::expect_list(res, types = "JoinKeys") - - testthat::expect_equal(names(res$A), c("A", "B", "C")) - testthat::expect_equal(names(res$B), c("B", "A")) - testthat::expect_equal(names(res$C), c("C", "A")) - testthat::expect_equal(names(res$Z), c("Z", "Y")) - testthat::expect_equal(names(res$Y), c("Y", "Z")) -}) - -testthat::test_that( - "split_join_keys method returns an updated list after the state of the object is modified by mutate_join_keys", - { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - res <- split_join_keys(x) - - x2 <- mutate_join_keys(x, "A", "B", c("a" = "b", "aa" = "bb")) - res2 <- split_join_keys(x2) - - testthat::expect_false(identical(res, res2)) - testthat::expect_identical(res2$A$A$B, c("a" = "b", "aa" = "bb")) - - # adding new datasets - x3 <- mutate_join_keys(x2, "D", "G", c("d" = "g")) - res3 <- split_join_keys(x3) - testthat::expect_false(identical(res, res3)) - testthat::expect_false(identical(res2, res3)) - testthat::expect_identical(res3$D$D$G, c("d" = "g")) - testthat::expect_identical(res3$D$G$D, c("g" = "d")) - testthat::expect_identical(names(res3$D), c("D", "G")) - } -) - -testthat::test_that("split_join_keys method does not modify self", { - x <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_self <- x - no_use_output <- split_join_keys(x) - testthat::expect_equal(previous_self, x) -}) - # ----------------------------------------------------------------------------- # # merge_join_keys From 667d4f8ec960e677fb6314b68815b2570911eaa2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:04:02 +0100 Subject: [PATCH 032/152] fix: [.JoinKeys returns a JoinKeys as it should --- R/TealData.R | 10 +++++++--- R/join_keys.R | 11 ++++++++--- tests/testthat/test-join_keys.R | 16 +++++++--------- 3 files changed, 22 insertions(+), 15 deletions(-) diff --git a/R/TealData.R b/R/TealData.R index b5823e585..d3bab5a04 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -176,11 +176,15 @@ TealData <- R6::R6Class( # nolint #' @return (`character`) named character vector x with names(x) the #' columns of `dataset_1` and the values of `(x)` the corresponding join #' keys in `dataset_2` or `character(0)` if no relationship - get_join_keys = function(dataset_1, dataset_2) { - if (missing(dataset_1) && missing(dataset_2)) { + get_join_keys = function(dataset_1 = NULL, dataset_2 = NULL) { + if (is.null(dataset_1) && is.null(dataset_2)) { private$join_keys + } else if (is.null(dataset_1)) { + private$join_keys[[dataset_2]] + } else if (is.null(dataset_2)) { + private$join_keys[[dataset_1]] } else { - private$join_keys[dataset_1, dataset_2] + private$join_keys[[dataset_1, dataset_2]] } }, diff --git a/R/join_keys.R b/R/join_keys.R index 1c5319680..c9832e2ed 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -154,6 +154,7 @@ join_keys <- function(...) { #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' jk["ds1", "ds2"] #' jk["ds1"] +#' jk[dataset_2 = "ds1"] #' jk[["ds1"]] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { # Protection against missing being passed through functions @@ -171,11 +172,11 @@ join_keys <- function(...) { } else if ( (is.null(dataset_1) && is.null(dataset_2)) ) { - + return(join_keys_obj) } else if (is.null(dataset_1)) { - return(join_keys_obj[[dataset_2]]) + return(join_keys_obj[dataset_2]) } else if (is.null(dataset_2)) { - return(join_keys_obj[[dataset_1]]) + return(NextMethod("[", join_keys_obj)) } result <- join_keys_obj[[dataset_1]][[dataset_2]] if (is.null(result)) { @@ -404,6 +405,10 @@ merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { return(join_keys_obj) } +# S3 methods have to be exported, otherwise `.S3method` needs to be used +.S3method("merge_join_keys", "teal_data", merge_join_keys.default) +.S3method("merge_join_keys", "JoinKeys", merge_join_keys.JoinKeys) + #' Prints `JoinKeys`. #' #' @inheritParams base::print diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index d001ab3b1..c140c0b40 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -100,10 +100,10 @@ test_that("[.JoinKeys can subscript multiple values by index or name", { expect_length(jk[1:2], 2) expect_length(jk[c("d1", "d5")], 2) - expect_identical(jk[c("d1", "d5")], list(d1 = jk["d1"], d5 = jk["d5"])) + expect_identical(jk[c("d1", "d5")], list(d1 = jk[["d1"]], d5 = jk[["d5"]])) - expect_identical(jk[2], list(d2 = jk["d2"])) - expect_identical(jk[c(1, 3)], list(d1 = jk["d1"], d3 = jk["d3"])) + expect_identical(jk[2], list(d2 = jk[["d2"]])) + expect_identical(jk[c(1, 3)], list(d1 = jk[["d1"]], d3 = jk[["d3"]])) }) test_that("[<-.JoinKeys cannot subscript multiple values", { @@ -300,19 +300,17 @@ test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - expect_equal(my_keys["d2", "d1"], c("C" = "A")) }) - test_that("join_keys[ can get all keys for a given dataset", { my_keys <- join_keys( join_key("d1", "d2", c("A" = "C")), join_key("d1", "d3", c("A" = "B", "S" = "T")), join_key("d2", "d3", c("C" = "U", "L" = "M")) ) - expect_equal(my_keys[dataset_1 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys[dataset_2 = "d1"], list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))) - expect_equal(my_keys[dataset_1 = "d3"], list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))) + expect_equal(my_keys[dataset_1 = "d1"], list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")))) + expect_equal(my_keys[dataset_2 = "d1"], list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")))) + expect_equal(my_keys[dataset_1 = "d3"], list("d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L")))) }) - test_that("join_keys can get all keys from JoinKeys", { my_keys <- join_keys( join_key("d1", "d2", c("A" = "C")), @@ -322,7 +320,7 @@ test_that("join_keys can get all keys from JoinKeys", { all_keys <- my_keys expect_equal(names(all_keys), c("d1", "d2", "d3")) - expect_equal(my_keys[dataset_1 = "d1"], all_keys[["d1"]]) + expect_equal(my_keys[dataset_1 = "d1"], list(d1 = all_keys[["d1"]])) }) test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { From 066ce4668b43aea5e7bbf1658e18b59103368800 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:05:29 +0100 Subject: [PATCH 033/152] docs: update documentation --- man/TealData.Rd | 2 +- man/join_keys.Rd | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/man/TealData.Rd b/man/TealData.Rd index f3728fa24..c3470d74d 100644 --- a/man/TealData.Rd +++ b/man/TealData.Rd @@ -199,7 +199,7 @@ name of dataset connector to be returned. If \code{NULL}, all connectors are ret \subsection{Method \code{get_join_keys()}}{ Get join keys between two datasets. \subsection{Usage}{ -\if{html}{\out{
}}\preformatted{TealData$get_join_keys(dataset_1, dataset_2)}\if{html}{\out{
}} +\if{html}{\out{
}}\preformatted{TealData$get_join_keys(dataset_1 = NULL, dataset_2 = NULL)}\if{html}{\out{
}} } \subsection{Arguments}{ diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 11455c31c..4710737cc 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -104,6 +104,7 @@ jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") jk["ds1", "ds2"] jk["ds1"] +jk[dataset_2 = "ds1"] jk[["ds1"]] # Setter via index ---- From c6256a77334286a9044352bafb469bd5a1e5e005 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:17:08 +0100 Subject: [PATCH 034/152] pr: remove internal assert/check/test/expect_join_key in favor of checkmate --- R/join_keys.R | 47 ++++----------------------- man/assert_join_keys.Rd | 43 ------------------------ man/assert_join_keys_alike.Rd | 8 ++--- tests/testthat/helper-get_join_keys.R | 4 +-- 4 files changed, 13 insertions(+), 89 deletions(-) delete mode 100644 man/assert_join_keys.Rd diff --git a/R/join_keys.R b/R/join_keys.R index c9832e2ed..ed54ef78c 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -82,7 +82,7 @@ join_keys <- function(...) { # Assume assignment of join keys as a merge operation # Needed to support join_keys(jk)[ds1, ds2] <- "key" - if (test_join_keys(value)) { + if (checkmate::test_class(value, classes = c("JoinKeys", "list"))) { return(merge_join_keys(join_keys_obj, value)) } @@ -127,7 +127,7 @@ join_keys <- function(...) { return(join_keys_obj) } - if (test_join_keys(value)) { + if (checkmate::test_class(value, c("JoinKeys", "list"))) { join_keys_obj@join_keys <- merge_join_keys(join_keys_obj@join_keys, value) return(join_keys_obj) } @@ -387,9 +387,9 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' #' @keywords internal merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { - assert_join_keys(join_keys_obj) + checkmate::assert_class(join_keys_obj, classes = c("JoinKeys", "list")) - if (test_join_keys(new_join_keys)) { + if (checkmate::test_class(new_join_keys, classes = c("JoinKeys", "list"))) { new_join_keys <- list(new_join_keys) } @@ -459,7 +459,7 @@ new_join_keys <- function() { #' #' @keywords internal join_pair <- function(join_keys_obj, join_key_obj) { - assert_join_keys(join_keys_obj) + checkmate::assert_class(join_keys_obj, c("JoinKeys", "list")) checkmate::assert_class(join_key_obj, "JoinKeySet") dataset_1 <- get_dataset_1(join_key_obj) @@ -470,39 +470,6 @@ join_pair <- function(join_keys_obj, join_key_obj) { join_keys_obj } -#' Assert the JoinKeys class membership of an argument -#' @inheritParams checkmate::assert_class -#' -#' @return `x` invisibly -#' -#' @keywords internal -assert_join_keys <- function(x, .var.name = checkmate::vname(x), add = NULL) { - if (missing(x)) { - stop(sprintf("argument \"%s\" is missing, with no default", .var.name)) - } - - res <- check_join_keys(x) - checkmate::makeAssertion(x, res, var.name = .var.name, add) -} - -#' @rdname assert_join_keys_alike -#' @keywords internal -check_join_keys <- function(x) { - checkmate::check_class(x, classes = c("JoinKeys", "list")) -} - -#' @rdname assert_join_keys -#' @keywords internal -test_join_keys <- function(x) { - checkmate::makeTest(check_join_keys(x)) -} - -#' @rdname assert_join_keys -#' @keywords internal -expect_join_keys <- function(x, info = NULL, label = checkmate::vname(x)) { - checkmate::makeExpectation(x, check_join_keys(x), info = info, label = label) -} - #' Assert the JoinKeys class membership of an argument #' @inheritParams checkmate::assert_class #' @@ -518,7 +485,7 @@ assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NUL checkmate::makeAssertion(x, res, var.name = .var.name, add) } -#' @rdname assert_join_keys +#' @rdname assert_join_keys_alike check_join_keys_alike <- function(x) { result <- checkmate::check_list(x, names = "named", types = "list") if (checkmate::test_string(result)) { @@ -604,7 +571,7 @@ assert_parent_child <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) jk_parents <- parents(jk) - assert_join_keys(jk) + checkmate::assert_class(jk, c("JoinKeys", "list")) if (!is.null(jk_parents)) { for (idx1 in seq_along(jk_parents)) { diff --git a/man/assert_join_keys.Rd b/man/assert_join_keys.Rd deleted file mode 100644 index 09f0f7b5b..000000000 --- a/man/assert_join_keys.Rd +++ /dev/null @@ -1,43 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{assert_join_keys} -\alias{assert_join_keys} -\alias{test_join_keys} -\alias{expect_join_keys} -\alias{check_join_keys_alike} -\title{Assert the JoinKeys class membership of an argument} -\usage{ -assert_join_keys(x, .var.name = checkmate::vname(x), add = NULL) - -test_join_keys(x) - -expect_join_keys(x, info = NULL, label = checkmate::vname(x)) - -check_join_keys_alike(x) -} -\arguments{ -\item{x}{[any]\cr -Object to check.} - -\item{.var.name}{[\code{character(1)}]\cr -Name of the checked object to print in assertions. Defaults to -the heuristic implemented in \code{\link[checkmate]{vname}}.} - -\item{add}{[\code{AssertCollection}]\cr -Collection to store assertion messages. See \code{\link[checkmate]{AssertCollection}}.} - -\item{info}{[\code{character(1)}]\cr -Extra information to be included in the message for the testthat reporter. -See \code{\link[testthat]{expect_that}}.} - -\item{label}{[\code{character(1)}]\cr -Name of the checked object to print in messages. Defaults to -the heuristic implemented in \code{\link[checkmate]{vname}}.} -} -\value{ -\code{x} invisibly -} -\description{ -Assert the JoinKeys class membership of an argument -} -\keyword{internal} diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd index e4ce72646..0cebe57ce 100644 --- a/man/assert_join_keys_alike.Rd +++ b/man/assert_join_keys_alike.Rd @@ -1,13 +1,13 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_keys.R -\name{check_join_keys} -\alias{check_join_keys} +\name{assert_join_keys_alike} \alias{assert_join_keys_alike} +\alias{check_join_keys_alike} \title{Assert the JoinKeys class membership of an argument} \usage{ -check_join_keys(x) - assert_join_keys_alike(x, .var.name = checkmate::vname(x), add = NULL) + +check_join_keys_alike(x) } \arguments{ \item{x}{[any]\cr diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index 58669d0b5..65b9671f2 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -24,7 +24,7 @@ helper_generator_JoinKeys <- function(dataset_1 = "ds1", keys = c("id")) { # nol helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { jk <- join_keys(obj) - expect_join_keys(jk) + expect_s3_class(jk, class = c("JoinKeys", "list")) expect_length(jk, 1) expect_length(jk[dataset_1, dataset_1], 1) @@ -38,7 +38,7 @@ helper_test_getter_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset jk <- join_keys(obj) - expect_join_keys(jk) + expect_s3_class(jk, class = c("JoinKeys", "list")) expect_length(jk, 2) expect_length(jk[dataset_1, dataset_1], 1) expect_length(jk[new_dataset_1, new_dataset_1], 1) From d6b4d9cdf107dd492b650104eee00d0243be6f2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:26:57 +0100 Subject: [PATCH 035/152] [ returns an object of class JoinKeys --- R/join_keys.R | 19 ++++++++++---- man/join_keys.Rd | 7 ++++-- tests/testthat/test-join_keys.R | 44 +++++++++++++++++++++++++++------ 3 files changed, 56 insertions(+), 14 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index ed54ef78c..1c8bd17b9 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -152,10 +152,13 @@ join_keys <- function(...) { #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") -#' jk["ds1", "ds2"] #' jk["ds1"] #' jk[dataset_2 = "ds1"] -#' jk[["ds1"]] +#' jk[1:2] +#' jk[c("ds1", "ds2")] +#' +#' # Double subscript +#' jk["ds1", "ds2"] `[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL @@ -164,7 +167,9 @@ join_keys <- function(...) { checkmate::test_integerish(dataset_1) || (length(dataset_1) >= 2 && is.null(dataset_2)) ) { - return(NextMethod("[", join_keys_obj)) + res <- NextMethod("[", join_keys_obj) + class(res) <- c("JoinKeys", "list") + return(res) } else if (length(dataset_1) >= 2) { res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) names(res) <- dataset_1 @@ -174,9 +179,13 @@ join_keys <- function(...) { ) { return(join_keys_obj) } else if (is.null(dataset_1)) { - return(join_keys_obj[dataset_2]) + res <- join_keys_obj[dataset_2] + class(res) <- c("JoinKeys", "list") + return(res) } else if (is.null(dataset_2)) { - return(NextMethod("[", join_keys_obj)) + res <- NextMethod("[", join_keys_obj) + class(res) <- c("JoinKeys", "list") + return(res) } result <- join_keys_obj[[dataset_1]][[dataset_2]] if (is.null(result)) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 4710737cc..50ef13260 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -102,10 +102,13 @@ join_keys(td) jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") -jk["ds1", "ds2"] jk["ds1"] jk[dataset_2 = "ds1"] -jk[["ds1"]] +jk[1:2] +jk[c("ds1", "ds2")] + +# Double subscript +jk["ds1", "ds2"] # Setter via index ---- diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index c140c0b40..71ade8bfb 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -100,10 +100,16 @@ test_that("[.JoinKeys can subscript multiple values by index or name", { expect_length(jk[1:2], 2) expect_length(jk[c("d1", "d5")], 2) - expect_identical(jk[c("d1", "d5")], list(d1 = jk[["d1"]], d5 = jk[["d5"]])) + expect_identical( + jk[c("d1", "d5")], + structure( + list(d1 = jk[["d1"]], d5 = jk[["d5"]]), + class = c("JoinKeys", "list") + ) + ) - expect_identical(jk[2], list(d2 = jk[["d2"]])) - expect_identical(jk[c(1, 3)], list(d1 = jk[["d1"]], d3 = jk[["d3"]])) + expect_identical(jk[2], structure(list(d2 = jk[["d2"]]), class = c("JoinKeys", "list"))) + expect_identical(jk[c(1, 3)], structure(list(d1 = jk[["d1"]], d3 = jk[["d3"]]), class = c("JoinKeys", "list"))) }) test_that("[<-.JoinKeys cannot subscript multiple values", { @@ -306,9 +312,27 @@ test_that("join_keys[ can get all keys for a given dataset", { join_key("d1", "d3", c("A" = "B", "S" = "T")), join_key("d2", "d3", c("C" = "U", "L" = "M")) ) - expect_equal(my_keys[dataset_1 = "d1"], list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")))) - expect_equal(my_keys[dataset_2 = "d1"], list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")))) - expect_equal(my_keys[dataset_1 = "d3"], list("d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L")))) + expect_equal( + my_keys[dataset_1 = "d1"], + structure( + list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), + class = c("JoinKeys", "list") + ) + ) + expect_equal( + my_keys[dataset_2 = "d1"], + structure( + list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), + class = c("JoinKeys", "list") + ) + ) + expect_equal( + my_keys[dataset_1 = "d3"], + structure( + list("d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))), + class = c("JoinKeys", "list") + ) + ) }) test_that("join_keys can get all keys from JoinKeys", { @@ -320,7 +344,13 @@ test_that("join_keys can get all keys from JoinKeys", { all_keys <- my_keys expect_equal(names(all_keys), c("d1", "d2", "d3")) - expect_equal(my_keys[dataset_1 = "d1"], list(d1 = all_keys[["d1"]])) + expect_equal( + my_keys[dataset_1 = "d1"], + structure( + list(d1 = all_keys[["d1"]]), + class = c("JoinKeys", "list") + ) + ) }) test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { From 5b55df6c8689fd05b9fcaf6e57a0db032cacf90e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 13:45:29 +0100 Subject: [PATCH 036/152] clean: fix linter problems --- R/join_keys.R | 4 +-- R/parents.R | 2 +- tests/testthat/helper-get_join_keys.R | 5 ++- tests/testthat/test-join_keys.R | 48 +++++++++++++++------------ 4 files changed, 34 insertions(+), 25 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 1c8bd17b9..fb9bfb91a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -435,7 +435,7 @@ print.JoinKeys <- function(x, ...) { length(keys_list) )) # Hide parents - attr(keys_list, "__parents__") <- NULL + attr(keys_list, "__parents__") <- NULL # nolint: object_name_linter print.default(keys_list[sort(names(keys_list))]) } else { cat("An empty JoinKeys object.") @@ -485,7 +485,7 @@ join_pair <- function(join_keys_obj, join_key_obj) { #' @return `x` invisibly #' #' @keywords internal -assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NULL) { +assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NULL) { # nolint: object_name_linter if (missing(x)) { stop(sprintf("argument \"%s\" is missing, with no default", .var.name)) } diff --git a/R/parents.R b/R/parents.R index 1991e1b4d..13a45bed0 100644 --- a/R/parents.R +++ b/R/parents.R @@ -80,7 +80,7 @@ parents.JoinKeys <- function(join_keys_obj) { old_parents[[dataset]] <- value[[dataset]] } } - attr(join_keys_obj, "__parents__") <- old_parents + attr(join_keys_obj, "__parents__") <- old_parents # nolint: object_name_linter join_keys_obj } diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index 65b9671f2..0071ba9d3 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -32,7 +32,10 @@ helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { } #' Test suite for JoinKeys after manual adding a primary key -helper_test_getter_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset_1 = "ds2", new_keys = c("id")) { +helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter + dataset_1 = "ds1", + new_dataset_1 = "ds2", + new_keys = c("id")) { obj <- helper_test_getter_join_keys(obj, dataset_1) join_keys(obj)[new_dataset_1] <- c(new_keys) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 71ade8bfb..9082524b0 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -353,10 +353,13 @@ test_that("join_keys can get all keys from JoinKeys", { ) }) -test_that("join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", { - test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) - expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) -}) +test_that( + "join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", + { + test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) + expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) + } +) test_that("join_keys if no keys between pair of datasets then getting them returns character(0)", { my_keys <- join_keys(join_key("d1", "d2", "A")) @@ -506,25 +509,28 @@ testthat::test_that("merge_join_keys does nothing when argument is a list of one testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", { - x <- join_keys() - y <- join_keys() +testthat::test_that( + "merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", + { + x <- join_keys() + y <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) - testthat::expect_identical(previous_output, join_keys(y)) -}) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) + testthat::expect_identical(previous_output, join_keys(y)) + } +) testthat::test_that("merge_join_keys clones data when argument is a list of one JoinKeys object that is a superset", { x <- join_keys() From 978de4c83d691d5e6cd3a9e67572f7ec0c8c9a98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 14:47:14 +0100 Subject: [PATCH 037/152] docs: update NEWS --- NEWS.md | 4 +++- inst/WORDLIST | 1 + 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 313bd4a98..20517b37c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,12 +2,14 @@ ### Enhancements * Simplified `join_key` to better support primary keys. -* Added subset and subset-assignment to `JoinKeySet` class to manipulate relationship pair keys _(`[` and `[<-`)_. +* `JoinKey` `R6` object was removed in favor of a list-like object. Subset operators and assignments are supported (`[`, `[[`, `[<-` and `[[<-`) +* `join_keys` function works as a constructor, getter and setter. ### Breaking changes * Introduced new data class (`teal_data`) which replaces deprecated `TealData`. New data class becomes a standard input for whole `teal` framework. * Deprecated `teal_data` constructor when `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects are provided. New delayed data loading functions introduced in `teal` package. + ### Miscellaneous * Specified minimal version of package dependencies. diff --git a/inst/WORDLIST b/inst/WORDLIST index e33bd1f7e..1d151081d 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -4,6 +4,7 @@ Forkers formatters funder Getter +getter Hoffmann iteratively JoinKeys From fcb9518b95fd314c452238d458775ed4c9d0e705 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 15:01:52 +0100 Subject: [PATCH 038/152] docs: add missing entries to pkgdown --- _pkgdown.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 0074c6087..77b06a17a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -123,10 +123,13 @@ reference: - join_key - join_keys - join_keys<- + - parent - parents - parents<- + - print.JoinKeys - python_code - read_script + - update_keys_given_parents - validate_metadata - title: For Developers subtitle: R6 Classes From 300e2ed4ec14af7d99b6a7cdd2f8bc48db21ae12 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 15:59:43 +0100 Subject: [PATCH 039/152] feat: convert keys with empty strings to their name or throw error --- R/join_key.R | 30 +++++++++++++++++++++++++++++- man/join_key.Rd | 3 +++ tests/testthat/test-join_key.R | 27 +++++++++++++++++++++++++++ tests/testthat/test-join_keys.R | 27 +++++++++++++++------------ 4 files changed, 74 insertions(+), 13 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 72fe2b37f..40e606a9e 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -20,21 +20,47 @@ #' @export #' #' @examples +#' join_key("d1", "d2", c("A")) #' join_key("d1", "d2", c("A" = "B")) +#' join_key("d1", "d2", c("A" = "B", "C")) +#' join_key("d1", "d2", c("A" = "B", "C" = "")) join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) - checkmate::assert_character(keys, any.missing = FALSE) + checkmate::assert_character(keys, any.missing = FALSE, min.len = 1) if (length(keys) > 0) { if (is.null(names(keys))) { names(keys) <- keys } + keys <- trimws(keys) + names(keys) <- trimws(names(keys)) + + # Remove keys with empty value and without name + if (any(keys == "" & names(keys) == "")) { + message("Key with an empty value and name are ignored.") + keys <- keys[keys != "" & names(keys) != ""] + if (!checkmate::test_character(keys, any.missing = FALSE, min.len = 1)) { + checkmate::makeAssertion( + keys, + "Must be of type 'character' with at least on non-empty key/name(key)", + var.name = "keys", + collection = NULL + ) + } + } + + # Set name of keys without one: c("A") -> c("A" = "A") if (any(names(keys) == "")) { names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""] } + # Set value of keys with empty string, but non-empty name: c("A" = "") -> c("A" = "A") + if (any(keys == "" & names(keys) != "")) { + keys[keys == ""] <- names(keys[keys == ""]) + } + stopifnot(!is.null(names(keys))) stopifnot(!anyDuplicated(keys)) stopifnot(!anyDuplicated(names(keys))) @@ -73,3 +99,5 @@ get_dataset_2 <- function(join_key_object) { get_keys.JoinKeySet <- function(join_key_object) { join_key_object[[1]][[1]] } +# Remove this once generic `get_keys` is removed (and rename non-exported function to `get_keys`) +.S3method("get_keys", "JoinKeySet", get_keys.JoinKeySet) diff --git a/man/join_key.Rd b/man/join_key.Rd index f5b51bb39..a1f34111e 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -28,7 +28,10 @@ object of class \code{JoinKeySet} to be passed into \code{join_keys} function. of datasets. } \examples{ +join_key("d1", "d2", c("A")) join_key("d1", "d2", c("A" = "B")) +join_key("d1", "d2", c("A" = "B", "C")) +join_key("d1", "d2", c("A" = "B", "C" = "")) } \seealso{ \code{\link[=join_keys]{join_keys()}} diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R index 6b433b099..e4e91c14a 100644 --- a/tests/testthat/test-join_key.R +++ b/tests/testthat/test-join_key.R @@ -1,3 +1,13 @@ +test_that("join_key throws error when keys are all empty strings", { + # invalid types + expect_error(join_key("d1", "d2", keys = c("", "", "", ""))) +}) + +test_that("join_key throws error when keys are all strings with empty spaces", { + # invalid types + expect_error(join_key("d1", "d2", keys = c(" ", " ", " ", " "))) +}) + test_that("join_key throws error with invalid keys arguments", { # invalid types expect_error(join_key("d1", "d2", keys = NULL)) @@ -48,3 +58,20 @@ test_that("join_key will fill empty names with value", { jk <- join_key("d1", "d2", keys = c("B", "C")) expect_identical(get_keys(jk), setNames(c("B", "C"), c("B", "C"))) }) + +test_that("join_key will fill empty values with name", { + # keys of length 0 + jk <- join_key("d1", "d2", keys = c("A" = "B", "C" = "")) + expect_identical(get_keys(jk), setNames(c("B", "C"), c("A", "C"))) + + jk <- join_key("d1", "d2", keys = c("B", "C" = "")) + expect_identical(get_keys(jk), setNames(c("B", "C"), c("B", "C"))) +}) + +test_that("join_key ignores empty name/value on keys if it has other keys", { + expect_message(jk <- join_key("d1", "d2", keys = c("A" = "B", "")), "are ignored") + expect_identical(get_keys(jk), setNames(c("B"), c("A"))) + + expect_message(jk <- join_key("d1", "d2", keys = c("B", "")), "are ignored") + expect_identical(get_keys(jk), setNames(c("B"), c("B"))) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 9082524b0..b3f7cc143 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -134,11 +134,14 @@ test_that("mutate_join_keys with empty name is changed to the key value", { # set key on non-empty variable name equal to "" jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "C" = "")) - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" - jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "")) - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) + expect_message( + jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "")), + "are ignored" + ) + expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) }) test_that("[<-.JoinKeys with empty name is changed to the key value", { @@ -150,12 +153,12 @@ test_that("[<-.JoinKeys with empty name is changed to the key value", { # set key on non-empty variable name equal to "" jk <- join_keys() jk["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" jk <- join_keys() - jk["d1", "d2"] <- c("A" = "B", "") - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) + expect_message(jk["d1", "d2"] <- c("A" = "B", ""), "are ignored") + expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) }) test_that("join_keys()[]<-.JoinKeys with empty name is changed to the key value", { @@ -167,12 +170,12 @@ test_that("join_keys()[]<-.JoinKeys with empty name is changed to the key value" # set key on non-empty variable name equal to "" jk <- join_keys() join_keys(jk)["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" jk <- join_keys() - join_keys(jk)["d1", "d2"] <- c("A" = "B", "") - expect_equal(jk["d1", "d2"], setNames(c("B", ""), c("A", ""))) + expect_message(join_keys(jk)["d1", "d2"] <- c("A" = "B", ""), "are ignored") + expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) }) test_that("join_keys()[]<-.teal_data with empty name is changed to the key value", { @@ -184,12 +187,12 @@ test_that("join_keys()[]<-.teal_data with empty name is changed to the key value # set key on non-empty variable name equal to "" td <- teal_data() join_keys(td)["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", "C"))) + expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" td <- teal_data() - join_keys(td)["d1", "d2"] <- c("A" = "B", "") - expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", ""), c("A", ""))) + expect_message(join_keys(td)["d1", "d2"] <- c("A" = "B", ""), "are ignored") + expect_equal(join_keys(td)["d1", "d2"], setNames(c("B"), c("A"))) }) # ----------------------------------------------------------------------------- From 46172dda7a8dc4f81fbe3651a45b66e44e03c7ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 16:09:39 +0100 Subject: [PATCH 040/152] small optimization on previous commit --- R/join_key.R | 10 +--------- R/join_keys.R | 1 - tests/testthat/test-join_key.R | 19 +++++++++---------- 3 files changed, 10 insertions(+), 20 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 40e606a9e..20543a9f6 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -27,7 +27,7 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) - checkmate::assert_character(keys, any.missing = FALSE, min.len = 1) + checkmate::assert_character(keys, any.missing = FALSE) if (length(keys) > 0) { if (is.null(names(keys))) { @@ -41,14 +41,6 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { if (any(keys == "" & names(keys) == "")) { message("Key with an empty value and name are ignored.") keys <- keys[keys != "" & names(keys) != ""] - if (!checkmate::test_character(keys, any.missing = FALSE, min.len = 1)) { - checkmate::makeAssertion( - keys, - "Must be of type 'character' with at least on non-empty key/name(key)", - var.name = "keys", - collection = NULL - ) - } } # Set name of keys without one: c("A") -> c("A" = "A") diff --git a/R/join_keys.R b/R/join_keys.R index fb9bfb91a..c459101e7 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -347,7 +347,6 @@ mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) checkmate::assert_character(value, any.missing = FALSE) - join_pair(x, join_key(dataset_1, dataset_2, value)) } diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R index e4e91c14a..9a099d771 100644 --- a/tests/testthat/test-join_key.R +++ b/tests/testthat/test-join_key.R @@ -1,13 +1,3 @@ -test_that("join_key throws error when keys are all empty strings", { - # invalid types - expect_error(join_key("d1", "d2", keys = c("", "", "", ""))) -}) - -test_that("join_key throws error when keys are all strings with empty spaces", { - # invalid types - expect_error(join_key("d1", "d2", keys = c(" ", " ", " ", " "))) -}) - test_that("join_key throws error with invalid keys arguments", { # invalid types expect_error(join_key("d1", "d2", keys = NULL)) @@ -75,3 +65,12 @@ test_that("join_key ignores empty name/value on keys if it has other keys", { expect_message(jk <- join_key("d1", "d2", keys = c("B", "")), "are ignored") expect_identical(get_keys(jk), setNames(c("B"), c("B"))) }) + +test_that("join_key sets key as character(0) when keys are all all empty strings", { + # invalid types + jk <- join_key("d1", "d2", keys = c("", "", "", "")) + expect_length(get_keys(jk), 0) + + jk2 <- join_key("d1", "d2", keys = c(" ", " ", " ", " ")) + expect_length(get_keys(jk2), 0) +}) From a1b825af446674b0defd3dc2f9e6d03dc7660829 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 7 Nov 2023 17:46:29 +0100 Subject: [PATCH 041/152] fix: bug detected with teal_data and adds extra tests --- R/join_keys.R | 3 +- tests/testthat/helper-get_join_keys.R | 93 ++++++++++++++++++++++++++- tests/testthat/test-join_keys.R | 43 +++++++++++++ 3 files changed, 136 insertions(+), 3 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index c459101e7..4da8639b2 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -90,7 +90,6 @@ join_keys <- function(...) { if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "JoinKeySet", min.len = 1)) { jk <- new_join_keys() join_keys(jk) <- value - message("note: Keys already set, merging new list of JoinKeySet with existing keys.") return(merge_join_keys(join_keys_obj, jk)) } @@ -132,7 +131,7 @@ join_keys <- function(...) { return(join_keys_obj) } - join_keys_obj@join_keys$set(value) + join_keys(join_keys_obj@join_keys) <- value join_keys_obj } diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index 0071ba9d3..56387ff5e 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -37,7 +37,7 @@ helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter new_dataset_1 = "ds2", new_keys = c("id")) { obj <- helper_test_getter_join_keys(obj, dataset_1) - join_keys(obj)[new_dataset_1] <- c(new_keys) + join_keys(obj)[new_dataset_1] <- c(new_keys) # primary key jk <- join_keys(obj) @@ -46,3 +46,94 @@ helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter expect_length(jk[dataset_1, dataset_1], 1) expect_length(jk[new_dataset_1, new_dataset_1], 1) } + +#' Test suite for JoinKeys after manual adding a primary key +helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length_linter + obj <- helper_test_getter_join_keys(obj, "ds1") + + counter <- 2 + .ds <- function(add = 1, prefix = "ds") { + counter <<- counter + add + paste0(prefix, "-", counter - add) + } + + .key <- function(type = 1, prefix = "col") { + col_name <- .ds(add = 1, prefix = prefix) + switch(type, + "1" = col_name, + "2" = setNames(col_name, col_name), + "3" = setNames(col_name, paste0(col_name, "-diff")), + "4" = setNames("", paste0(col_name)) + ) + } + + # Primary key (each adds 1) + join_keys(obj)[.ds()] <- .key() + join_keys(obj)[.ds(add = 0), .ds()] <- .key(2) + join_keys(obj)[.ds(add = 0), .ds()] <- .key(4) + join_keys(obj)[.ds(add = 0), .ds()] <- character(0) + expect_error(join_keys(obj)[.ds(add = 0), .ds()] <- .key(3)) + + join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(1)) + join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(2)) + join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(4)) + join_keys(obj) <- join_key(.ds(add = 0), .ds(), character(0)) + expect_error(join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(3))) + + # Relationship pair (each adds 2) + join_keys(obj)[[.ds()]][[.ds()]] <- .key(1) + join_keys(obj)[[.ds()]][[.ds()]] <- .key(2) + join_keys(obj)[[.ds()]][[.ds()]] <- .key(3) + join_keys(obj)[[.ds()]][[.ds()]] <- .key(4) + join_keys(obj)[[.ds()]][[.ds()]] <- character(0) + + # Relationship pair alt 1 (each adds 2) + join_keys(obj)[[.ds(), .ds()]] <- .key(1) + join_keys(obj)[[.ds(), .ds()]] <- .key(2) + join_keys(obj)[[.ds(), .ds()]] <- .key(3) + join_keys(obj)[[.ds(), .ds()]] <- .key(4) + join_keys(obj)[[.ds(), .ds()]] <- character(0) + + # Relationship pair alt 2 (each adds 2) + join_keys(obj)[[.ds()]] <- setNames(list(.key(1)), .ds()) + join_keys(obj)[[.ds()]] <- setNames(list(.key(2)), .ds()) + join_keys(obj)[[.ds()]] <- setNames(list(.key(3)), .ds()) + join_keys(obj)[[.ds()]] <- setNames(list(.key(4)), .ds()) + join_keys(obj)[[.ds()]] <- setNames(list(character(0)), .ds()) + + # Using join_key (each adds 2) + join_keys(obj) <- join_key(.ds(), .ds(), .key(1)) + join_keys(obj) <- join_key(.ds(), .ds(), .key(2)) + join_keys(obj) <- join_key(.ds(), .ds(), .key(3)) + join_keys(obj) <- join_key(.ds(), .ds(), .key(4)) + join_keys(obj) <- join_key(.ds(), .ds(), character(0)) + + # (each join_key adds 2) + join_keys(obj) <- list( + join_key(.ds(), .ds(), .key(1)), + join_key(.ds(), .ds(), .key(2)), + join_key(.ds(), .ds(), .key(3)), + join_key(.ds(), .ds(), .key(4)), + join_key(.ds(), .ds(), character(0)) + ) + + # (each join_key adds 2) + join_keys(obj) <- join_keys( + join_key(.ds(), .ds(), .key(1)), + join_key(.ds(), .ds(), .key(2)), + join_key(.ds(), .ds(), .key(3)), + join_key(.ds(), .ds(), .key(4)), + join_key(.ds(), .ds(), character(0)) + ) + + expect_s3_class(join_keys(obj), class = c("JoinKeys", "list")) + + expected_length <- 68 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` + expect_length(join_keys(obj), expected_length) + + join_keys(obj) <- join_key("ds-manual", .ds(), .key(1)) + expect_length(join_keys(obj), expected_length + 2) # adds 2 new datasets + + join_keys(obj) <- join_key(.ds(), "ds-manual", .key(1)) + expect_length(join_keys(obj), expected_length + 2 + 1) # adds 1 new dataset as ds-manual already exists +} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index b3f7cc143..092637138 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -12,6 +12,16 @@ test_that("join_keys.JoinKeys will return itself", { helper_test_getter_join_keys(obj, "ds1") }) +test_that("join_keys<-.teal_data shared test to setter (in mass)", { + obj <- helper_generator_teal_data() + helper_test_setter_mass_join_keys_add(obj) +}) + +test_that("join_keys<-.JoinKeys shared test to setter (in mass)", { + obj <- helper_generator_JoinKeys() + helper_test_setter_mass_join_keys_add(obj) +}) + test_that("join_keys<-.teal_data shared test to getter and setter", { obj <- helper_generator_teal_data() helper_test_getter_join_keys_add(obj, "ds1", "ds2") @@ -42,6 +52,23 @@ test_that("join_keys<-.JoinKeys to set via multiple lists that progressively mer # # [[ and [[<- # +test_that("[[<-.JoinKeys creates symmetric relationship", { + jk <- join_keys() + + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") + + expect_identical( + jk, + structure( + list( + d1 = list(d2 = c("A" = "B", "C" = "C")), + d2 = list(d1 = c("B" = "A", "C" = "C")) + ), + class = c("JoinKeys", "list") + ) + ) +}) + test_that("[[<-.JoinKeys is equivalent to using the constructor (double subscript)", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), @@ -197,6 +224,22 @@ test_that("join_keys()[]<-.teal_data with empty name is changed to the key value # ----------------------------------------------------------------------------- +test_that("join_keys constructor creates symmetric relationship", { + jk <- join_keys(join_key("d1", "d2", c("A" = "B", "C" = "C"))) + + expect_identical( + jk, + structure( + list( + d1 = list(d2 = c("A" = "B", "C" = "C")), + d2 = list(d1 = c("B" = "A", "C" = "C")) + ), + class = c("JoinKeys", "list") + ) + ) +}) + + test_that("join_keys cannot set join_keys with incompatible keys", { # different keys expect_error( From 0e09e72a230d6280797fca2f786d8e629c303f23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 11:56:51 +0100 Subject: [PATCH 042/152] code review: empty string were already dropped MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- R/join_key.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 20543a9f6..ca1a15f55 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -45,11 +45,11 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { # Set name of keys without one: c("A") -> c("A" = "A") if (any(names(keys) == "")) { - names(keys)[names(keys) == "" & keys != ""] <- keys[names(keys) == "" & keys != ""] + names(keys)[names(keys) == ""] <- keys[names(keys) == ""] } # Set value of keys with empty string, but non-empty name: c("A" = "") -> c("A" = "A") - if (any(keys == "" & names(keys) != "")) { + if (any(keys == "")) { keys[keys == ""] <- names(keys[keys == ""]) } From 43f321f57fbac52c487eafccfa063fccb7da62dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 11:59:18 +0100 Subject: [PATCH 043/152] pr: use only structure to build JoinKeySet --- R/join_key.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/R/join_key.R b/R/join_key.R index ca1a15f55..80d353c64 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -63,7 +63,13 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { } structure( - setNames(list(setNames(list(keys), dataset_2)), dataset_1), + list( + structure( + list(keys), + names = dataset_2 + ) + ), + names = dataset_1, class = "JoinKeySet" ) } From 0cad9c7c39b2700c6db1d1b15960be4f6f9e29a0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 12:01:23 +0100 Subject: [PATCH 044/152] pr: rename parameter to join_key_set_object --- R/join_key.R | 14 +++++++------- man/get_dataset_1.Rd | 8 ++++---- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 80d353c64..1be7d5c32 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -78,24 +78,24 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { #' #' Internal methods for `JoinKeySet` operations #' -#' @param join_key_object (`JoinKeySet`) object to retrieve attribute from. +#' @param join_key_set_object (`JoinKeySet`) object to retrieve attribute from. #' @return `dataset_1`, `dataset_2` or `key` as `character(1)` #' #' @keywords internal -get_dataset_1 <- function(join_key_object) { - names(join_key_object) +get_dataset_1 <- function(join_key_set_object) { + names(join_key_set_object) } #' @rdname get_dataset_1 #' @keywords internal -get_dataset_2 <- function(join_key_object) { - names(join_key_object[[1]]) +get_dataset_2 <- function(join_key_set_object) { + names(join_key_set_object[[1]]) } #' @rdname get_dataset_1 #' @keywords internal -get_keys.JoinKeySet <- function(join_key_object) { - join_key_object[[1]][[1]] +get_keys.JoinKeySet <- function(join_key_set_object) { + join_key_set_object[[1]][[1]] } # Remove this once generic `get_keys` is removed (and rename non-exported function to `get_keys`) .S3method("get_keys", "JoinKeySet", get_keys.JoinKeySet) diff --git a/man/get_dataset_1.Rd b/man/get_dataset_1.Rd index 8e8fd6076..4cd68c19c 100644 --- a/man/get_dataset_1.Rd +++ b/man/get_dataset_1.Rd @@ -6,14 +6,14 @@ \alias{get_keys.JoinKeySet} \title{Getter for attributes in \code{JoinKeySet} object} \usage{ -get_dataset_1(join_key_object) +get_dataset_1(join_key_set_object) -get_dataset_2(join_key_object) +get_dataset_2(join_key_set_object) -\method{get_keys}{JoinKeySet}(join_key_object) +\method{get_keys}{JoinKeySet}(join_key_set_object) } \arguments{ -\item{join_key_object}{(\code{JoinKeySet}) object to retrieve attribute from.} +\item{join_key_set_object}{(\code{JoinKeySet}) object to retrieve attribute from.} } \value{ \code{dataset_1}, \code{dataset_2} or \code{key} as \code{character(1)} From 816fc836a0dbe9a2e9799c548c2dab283cb3342a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 12:08:33 +0100 Subject: [PATCH 045/152] spelling: regenerates WORDLIST --- R/join_keys.R | 4 ++-- inst/WORDLIST | 17 +++++++---------- man/assert_join_keys_alike.Rd | 4 ++-- man/join_keys.Rd | 2 +- 4 files changed, 12 insertions(+), 15 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 4da8639b2..02de2610a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -137,7 +137,7 @@ join_keys <- function(...) { #' @rdname join_keys #' @details -#' Getter for JoinKeys that returns the relationship between pairs of datasets. +#' Getter for `JoinKeys` that returns the relationship between pairs of datasets. #' #' @param join_keys_obj (`JoinKeys`) object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. @@ -477,7 +477,7 @@ join_pair <- function(join_keys_obj, join_key_obj) { join_keys_obj } -#' Assert the JoinKeys class membership of an argument +#' Assert the `JoinKeys` class membership of an argument #' @inheritParams checkmate::assert_class #' #' @return `x` invisibly diff --git a/inst/WORDLIST b/inst/WORDLIST index 1d151081d..063052f75 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,19 +1,16 @@ CDISC -cloneable Forkers +Getter +Hoffmann +Pre +Reproducibility +SCDA +UI +cloneable formatters funder -Getter getter -Hoffmann iteratively -JoinKeys -Pre pre repo -Reproducibility reproducibility -returens -SCDA -testthat -UI diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd index 0cebe57ce..39aa848aa 100644 --- a/man/assert_join_keys_alike.Rd +++ b/man/assert_join_keys_alike.Rd @@ -3,7 +3,7 @@ \name{assert_join_keys_alike} \alias{assert_join_keys_alike} \alias{check_join_keys_alike} -\title{Assert the JoinKeys class membership of an argument} +\title{Assert the \code{JoinKeys} class membership of an argument} \usage{ assert_join_keys_alike(x, .var.name = checkmate::vname(x), add = NULL) @@ -24,6 +24,6 @@ Collection to store assertion messages. See \code{\link[checkmate]{AssertCollect \code{x} invisibly } \description{ -Assert the JoinKeys class membership of an argument +Assert the \code{JoinKeys} class membership of an argument } \keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 50ef13260..57178ad24 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -58,7 +58,7 @@ to be specified once. The setter assignment \code{join_keys(obj) <- ...} will merge obj and \code{...} if obj is not empty. -Getter for JoinKeys that returns the relationship between pairs of datasets. +Getter for \code{JoinKeys} that returns the relationship between pairs of datasets. Setter via index directly (bypassing the need to use \code{join_key()}). When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. From 2b5d3397efc9906c989c13dae5b197d7e4b3e370 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 13:22:29 +0100 Subject: [PATCH 046/152] feat: use of S3 method for join_keys to support extensions --- NAMESPACE | 4 +++ R/join_keys.R | 76 ++++++++++++++++++++++++++++++++++++++---------- man/join_keys.Rd | 46 +++++++++++++++++++++++++---- 3 files changed, 106 insertions(+), 20 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 5415ec69c..754f07fd6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -40,6 +40,10 @@ S3method(get_raw_data,TealDatasetConnector) S3method(is_pulled,TealDataAbstract) S3method(is_pulled,TealDataset) S3method(is_pulled,TealDatasetConnector) +S3method(join_keys,JoinKeys) +S3method(join_keys,TealData) +S3method(join_keys,default) +S3method(join_keys,teal_data) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) S3method(load_datasets,TealData) diff --git a/R/join_keys.R b/R/join_keys.R index 02de2610a..81c6f3923 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -4,14 +4,23 @@ #' #' @description `r lifecycle::badge("stable")` #' -#' @details Note that join keys are symmetric although the relationship only needs -#' to be specified once. +#' @details - `join_keys()`: When called without arguments it will return an +#' empty constructor. +#' - `join_keys(x)`: When called with a single argument it will return the `JoinKeys` +#' object contained in `x` (if it contains a `JoinKeys` object). +#' - `join_keys(...)`: When called with a single or more `JoinKeySet` parameters it will +#' create a new object. #' -#' @name join_keys +#' Note that join keys are created symmetrically, that is, if `dat1` and `dat2` +#' have a join key of `col1`, then 2 join keys are created, `dat1 → dat2` and +#' `dat2 → dat1`. The only exception is for a primary key. #' -#' @param ... optional, a `JoinKeySet` objects created using the `join_key` function. +#' @param x (optional), when no argument is given the empty constructor is called. +#' Otherwise, it can be one of: `JoinKeys`, `teal_data` or `JoinKeySet`. +#' @param ... (optional), additional `JoinKeySet` objects when `x` is a `JoinKeySet`. +#' If argument types are mixed the call will fail. #' -#' @return `JoinKeys` +#' @return `JoinKeys` object. #' #' @export #' @@ -29,17 +38,54 @@ #' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") #' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") #' jk -join_keys <- function(...) { - x <- rlang::list2(...) - - # Getter - if (checkmate::test_list(x, len = 1, types = c("JoinKeys"))) { - return(x[[1]]) - } else if (checkmate::test_list(x, len = 1, types = c("teal_data"))) { - return(x[[1]]@join_keys) - } else if (checkmate::test_list(x, len = 1, types = c("TealData"))) { - return(x[[1]]$get_join_keys()) +#' +#' td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) +#' join_keys(td) +#' +#' jk <- join_keys() +#' join_keys(jk) +#' +#' jk <- join_keys() +#' jk <- join_keys(join_key("a", "b", "c")) +#' jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) +join_keys <- function(x = NULL, ...) { + if (is.null(x)) { + return(new_join_keys()) } + UseMethod("join_keys", x) +} + +#' @rdname join_keys +#' @export +join_keys.JoinKeys <- function(x, ...) { + if (missing(...)) { + return(x) + } + join_keys.default(x, ...) +} + +#' @rdname join_keys +#' @export +join_keys.teal_data <- function(x, ...) { + if (missing(...)) { + return(x@join_keys) + } + join_keys.default(x, ...) +} + +#' @rdname join_keys +#' @export +join_keys.TealData <- function(x, ...) { + if (missing(...)) { + return(x$get_join_keys()) + } + join_keys.default(x, ...) +} + +#' @rdname join_keys +#' @export +join_keys.default <- function(x, ...) { + x <- append(list(x), rlang::list2(...)) # Constructor res <- new_join_keys() diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 57178ad24..953241d4f 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -3,6 +3,10 @@ \name{cdisc_join_keys} \alias{cdisc_join_keys} \alias{join_keys} +\alias{join_keys.JoinKeys} +\alias{join_keys.teal_data} +\alias{join_keys.TealData} +\alias{join_keys.default} \alias{join_keys<-} \alias{join_keys<-.JoinKeys} \alias{join_keys<-.teal_data} @@ -14,7 +18,15 @@ \usage{ cdisc_join_keys(...) -join_keys(...) +join_keys(x = NULL, ...) + +\method{join_keys}{JoinKeys}(x, ...) + +\method{join_keys}{teal_data}(x, ...) + +\method{join_keys}{TealData}(x, ...) + +\method{join_keys}{default}(x, ...) join_keys(join_keys_obj) <- value @@ -31,7 +43,11 @@ join_keys(join_keys_obj) <- value \method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value } \arguments{ -\item{...}{optional, a \code{JoinKeySet} objects created using the \code{join_key} function.} +\item{...}{(optional), additional \code{JoinKeySet} objects when \code{x} is a \code{JoinKeySet}. +If argument types are mixed the call will fail.} + +\item{x}{(optional), when no argument is given the empty constructor is called. +Otherwise, it can be one of: \code{JoinKeys}, \code{teal_data} or \code{JoinKeySet}.} \item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} @@ -42,7 +58,7 @@ join_keys(join_keys_obj) <- value \item{dataset_2}{(\code{character}) name of second dataset.} } \value{ -\code{JoinKeys} +\code{JoinKeys} object. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} @@ -52,8 +68,18 @@ join_keys(join_keys_obj) <- value join keys for CDISC datasets. It is used internally by \code{cdisc_data} to set the default join keys for CDISC datasets. -Note that join keys are symmetric although the relationship only needs -to be specified once. +\itemize{ +\item \code{join_keys()}: When called without arguments it will return an +empty constructor. +\item \code{join_keys(x)}: When called with a single argument it will return the \code{JoinKeys} +object contained in \code{x} (if it contains a \code{JoinKeys} object). +\item \code{join_keys(...)}: When called with a single or more \code{JoinKeySet} parameters it will +create a new object. +} + +Note that join keys are created symmetrically, that is, if \code{dat1} and \code{dat2} +have a join key of \code{col1}, then 2 join keys are created, \verb{dat1 → dat2} and +\verb{dat2 → dat1}. The only exception is for a primary key. The setter assignment \code{join_keys(obj) <- ...} will merge obj and \code{...} if obj is not empty. @@ -82,6 +108,16 @@ jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") jk +td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) +join_keys(td) + +jk <- join_keys() +join_keys(jk) + +jk <- join_keys() +jk <- join_keys(join_key("a", "b", "c")) +jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) + # Using the setter (assignment) ---- jk <- join_keys() From 9632762628e1bab4a7f7245eb715da4730e5b513 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 14:16:35 +0100 Subject: [PATCH 047/152] pr: rename JoinKeySet to join_key_set --- R/TealData.R | 2 +- R/cdisc_data.R | 2 +- R/cdisc_join_keys.R | 2 +- R/get_keys.R | 2 +- R/join_key.R | 14 +++++++------- R/join_keys.R | 24 ++++++++++++------------ R/teal_data.R | 4 ++-- man/TealData.Rd | 2 +- man/cdisc_data.Rd | 2 +- man/get_dataset_1.Rd | 10 +++++----- man/join_key.Rd | 2 +- man/join_keys.Rd | 8 ++++---- man/join_pair.Rd | 2 +- man/teal_data.Rd | 2 +- tests/testthat/test-join_keys.R | 2 +- 15 files changed, 40 insertions(+), 40 deletions(-) diff --git a/R/TealData.R b/R/TealData.R index d3bab5a04..2a687accc 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -8,7 +8,7 @@ #' #' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr #' objects -#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr +#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr #' (optional) object with dataset column relationships used for joining. #' If empty then an empty `JoinKeys` object is passed by default. #' @param check (`logical`) reproducibility check - whether evaluated preprocessing code gives the same objects diff --git a/R/cdisc_data.R b/R/cdisc_data.R index e043db499..133b56ca8 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -5,7 +5,7 @@ #' for given datasets whose names match ADAM datasets names. #' #' @inheritParams teal_data -#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr +#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr #' (optional) object with datasets column names used for joining. #' If empty then it would be automatically derived basing on intersection of datasets primary keys. #' For ADAM datasets it would be automatically derived. diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index 77920d241..a102c0cfc 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -20,7 +20,7 @@ cdisc_join_keys <- function(...) { item <- data_objects[[ix]] name <- names(data_objects)[ix] - if (checkmate::test_class(item, "JoinKeySet")) { + if (checkmate::test_class(item, "join_key_set")) { jk[get_dataset_1(item), get_dataset_2(item)] <- get_keys(item) } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) diff --git a/R/get_keys.R b/R/get_keys.R index 6ccbd4d45..8b996e006 100644 --- a/R/get_keys.R +++ b/R/get_keys.R @@ -11,7 +11,7 @@ #' #' @export get_keys <- function(x, ...) { - # TODO: rename function `get_keys.JoinKeySet` to `get_keys` once this generic is removed + # TODO: rename function `get_keys.join_key_set` to `get_keys` once this generic is removed UseMethod("get_keys") } diff --git a/R/join_key.R b/R/join_key.R index 1be7d5c32..a5aa61444 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -13,7 +13,7 @@ #' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1` #' and `dataset_2`. #' -#' @return object of class `JoinKeySet` to be passed into `join_keys` function. +#' @return object of class `join_key_set` to be passed into `join_keys` function. #' #' @seealso [join_keys()] #' @@ -70,15 +70,15 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { ) ), names = dataset_1, - class = "JoinKeySet" + class = "join_key_set" ) } -#' Getter for attributes in `JoinKeySet` object +#' Getter for attributes in `join_key_set` object #' -#' Internal methods for `JoinKeySet` operations +#' Internal methods for `join_key_set` operations #' -#' @param join_key_set_object (`JoinKeySet`) object to retrieve attribute from. +#' @param join_key_set_object (`join_key_set`) object to retrieve attribute from. #' @return `dataset_1`, `dataset_2` or `key` as `character(1)` #' #' @keywords internal @@ -94,8 +94,8 @@ get_dataset_2 <- function(join_key_set_object) { #' @rdname get_dataset_1 #' @keywords internal -get_keys.JoinKeySet <- function(join_key_set_object) { +get_keys.join_key_set <- function(join_key_set_object) { join_key_set_object[[1]][[1]] } # Remove this once generic `get_keys` is removed (and rename non-exported function to `get_keys`) -.S3method("get_keys", "JoinKeySet", get_keys.JoinKeySet) +.S3method("get_keys", "join_key_set", get_keys.join_key_set) diff --git a/R/join_keys.R b/R/join_keys.R index 81c6f3923..2d77cb95e 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,6 +1,6 @@ # Constructors ==== -#' Create a `JoinKeys` out of a list of `JoinKeySet` objects +#' Create a `JoinKeys` out of a list of `join_key_set` objects #' #' @description `r lifecycle::badge("stable")` #' @@ -8,7 +8,7 @@ #' empty constructor. #' - `join_keys(x)`: When called with a single argument it will return the `JoinKeys` #' object contained in `x` (if it contains a `JoinKeys` object). -#' - `join_keys(...)`: When called with a single or more `JoinKeySet` parameters it will +#' - `join_keys(...)`: When called with a single or more `join_key_set` parameters it will #' create a new object. #' #' Note that join keys are created symmetrically, that is, if `dat1` and `dat2` @@ -16,8 +16,8 @@ #' `dat2 → dat1`. The only exception is for a primary key. #' #' @param x (optional), when no argument is given the empty constructor is called. -#' Otherwise, it can be one of: `JoinKeys`, `teal_data` or `JoinKeySet`. -#' @param ... (optional), additional `JoinKeySet` objects when `x` is a `JoinKeySet`. +#' Otherwise, it can be one of: `JoinKeys`, `teal_data` or `join_key_set`. +#' @param ... (optional), additional `join_key_set` objects when `x` is a `join_key_set`. #' If argument types are mixed the call will fail. #' #' @return `JoinKeys` object. @@ -102,7 +102,7 @@ join_keys.default <- function(x, ...) { #' is not empty. #' #' @param join_keys_obj (`JoinKeys`) empty object to set the new relationship pairs. -#' @param value (`JoinKeySet` or list of `JoinKeySet`) relationship pairs to add +#' @param value (`join_key_set` or list of `join_key_set`) relationship pairs to add #' to `JoinKeys` list. #' #' @export @@ -132,18 +132,18 @@ join_keys.default <- function(x, ...) { return(merge_join_keys(join_keys_obj, value)) } - # Assignment of list of JoinKeySet will merge it with existing JoinKeys - if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "JoinKeySet", min.len = 1)) { + # Assignment of list of join_key_set will merge it with existing JoinKeys + if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "join_key_set", min.len = 1)) { jk <- new_join_keys() join_keys(jk) <- value return(merge_join_keys(join_keys_obj, jk)) } - if (inherits(value, "JoinKeySet")) value <- list(value) + if (inherits(value, "join_key_set")) value <- list(value) - checkmate::assert_list(value, types = "JoinKeySet", min.len = 1) + checkmate::assert_list(value, types = "join_key_set", min.len = 1) - # check if any JoinKeySets share the same datasets but different values + # check if any join_key_sets share the same datasets but different values for (idx_1 in seq_along(value)) { for (idx_2 in seq_along(value[idx_1])) { assert_compatible_keys(value[[idx_1]], value[[idx_2]]) @@ -508,12 +508,12 @@ new_join_keys <- function() { #' Helper function to add a new pair to a `JoinKeys` object #' #' @param join_keys_obj (`JoinKeys`) Object with existing pairs. -#' @param join_key_obj (`JoinKeySet`) relationship pair to add. +#' @param join_key_obj (`join_key_set`) relationship pair to add. #' #' @keywords internal join_pair <- function(join_keys_obj, join_key_obj) { checkmate::assert_class(join_keys_obj, c("JoinKeys", "list")) - checkmate::assert_class(join_key_obj, "JoinKeySet") + checkmate::assert_class(join_key_obj, "join_key_set") dataset_1 <- get_dataset_1(join_key_obj) dataset_2 <- get_dataset_2(join_key_obj) diff --git a/R/teal_data.R b/R/teal_data.R index 5d73a624a..3cc5329ab 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -6,7 +6,7 @@ #' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`, `any`)\cr #' Either 1) an object of a `Teal*` class, which is deprecated and will be removed in next release, #' or 2) any number of any objects provided as `name = value` pairs, which is available from version `0.4.0`. -#' @param join_keys (`JoinKeys`) or a single (`JoinKeySet`)\cr +#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr #' (optional) object with dataset column relationships used for joining. #' If empty then no joins between pairs of objects #' @param code (`character`, `language`) code to reproduce the datasets. @@ -28,7 +28,7 @@ teal_data <- function(..., code = character(0), check = FALSE) { data_objects <- rlang::list2(...) - if (inherits(join_keys, "JoinKeySet")) { + if (inherits(join_keys, "join_key_set")) { join_keys <- teal.data::join_keys(join_keys) } if ( diff --git a/man/TealData.Rd b/man/TealData.Rd index c3470d74d..6d30a8384 100644 --- a/man/TealData.Rd +++ b/man/TealData.Rd @@ -110,7 +110,7 @@ objects} \item{\code{check}}{(\code{logical}) reproducibility check - whether evaluated preprocessing code gives the same objects as provided in arguments. Check is run only if flag is true and preprocessing code is not empty.} -\item{\code{join_keys}}{(\code{JoinKeys}) or a single (\code{JoinKeySet})\cr +\item{\code{join_keys}}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr (optional) object with dataset column relationships used for joining. If empty then an empty \code{JoinKeys} object is passed by default.} } diff --git a/man/cdisc_data.Rd b/man/cdisc_data.Rd index eea0b46b5..673fd8fdc 100644 --- a/man/cdisc_data.Rd +++ b/man/cdisc_data.Rd @@ -16,7 +16,7 @@ cdisc_data( Either 1) an object of a \verb{Teal*} class, which is deprecated and will be removed in next release, or 2) any number of any objects provided as \code{name = value} pairs, which is available from version \verb{0.4.0}.} -\item{join_keys}{(\code{JoinKeys}) or a single (\code{JoinKeySet})\cr +\item{join_keys}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr (optional) object with datasets column names used for joining. If empty then it would be automatically derived basing on intersection of datasets primary keys. For ADAM datasets it would be automatically derived.} diff --git a/man/get_dataset_1.Rd b/man/get_dataset_1.Rd index 4cd68c19c..aa7d87d6a 100644 --- a/man/get_dataset_1.Rd +++ b/man/get_dataset_1.Rd @@ -3,22 +3,22 @@ \name{get_dataset_1} \alias{get_dataset_1} \alias{get_dataset_2} -\alias{get_keys.JoinKeySet} -\title{Getter for attributes in \code{JoinKeySet} object} +\alias{get_keys.join_key_set} +\title{Getter for attributes in \code{join_key_set} object} \usage{ get_dataset_1(join_key_set_object) get_dataset_2(join_key_set_object) -\method{get_keys}{JoinKeySet}(join_key_set_object) +\method{get_keys}{join_key_set}(join_key_set_object) } \arguments{ -\item{join_key_set_object}{(\code{JoinKeySet}) object to retrieve attribute from.} +\item{join_key_set_object}{(\code{join_key_set}) object to retrieve attribute from.} } \value{ \code{dataset_1}, \code{dataset_2} or \code{key} as \code{character(1)} } \description{ -Internal methods for \code{JoinKeySet} operations +Internal methods for \code{join_key_set} operations } \keyword{internal} diff --git a/man/join_key.Rd b/man/join_key.Rd index a1f34111e..72ecd0426 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -18,7 +18,7 @@ If \code{names(keys)} is \code{NULL} then the same column names are used for bot and \code{dataset_2}.} } \value{ -object of class \code{JoinKeySet} to be passed into \code{join_keys} function. +object of class \code{join_key_set} to be passed into \code{join_keys} function. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 953241d4f..4dffed71b 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -14,7 +14,7 @@ \alias{[<-.JoinKeys} \alias{[[.JoinKeys} \alias{[[<-.JoinKeys} -\title{Create a \code{JoinKeys} out of a list of \code{JoinKeySet} objects} +\title{Create a \code{JoinKeys} out of a list of \code{join_key_set} objects} \usage{ cdisc_join_keys(...) @@ -43,11 +43,11 @@ join_keys(join_keys_obj) <- value \method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value } \arguments{ -\item{...}{(optional), additional \code{JoinKeySet} objects when \code{x} is a \code{JoinKeySet}. +\item{...}{(optional), additional \code{join_key_set} objects when \code{x} is a \code{join_key_set}. If argument types are mixed the call will fail.} \item{x}{(optional), when no argument is given the empty constructor is called. -Otherwise, it can be one of: \code{JoinKeys}, \code{teal_data} or \code{JoinKeySet}.} +Otherwise, it can be one of: \code{JoinKeys}, \code{teal_data} or \code{join_key_set}.} \item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} @@ -73,7 +73,7 @@ set the default join keys for CDISC datasets. empty constructor. \item \code{join_keys(x)}: When called with a single argument it will return the \code{JoinKeys} object contained in \code{x} (if it contains a \code{JoinKeys} object). -\item \code{join_keys(...)}: When called with a single or more \code{JoinKeySet} parameters it will +\item \code{join_keys(...)}: When called with a single or more \code{join_key_set} parameters it will create a new object. } diff --git a/man/join_pair.Rd b/man/join_pair.Rd index b4bbc8996..410efe431 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -9,7 +9,7 @@ join_pair(join_keys_obj, join_key_obj) \arguments{ \item{join_keys_obj}{(\code{JoinKeys}) Object with existing pairs.} -\item{join_key_obj}{(\code{JoinKeySet}) relationship pair to add.} +\item{join_key_obj}{(\code{join_key_set}) relationship pair to add.} } \description{ Helper function to add a new pair to a \code{JoinKeys} object diff --git a/man/teal_data.Rd b/man/teal_data.Rd index 5b556fe54..403baa4e2 100644 --- a/man/teal_data.Rd +++ b/man/teal_data.Rd @@ -16,7 +16,7 @@ teal_data( Either 1) an object of a \verb{Teal*} class, which is deprecated and will be removed in next release, or 2) any number of any objects provided as \code{name = value} pairs, which is available from version \verb{0.4.0}.} -\item{join_keys}{(\code{JoinKeys}) or a single (\code{JoinKeySet})\cr +\item{join_keys}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr (optional) object with dataset column relationships used for joining. If empty then no joins between pairs of objects} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 092637138..faeb3190a 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -32,7 +32,7 @@ test_that("join_keys<-.JoinKeys shared test to getter and setter", { helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) -test_that("join_keys<-.JoinKeys to set via a JoinKeySet object", { +test_that("join_keys<-.JoinKeys to set via a join_key_set object", { obj <- join_keys() join_keys(obj) <- join_key("ds1", "ds2", "id") expect_equal(obj$ds1, list("ds2" = c("id" = "id"))) From 003467b042dd1eb31711009c975057d0e37181e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 14:31:13 +0100 Subject: [PATCH 048/152] pr: rename JoinKeys class to join_keys --- NAMESPACE | 20 ++-- R/TealData.R | 8 +- R/cdisc_data.R | 2 +- R/get_join_keys.R | 2 +- R/join_keys.R | 108 +++++++++--------- R/parents.R | 14 +-- R/teal_data-class.R | 10 +- R/teal_data.R | 4 +- _pkgdown.yml | 2 +- inst/WORDLIST | 42 +++++-- man/TealData.Rd | 4 +- man/assert_join_keys_alike.Rd | 4 +- man/assert_parent_child.Rd | 2 +- man/cdisc_data.Rd | 2 +- man/get_join_keys.Rd | 4 +- man/join_keys.Rd | 42 +++---- man/join_pair.Rd | 6 +- man/merge_join_keys.Rd | 14 +-- man/mutate_join_keys.Rd | 14 +-- man/new_join_keys.Rd | 2 +- man/new_teal_data.Rd | 2 +- man/parent.Rd | 2 +- man/parents.Rd | 14 +-- man/{print.JoinKeys.Rd => print.join_keys.Rd} | 10 +- man/teal_data-class.Rd | 2 +- man/teal_data.Rd | 2 +- man/update_join_keys_to_primary.Rd | 2 +- man/update_keys_given_parents.Rd | 2 +- tests/testthat/helper-get_join_keys.R | 18 +-- tests/testthat/test-TealData.R | 2 +- tests/testthat/test-join_keys.R | 98 ++++++++-------- tests/testthat/test-parents.R | 4 +- tests/testthat/test-teal_data.R | 4 +- 33 files changed, 248 insertions(+), 220 deletions(-) rename man/{print.JoinKeys.Rd => print.join_keys.Rd} (66%) diff --git a/NAMESPACE b/NAMESPACE index 754f07fd6..c343488fc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,12 +1,12 @@ # Generated by roxygen2: do not edit by hand -S3method("[",JoinKeys) -S3method("[<-",JoinKeys) -S3method("[[",JoinKeys) -S3method("[[<-",JoinKeys) -S3method("join_keys<-",JoinKeys) +S3method("[",join_keys) +S3method("[<-",join_keys) +S3method("[[",join_keys) +S3method("[[<-",join_keys) +S3method("join_keys<-",join_keys) S3method("join_keys<-",teal_data) -S3method("parents<-",JoinKeys) +S3method("parents<-",join_keys) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(dataset,MultiAssayExperiment) @@ -40,9 +40,9 @@ S3method(get_raw_data,TealDatasetConnector) S3method(is_pulled,TealDataAbstract) S3method(is_pulled,TealDataset) S3method(is_pulled,TealDatasetConnector) -S3method(join_keys,JoinKeys) S3method(join_keys,TealData) S3method(join_keys,default) +S3method(join_keys,join_keys) S3method(join_keys,teal_data) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) @@ -54,10 +54,10 @@ S3method(mutate_data,TealDataAbstract) S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) -S3method(mutate_join_keys,JoinKeys) +S3method(mutate_join_keys,join_keys) S3method(mutate_join_keys,teal_data) -S3method(parents,JoinKeys) -S3method(print,JoinKeys) +S3method(parents,join_keys) +S3method(print,join_keys) S3method(set_args,CallableCode) S3method(set_args,CallableFunction) S3method(set_args,TealDatasetConnector) diff --git a/R/TealData.R b/R/TealData.R index 2a687accc..918e3c21d 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -8,9 +8,9 @@ #' #' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`)\cr #' objects -#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr +#' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr #' (optional) object with dataset column relationships used for joining. -#' If empty then an empty `JoinKeys` object is passed by default. +#' If empty then an empty `join_keys` object is passed by default. #' @param check (`logical`) reproducibility check - whether evaluated preprocessing code gives the same objects #' as provided in arguments. Check is run only if flag is true and preprocessing code is not empty. #' @@ -61,7 +61,7 @@ TealData <- R6::R6Class( # nolint #' @description #' Create a new object of `TealData` class initialize = function(..., check = FALSE, join_keys = teal.data::join_keys()) { - checkmate::assert_class(join_keys, "JoinKeys") + checkmate::assert_class(join_keys, "join_keys") dot_args <- list(...) is_teal_data <- checkmate::test_list( @@ -315,7 +315,7 @@ TealData <- R6::R6Class( # nolint dataname <- get_dataname(dataset) dataset_colnames <- dataset$get_colnames() - # expected columns in this dataset from JoinKeys specification + # expected columns in this dataset from join_keys specification join_key_cols <- unique(unlist(lapply(self$get_join_keys(dataname), names))) if (!is.null(join_key_cols) && !all(join_key_cols %in% dataset_colnames)) { stop( diff --git a/R/cdisc_data.R b/R/cdisc_data.R index 133b56ca8..2ac7f7fe4 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -5,7 +5,7 @@ #' for given datasets whose names match ADAM datasets names. #' #' @inheritParams teal_data -#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr +#' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr #' (optional) object with datasets column names used for joining. #' If empty then it would be automatically derived basing on intersection of datasets primary keys. #' For ADAM datasets it would be automatically derived. diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 6390f59d0..c8e2b3342 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -1,6 +1,6 @@ #' Function to get join keys from a `` object #' @param data `` - object to extract the join keys -#' @return Either `JoinKeys` object or `NULL` if no join keys +#' @return Either `join_keys` object or `NULL` if no join keys #' @export get_join_keys <- function(data) { lifecycle::deprecate_stop( diff --git a/R/join_keys.R b/R/join_keys.R index 2d77cb95e..06aef1378 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,13 +1,13 @@ # Constructors ==== -#' Create a `JoinKeys` out of a list of `join_key_set` objects +#' Create a `join_keys` out of a list of `join_key_set` objects #' #' @description `r lifecycle::badge("stable")` #' #' @details - `join_keys()`: When called without arguments it will return an #' empty constructor. -#' - `join_keys(x)`: When called with a single argument it will return the `JoinKeys` -#' object contained in `x` (if it contains a `JoinKeys` object). +#' - `join_keys(x)`: When called with a single argument it will return the `join_keys` +#' object contained in `x` (if it contains a `join_keys` object). #' - `join_keys(...)`: When called with a single or more `join_key_set` parameters it will #' create a new object. #' @@ -16,11 +16,11 @@ #' `dat2 → dat1`. The only exception is for a primary key. #' #' @param x (optional), when no argument is given the empty constructor is called. -#' Otherwise, it can be one of: `JoinKeys`, `teal_data` or `join_key_set`. +#' Otherwise, it can be one of: `join_keys`, `teal_data` or `join_key_set`. #' @param ... (optional), additional `join_key_set` objects when `x` is a `join_key_set`. #' If argument types are mixed the call will fail. #' -#' @return `JoinKeys` object. +#' @return `join_keys` object. #' #' @export #' @@ -57,7 +57,7 @@ join_keys <- function(x = NULL, ...) { #' @rdname join_keys #' @export -join_keys.JoinKeys <- function(x, ...) { +join_keys.join_keys <- function(x, ...) { if (missing(...)) { return(x) } @@ -101,9 +101,9 @@ join_keys.default <- function(x, ...) { #' The setter assignment `join_keys(obj) <- ...` will merge obj and `...` if obj #' is not empty. #' -#' @param join_keys_obj (`JoinKeys`) empty object to set the new relationship pairs. +#' @param join_keys_obj (`join_keys`) empty object to set the new relationship pairs. #' @param value (`join_key_set` or list of `join_key_set`) relationship pairs to add -#' to `JoinKeys` list. +#' to `join_keys` list. #' #' @export `join_keys<-` <- function(join_keys_obj, value) { @@ -121,18 +121,18 @@ join_keys.default <- function(x, ...) { #' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") #' join_keys(jk)["ds1", "ds3"] <- "some_col3" #' jk -`join_keys<-.JoinKeys` <- function(join_keys_obj, value) { +`join_keys<-.join_keys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } # Assume assignment of join keys as a merge operation # Needed to support join_keys(jk)[ds1, ds2] <- "key" - if (checkmate::test_class(value, classes = c("JoinKeys", "list"))) { + if (checkmate::test_class(value, classes = c("join_keys", "list"))) { return(merge_join_keys(join_keys_obj, value)) } - # Assignment of list of join_key_set will merge it with existing JoinKeys + # Assignment of list of join_key_set will merge it with existing join_keys if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "join_key_set", min.len = 1)) { jk <- new_join_keys() join_keys(jk) <- value @@ -151,7 +151,7 @@ join_keys.default <- function(x, ...) { join_keys_obj <- join_pair(join_keys_obj, value[[idx_1]]) } - logger::log_trace("JoinKeys keys are set.") + logger::log_trace("join_keys keys are set.") join_keys_obj } @@ -160,7 +160,7 @@ join_keys.default <- function(x, ...) { #' @export #' @examples #' -#' # Setter for JoinKeys within teal_data ---- +#' # Setter for join_keys within teal_data ---- #' #' td <- teal_data() #' join_keys(td)["ds1", "ds2"] <- "key1" @@ -172,7 +172,7 @@ join_keys.default <- function(x, ...) { return(join_keys_obj) } - if (checkmate::test_class(value, c("JoinKeys", "list"))) { + if (checkmate::test_class(value, c("join_keys", "list"))) { join_keys_obj@join_keys <- merge_join_keys(join_keys_obj@join_keys, value) return(join_keys_obj) } @@ -183,9 +183,9 @@ join_keys.default <- function(x, ...) { #' @rdname join_keys #' @details -#' Getter for `JoinKeys` that returns the relationship between pairs of datasets. +#' Getter for `join_keys` that returns the relationship between pairs of datasets. #' -#' @param join_keys_obj (`JoinKeys`) object to extract the join keys +#' @param join_keys_obj (`join_keys`) object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. #' @param dataset_2 (`character`) name of second dataset. #' @@ -193,7 +193,7 @@ join_keys.default <- function(x, ...) { #' #' @examples #' -#' # Getter for JoinKeys ---- +#' # Getter for join_keys ---- #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") @@ -204,7 +204,7 @@ join_keys.default <- function(x, ...) { #' #' # Double subscript #' jk["ds1", "ds2"] -`[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { +`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL if (missing(dataset_2)) dataset_2 <- NULL @@ -213,7 +213,7 @@ join_keys.default <- function(x, ...) { (length(dataset_1) >= 2 && is.null(dataset_2)) ) { res <- NextMethod("[", join_keys_obj) - class(res) <- c("JoinKeys", "list") + class(res) <- c("join_keys", "list") return(res) } else if (length(dataset_1) >= 2) { res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) @@ -225,11 +225,11 @@ join_keys.default <- function(x, ...) { return(join_keys_obj) } else if (is.null(dataset_1)) { res <- join_keys_obj[dataset_2] - class(res) <- c("JoinKeys", "list") + class(res) <- c("join_keys", "list") return(res) } else if (is.null(dataset_2)) { res <- NextMethod("[", join_keys_obj) - class(res) <- c("JoinKeys", "list") + class(res) <- c("join_keys", "list") return(res) } result <- join_keys_obj[[dataset_1]][[dataset_2]] @@ -261,15 +261,15 @@ join_keys.default <- function(x, ...) { #' # Creates primary key by only defining `dataset_1` #' jk["ds1"] <- "primary_key" #' jk -`[<-.JoinKeys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { +`[<-.join_keys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { if (checkmate::test_integerish(dataset_1)) { stop(paste( - "Assigment via index number is not supported with JoinKeys object,", + "Assigment via index number is not supported with `join_keys` object,", "please use a dataset name as index and one at a time." )) } else if (length(dataset_1) > 1) { stop(paste( - "Assigment of multiple JoinKeys at the same time is not supported,", + "Assigment of multiple `join_keys` at the same time is not supported,", "please only assign one pair at a time." )) } @@ -285,7 +285,7 @@ join_keys.default <- function(x, ...) { #' jk <- join_keys(join_key("ds1", "ds2", "key")) #' jk[["ds1"]] #' jk[["ds1", "ds2"]] -`[[.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { +`[[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { if (!is.null(dataset_1) && !is.null(dataset_2)) { return(join_keys_obj[[dataset_1]][[dataset_2]]) } @@ -307,7 +307,7 @@ join_keys.default <- function(x, ...) { #' jk[["ds4"]] <- list(ds5 = "new") #' jk[["ds6", "ds7"]] <- "yada" #' jk[["ds8", "ds9"]] <- c(A = "B", "C") -`[[<-.JoinKeys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { +`[[<-.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2, null.ok = TRUE) @@ -362,17 +362,17 @@ join_keys.default <- function(x, ...) { join_keys_obj } -#' Mutate `JoinKeys` with a new values +#' Mutate `join_keys` with a new values #' #' @description `r lifecycle::badge("experimental")` -#' Mutate `JoinKeys` with a new values +#' Mutate `join_keys` with a new values #' -#' @param x (`JoinKeys`) object to be modified +#' @param x (`join_keys`) object to be modified #' @param dataset_1 (`character`) one dataset name #' @param dataset_2 (`character`) other dataset name #' @param value (named `character`) column names used to join #' -#' @return modified `JoinKeys` object +#' @return modified `join_keys` object #' #' @export mutate_join_keys <- function(x, dataset_1, dataset_2, value) { @@ -383,12 +383,12 @@ mutate_join_keys <- function(x, dataset_1, dataset_2, value) { #' @export #' @examples #' -#' # JoinKeys ---- +#' # join_keys ---- #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") #' mutate_join_keys(jk, "ds2", "ds3", "another") -mutate_join_keys.JoinKeys <- function(x, dataset_1, dataset_2, value) { +mutate_join_keys.join_keys <- function(x, dataset_1, dataset_2, value) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) checkmate::assert_character(value, any.missing = FALSE) @@ -429,60 +429,60 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { merge_join_keys(join_keys(join_keys_obj), new_join_keys) } -#' Merging a list (or one) of `JoinKeys` objects into the current `JoinKeys` object +#' Merging a list (or one) of `join_keys` objects into the current `join_keys` object #' #' @rdname merge_join_keys #' -#' @param join_keys_obj (`JoinKeys`) object to merge the new_join_keys. -#' @param new_join_keys `list` of `JoinKeys` objects or single `JoinKeys` object +#' @param join_keys_obj (`join_keys`) object to merge the new_join_keys. +#' @param new_join_keys `list` of `join_keys` objects or single `join_keys` object #' -#' @return a new `JoinKeys` object with the resulting merge. +#' @return a new `join_keys` object with the resulting merge. #' #' @keywords internal -merge_join_keys.JoinKeys <- function(join_keys_obj, new_join_keys) { - checkmate::assert_class(join_keys_obj, classes = c("JoinKeys", "list")) +merge_join_keys.join_keys <- function(join_keys_obj, new_join_keys) { + checkmate::assert_class(join_keys_obj, classes = c("join_keys", "list")) - if (checkmate::test_class(new_join_keys, classes = c("JoinKeys", "list"))) { + if (checkmate::test_class(new_join_keys, classes = c("join_keys", "list"))) { new_join_keys <- list(new_join_keys) } lapply(new_join_keys, assert_join_keys_alike) - checkmate::assert_list(new_join_keys, types = c("JoinKeys"), min.len = 1) + checkmate::assert_list(new_join_keys, types = c("join_keys"), min.len = 1) for (el in new_join_keys) { join_keys_obj <- utils::modifyList(join_keys_obj, el) } - logger::log_trace("JoinKeys keys merged.") + logger::log_trace("join_keys keys merged.") return(join_keys_obj) } # S3 methods have to be exported, otherwise `.S3method` needs to be used .S3method("merge_join_keys", "teal_data", merge_join_keys.default) -.S3method("merge_join_keys", "JoinKeys", merge_join_keys.JoinKeys) +.S3method("merge_join_keys", "join_keys", merge_join_keys.join_keys) -#' Prints `JoinKeys`. +#' Prints `join_keys`. #' #' @inheritParams base::print #' @return the `x` parameter #' #' @export -print.JoinKeys <- function(x, ...) { +print.join_keys <- function(x, ...) { check_ellipsis(...) keys_list <- x my_parents <- parents(keys_list) class(keys_list) <- "list" if (length(keys_list) > 0) { cat(sprintf( - "A JoinKeys object containing foreign keys between %s datasets:\n", + "A join_keys object containing foreign keys between %s datasets:\n", length(keys_list) )) # Hide parents attr(keys_list, "__parents__") <- NULL # nolint: object_name_linter print.default(keys_list[sort(names(keys_list))]) } else { - cat("An empty JoinKeys object.") + cat("An empty join_keys object.") } invisible(x) } @@ -495,24 +495,24 @@ print.JoinKeys <- function(x, ...) { #' Internal constructor #' -#' @return an empty `JoinKeys` list +#' @return an empty `join_keys` list #' #' @keywords internal new_join_keys <- function() { structure( list(), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) } -#' Helper function to add a new pair to a `JoinKeys` object +#' Helper function to add a new pair to a `join_keys` object #' -#' @param join_keys_obj (`JoinKeys`) Object with existing pairs. +#' @param join_keys_obj (`join_keys`) Object with existing pairs. #' @param join_key_obj (`join_key_set`) relationship pair to add. #' #' @keywords internal join_pair <- function(join_keys_obj, join_key_obj) { - checkmate::assert_class(join_keys_obj, c("JoinKeys", "list")) + checkmate::assert_class(join_keys_obj, c("join_keys", "list")) checkmate::assert_class(join_key_obj, "join_key_set") dataset_1 <- get_dataset_1(join_key_obj) @@ -523,7 +523,7 @@ join_pair <- function(join_keys_obj, join_key_obj) { join_keys_obj } -#' Assert the `JoinKeys` class membership of an argument +#' Assert the `join_keys` class membership of an argument #' @inheritParams checkmate::assert_class #' #' @return `x` invisibly @@ -615,7 +615,7 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { #' Helper function checks the parent-child relations are valid #' -#' @param join_keys_obj (`JoinKeys`) object to assert validity of relations +#' @param join_keys_obj (`join_keys`) object to assert validity of relations #' #' @return `join_keys_obj` invisibly #' @@ -624,7 +624,7 @@ assert_parent_child <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) jk_parents <- parents(jk) - checkmate::assert_class(jk, c("JoinKeys", "list")) + checkmate::assert_class(jk, c("join_keys", "list")) if (!is.null(jk_parents)) { for (idx1 in seq_along(jk_parents)) { diff --git a/R/parents.R b/R/parents.R index 13a45bed0..87fd458d9 100644 --- a/R/parents.R +++ b/R/parents.R @@ -1,6 +1,6 @@ #' Getter and setter for specific parent #' -#' @param join_keys_obj (`JoinKeys`) object to retrieve. +#' @param join_keys_obj (`join_keys`) object to retrieve. #' @param dataset_name (`character(1)`) #' #' @export @@ -19,9 +19,9 @@ parent <- function(join_keys_obj, dataset_name) { parents(join_keys_obj)[[dataset_name]] } -#' Getter and setter functions for parents attribute of `JoinKeys` +#' Getter and setter functions for parents attribute of `join_keys` #' -#' @param join_keys_obj (`JoinKeys`) object to retrieve or manipulate. +#' @param join_keys_obj (`join_keys`) object to retrieve or manipulate. #' @return a list of `character` representing the parents. #' #' @export @@ -34,7 +34,7 @@ parents <- function(join_keys_obj) { #' @examples #' jk <- join_keys() #' parents(jk) -parents.JoinKeys <- function(join_keys_obj) { +parents.join_keys <- function(join_keys_obj) { attr(join_keys_obj, "__parents__") %||% list() } @@ -58,7 +58,7 @@ parents.JoinKeys <- function(join_keys_obj) { #' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") #' parents(jk)["ds5"] <- "ds6" #' parents(jk)["ds6"] <- "ds7" -`parents<-.JoinKeys` <- function(join_keys_obj, value) { +`parents<-.join_keys` <- function(join_keys_obj, value) { if (missing(value)) { return(join_keys_obj) } @@ -86,7 +86,7 @@ parents.JoinKeys <- function(join_keys_obj) { #' Updates the keys of the datasets based on the parents. #' -#' @param join_keys_obj (`JoinKeys`) object to update the keys. +#' @param join_keys_obj (`join_keys`) object to update the keys. #' #' @return (`self`) invisibly for chaining #' @@ -107,7 +107,7 @@ parents.JoinKeys <- function(join_keys_obj) { update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) - checkmate::assert_class(jk, "JoinKeys", .var.name = checkmate::vname(join_keys_obj)) + checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(join_keys_obj)) datanames <- names(jk) duplicate_pairs <- list() diff --git a/R/teal_data-class.R b/R/teal_data-class.R index ae7b1e637..3ce3b4652 100644 --- a/R/teal_data-class.R +++ b/R/teal_data-class.R @@ -1,4 +1,4 @@ -setOldClass("JoinKeys") +setOldClass("join_keys") #' Reproducible data. #' @@ -25,7 +25,7 @@ setOldClass("JoinKeys") #' @slot warnings (`character`) warnings raised when evaluating code. #' Access with [get_warnings()]. #' @slot messages (`character`) messages raised when evaluating code. -#' @slot join_keys (`JoinKeys`) object specifying joining keys for data sets in `@env`. +#' @slot join_keys (`join_keys`) object specifying joining keys for data sets in `@env`. #' Access or modify with [join_keys()]. #' @slot datanames (`character`) vector of names of data sets in `@env`. #' Used internally to distinguish them from auxiliary variables. @@ -36,7 +36,7 @@ setOldClass("JoinKeys") setClass( Class = "teal_data", contains = "qenv", - slots = c(join_keys = "JoinKeys", datanames = "character"), + slots = c(join_keys = "join_keys", datanames = "character"), prototype = list( join_keys = join_keys(), datanames = character(0) @@ -51,7 +51,7 @@ setClass( #' @param data (`named list`) List of data. #' @param code (`character` or `language`) code to reproduce the `data`. #' Accepts and stores comments also. -#' @param join_keys (`JoinKeys`) object +#' @param join_keys (`join_keys`) object #' @param datanames (`character`) names of datasets passed to `data`. #' Needed when non-dataset objects are needed in the `env` slot. #' @rdname new_teal_data @@ -61,7 +61,7 @@ new_teal_data <- function(data, join_keys = join_keys(), datanames = union(names(data), names(join_keys))) { checkmate::assert_list(data) - checkmate::assert_class(join_keys, "JoinKeys") + checkmate::assert_class(join_keys, "join_keys") if (is.null(datanames)) datanames <- character(0) # todo: allow to specify checkmate::assert_character(datanames) if (!any(is.language(code), is.character(code))) { diff --git a/R/teal_data.R b/R/teal_data.R index 3cc5329ab..a0ac7961b 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -6,7 +6,7 @@ #' @param ... (`TealDataConnector`, `TealDataset`, `TealDatasetConnector`, `any`)\cr #' Either 1) an object of a `Teal*` class, which is deprecated and will be removed in next release, #' or 2) any number of any objects provided as `name = value` pairs, which is available from version `0.4.0`. -#' @param join_keys (`JoinKeys`) or a single (`join_key_set`)\cr +#' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr #' (optional) object with dataset column relationships used for joining. #' If empty then no joins between pairs of objects #' @param code (`character`, `language`) code to reproduce the datasets. @@ -110,7 +110,7 @@ teal_data_file <- function(path, code = get_code(path)) { #' Add primary keys as join_keys to a dataset self #' #' @param data_objects (`list`) of `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects -#' @param join_keys (`JoinKeys`) object +#' @param join_keys (`join_keys`) object #' #' @keywords internal update_join_keys_to_primary <- function(data_objects, join_keys) { diff --git a/_pkgdown.yml b/_pkgdown.yml index 77b06a17a..929a5877e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -126,7 +126,7 @@ reference: - parent - parents - parents<- - - print.JoinKeys + - print.join_keys - python_code - read_script - update_keys_given_parents diff --git a/inst/WORDLIST b/inst/WORDLIST index 063052f75..c734b019a 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,16 +1,44 @@ +args +attrs +CallableCode +CallablePythonCode CDISC -Forkers -Getter -Hoffmann -Pre -Reproducibility -SCDA -UI +cdisc +CDISCTealDataConnector +CDISCTealDataset +CDISCTealDatasetConnector cloneable +csv +dataname +datanames +desc +Forkers formatters funder +Getter getter +github +Hoffmann +href +https +insightsengineering +io iteratively +mae +MAETealDataset +navbar +nesttemplate +Pre pre +PythonCodeClass +rds repo +Reproducibility reproducibility +SCDA +TealData +TealDataConnection +TealDataConnector +TealDataset +TealDatasetConnector +UI diff --git a/man/TealData.Rd b/man/TealData.Rd index 6d30a8384..57ac7e07c 100644 --- a/man/TealData.Rd +++ b/man/TealData.Rd @@ -110,9 +110,9 @@ objects} \item{\code{check}}{(\code{logical}) reproducibility check - whether evaluated preprocessing code gives the same objects as provided in arguments. Check is run only if flag is true and preprocessing code is not empty.} -\item{\code{join_keys}}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr +\item{\code{join_keys}}{(\code{join_keys}) or a single (\code{join_key_set})\cr (optional) object with dataset column relationships used for joining. -If empty then an empty \code{JoinKeys} object is passed by default.} +If empty then an empty \code{join_keys} object is passed by default.} } \if{html}{\out{}} } diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd index 39aa848aa..86c8535cb 100644 --- a/man/assert_join_keys_alike.Rd +++ b/man/assert_join_keys_alike.Rd @@ -3,7 +3,7 @@ \name{assert_join_keys_alike} \alias{assert_join_keys_alike} \alias{check_join_keys_alike} -\title{Assert the \code{JoinKeys} class membership of an argument} +\title{Assert the \code{join_keys} class membership of an argument} \usage{ assert_join_keys_alike(x, .var.name = checkmate::vname(x), add = NULL) @@ -24,6 +24,6 @@ Collection to store assertion messages. See \code{\link[checkmate]{AssertCollect \code{x} invisibly } \description{ -Assert the \code{JoinKeys} class membership of an argument +Assert the \code{join_keys} class membership of an argument } \keyword{internal} diff --git a/man/assert_parent_child.Rd b/man/assert_parent_child.Rd index d69d824aa..f4c103ee6 100644 --- a/man/assert_parent_child.Rd +++ b/man/assert_parent_child.Rd @@ -7,7 +7,7 @@ assert_parent_child(join_keys_obj) } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to assert validity of relations} +\item{join_keys_obj}{(\code{join_keys}) object to assert validity of relations} } \value{ \code{join_keys_obj} invisibly diff --git a/man/cdisc_data.Rd b/man/cdisc_data.Rd index 673fd8fdc..061f737c3 100644 --- a/man/cdisc_data.Rd +++ b/man/cdisc_data.Rd @@ -16,7 +16,7 @@ cdisc_data( Either 1) an object of a \verb{Teal*} class, which is deprecated and will be removed in next release, or 2) any number of any objects provided as \code{name = value} pairs, which is available from version \verb{0.4.0}.} -\item{join_keys}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr +\item{join_keys}{(\code{join_keys}) or a single (\code{join_key_set})\cr (optional) object with datasets column names used for joining. If empty then it would be automatically derived basing on intersection of datasets primary keys. For ADAM datasets it would be automatically derived.} diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 2b643dd87..6fd4df3e9 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -12,7 +12,7 @@ get_join_keys(x, dataset_1, dataset_2 = NULL) <- value \arguments{ \item{data}{`` - object to extract the join keys} -\item{x}{(\code{JoinKeys}) object to be modified} +\item{x}{(\code{join_keys}) object to be modified} \item{dataset_1}{(\code{character}) one dataset name} @@ -21,7 +21,7 @@ get_join_keys(x, dataset_1, dataset_2 = NULL) <- value \item{value}{value to assign} } \value{ -Either \code{JoinKeys} object or \code{NULL} if no join keys +Either \code{join_keys} object or \code{NULL} if no join keys } \description{ Function to get join keys from a `` object diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 4dffed71b..9b8516687 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -3,24 +3,24 @@ \name{cdisc_join_keys} \alias{cdisc_join_keys} \alias{join_keys} -\alias{join_keys.JoinKeys} +\alias{join_keys.join_keys} \alias{join_keys.teal_data} \alias{join_keys.TealData} \alias{join_keys.default} \alias{join_keys<-} -\alias{join_keys<-.JoinKeys} +\alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} -\alias{[.JoinKeys} -\alias{[<-.JoinKeys} -\alias{[[.JoinKeys} -\alias{[[<-.JoinKeys} -\title{Create a \code{JoinKeys} out of a list of \code{join_key_set} objects} +\alias{[.join_keys} +\alias{[<-.join_keys} +\alias{[[.join_keys} +\alias{[[<-.join_keys} +\title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} \usage{ cdisc_join_keys(...) join_keys(x = NULL, ...) -\method{join_keys}{JoinKeys}(x, ...) +\method{join_keys}{join_keys}(x, ...) \method{join_keys}{teal_data}(x, ...) @@ -30,26 +30,26 @@ join_keys(x = NULL, ...) join_keys(join_keys_obj) <- value -\method{join_keys}{JoinKeys}(join_keys_obj) <- value +\method{join_keys}{join_keys}(join_keys_obj) <- value \method{join_keys}{teal_data}(join_keys_obj) <- value -\method{[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) +\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) -\method{[}{JoinKeys}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value +\method{[}{join_keys}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value -\method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) +\method{[[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) -\method{[[}{JoinKeys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value +\method{[[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value } \arguments{ \item{...}{(optional), additional \code{join_key_set} objects when \code{x} is a \code{join_key_set}. If argument types are mixed the call will fail.} \item{x}{(optional), when no argument is given the empty constructor is called. -Otherwise, it can be one of: \code{JoinKeys}, \code{teal_data} or \code{join_key_set}.} +Otherwise, it can be one of: \code{join_keys}, \code{teal_data} or \code{join_key_set}.} -\item{join_keys_obj}{(\code{JoinKeys}) object to extract the join keys} +\item{join_keys_obj}{(\code{join_keys}) object to extract the join keys} \item{value}{(\code{character} vector) value to assign.} @@ -58,7 +58,7 @@ Otherwise, it can be one of: \code{JoinKeys}, \code{teal_data} or \code{join_key \item{dataset_2}{(\code{character}) name of second dataset.} } \value{ -\code{JoinKeys} object. +\code{join_keys} object. } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} @@ -71,8 +71,8 @@ set the default join keys for CDISC datasets. \itemize{ \item \code{join_keys()}: When called without arguments it will return an empty constructor. -\item \code{join_keys(x)}: When called with a single argument it will return the \code{JoinKeys} -object contained in \code{x} (if it contains a \code{JoinKeys} object). +\item \code{join_keys(x)}: When called with a single argument it will return the \code{join_keys} +object contained in \code{x} (if it contains a \code{join_keys} object). \item \code{join_keys(...)}: When called with a single or more \code{join_key_set} parameters it will create a new object. } @@ -84,7 +84,7 @@ have a join key of \code{col1}, then 2 join keys are created, \verb{dat1 → dat The setter assignment \code{join_keys(obj) <- ...} will merge obj and \code{...} if obj is not empty. -Getter for \code{JoinKeys} that returns the relationship between pairs of datasets. +Getter for \code{join_keys} that returns the relationship between pairs of datasets. Setter via index directly (bypassing the need to use \code{join_key()}). When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. @@ -126,7 +126,7 @@ join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" jk -# Setter for JoinKeys within teal_data ---- +# Setter for join_keys within teal_data ---- td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" @@ -134,7 +134,7 @@ join_keys(td)["ds2", "ds2"] <- "key2" join_keys(td) <- join_keys(join_key("ds3", "ds2", "key3")) join_keys(td) -# Getter for JoinKeys ---- +# Getter for join_keys ---- jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") diff --git a/man/join_pair.Rd b/man/join_pair.Rd index 410efe431..5366f412a 100644 --- a/man/join_pair.Rd +++ b/man/join_pair.Rd @@ -2,16 +2,16 @@ % Please edit documentation in R/join_keys.R \name{join_pair} \alias{join_pair} -\title{Helper function to add a new pair to a \code{JoinKeys} object} +\title{Helper function to add a new pair to a \code{join_keys} object} \usage{ join_pair(join_keys_obj, join_key_obj) } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) Object with existing pairs.} +\item{join_keys_obj}{(\code{join_keys}) Object with existing pairs.} \item{join_key_obj}{(\code{join_key_set}) relationship pair to add.} } \description{ -Helper function to add a new pair to a \code{JoinKeys} object +Helper function to add a new pair to a \code{join_keys} object } \keyword{internal} diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd index e6cbdbe0c..aa920b11f 100644 --- a/man/merge_join_keys.Rd +++ b/man/merge_join_keys.Rd @@ -3,24 +3,24 @@ \name{merge_join_keys} \alias{merge_join_keys} \alias{merge_join_keys.default} -\alias{merge_join_keys.JoinKeys} -\title{Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object} +\alias{merge_join_keys.join_keys} +\title{Merging a list (or one) of \code{join_keys} objects into the current \code{join_keys} object} \usage{ merge_join_keys(join_keys_obj, new_join_keys) \method{merge_join_keys}{default}(join_keys_obj, new_join_keys) -\method{merge_join_keys}{JoinKeys}(join_keys_obj, new_join_keys) +\method{merge_join_keys}{join_keys}(join_keys_obj, new_join_keys) } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to merge the new_join_keys.} +\item{join_keys_obj}{(\code{join_keys}) object to merge the new_join_keys.} -\item{new_join_keys}{\code{list} of \code{JoinKeys} objects or single \code{JoinKeys} object} +\item{new_join_keys}{\code{list} of \code{join_keys} objects or single \code{join_keys} object} } \value{ -a new \code{JoinKeys} object with the resulting merge. +a new \code{join_keys} object with the resulting merge. } \description{ -Merging a list (or one) of \code{JoinKeys} objects into the current \code{JoinKeys} object +Merging a list (or one) of \code{join_keys} objects into the current \code{join_keys} object } \keyword{internal} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd index 5f13ad0a5..b5c582726 100644 --- a/man/mutate_join_keys.Rd +++ b/man/mutate_join_keys.Rd @@ -2,18 +2,18 @@ % Please edit documentation in R/join_keys.R \name{mutate_join_keys} \alias{mutate_join_keys} -\alias{mutate_join_keys.JoinKeys} +\alias{mutate_join_keys.join_keys} \alias{mutate_join_keys.teal_data} -\title{Mutate \code{JoinKeys} with a new values} +\title{Mutate \code{join_keys} with a new values} \usage{ mutate_join_keys(x, dataset_1, dataset_2, value) -\method{mutate_join_keys}{JoinKeys}(x, dataset_1, dataset_2, value) +\method{mutate_join_keys}{join_keys}(x, dataset_1, dataset_2, value) \method{mutate_join_keys}{teal_data}(x, dataset_1, dataset_2, value) } \arguments{ -\item{x}{(\code{JoinKeys}) object to be modified} +\item{x}{(\code{join_keys}) object to be modified} \item{dataset_1}{(\code{character}) one dataset name} @@ -22,15 +22,15 @@ mutate_join_keys(x, dataset_1, dataset_2, value) \item{value}{(named \code{character}) column names used to join} } \value{ -modified \code{JoinKeys} object +modified \code{join_keys} object } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -Mutate \code{JoinKeys} with a new values +Mutate \code{join_keys} with a new values } \examples{ -# JoinKeys ---- +# join_keys ---- jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") diff --git a/man/new_join_keys.Rd b/man/new_join_keys.Rd index 4d8317b19..093f9eb34 100644 --- a/man/new_join_keys.Rd +++ b/man/new_join_keys.Rd @@ -7,7 +7,7 @@ new_join_keys() } \value{ -an empty \code{JoinKeys} list +an empty \code{join_keys} list } \description{ Internal constructor diff --git a/man/new_teal_data.Rd b/man/new_teal_data.Rd index 675802af5..5b1557ec2 100644 --- a/man/new_teal_data.Rd +++ b/man/new_teal_data.Rd @@ -17,7 +17,7 @@ new_teal_data( \item{code}{(\code{character} or \code{language}) code to reproduce the \code{data}. Accepts and stores comments also.} -\item{join_keys}{(\code{JoinKeys}) object} +\item{join_keys}{(\code{join_keys}) object} \item{datanames}{(\code{character}) names of datasets passed to \code{data}. Needed when non-dataset objects are needed in the \code{env} slot.} diff --git a/man/parent.Rd b/man/parent.Rd index fbfd33146..106728cb5 100644 --- a/man/parent.Rd +++ b/man/parent.Rd @@ -7,7 +7,7 @@ parent(join_keys_obj, dataset_name) } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to retrieve.} +\item{join_keys_obj}{(\code{join_keys}) object to retrieve.} \item{dataset_name}{(\code{character(1)})} } diff --git a/man/parents.Rd b/man/parents.Rd index 0f1446842..11c8af424 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -2,21 +2,21 @@ % Please edit documentation in R/parents.R \name{parents} \alias{parents} -\alias{parents.JoinKeys} +\alias{parents.join_keys} \alias{parents<-} -\alias{parents<-.JoinKeys} -\title{Getter and setter functions for parents attribute of \code{JoinKeys}} +\alias{parents<-.join_keys} +\title{Getter and setter functions for parents attribute of \code{join_keys}} \usage{ parents(join_keys_obj) -\method{parents}{JoinKeys}(join_keys_obj) +\method{parents}{join_keys}(join_keys_obj) parents(join_keys_obj) <- value -\method{parents}{JoinKeys}(join_keys_obj) <- value +\method{parents}{join_keys}(join_keys_obj) <- value } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to retrieve or manipulate.} +\item{join_keys_obj}{(\code{join_keys}) object to retrieve or manipulate.} \item{value}{(\code{list}) named list of character values} } @@ -24,7 +24,7 @@ parents(join_keys_obj) <- value a list of \code{character} representing the parents. } \description{ -Getter and setter functions for parents attribute of \code{JoinKeys} +Getter and setter functions for parents attribute of \code{join_keys} } \examples{ jk <- join_keys() diff --git a/man/print.JoinKeys.Rd b/man/print.join_keys.Rd similarity index 66% rename from man/print.JoinKeys.Rd rename to man/print.join_keys.Rd index 2be9c997e..0c30b5850 100644 --- a/man/print.JoinKeys.Rd +++ b/man/print.join_keys.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_keys.R -\name{print.JoinKeys} -\alias{print.JoinKeys} -\title{Prints \code{JoinKeys}.} +\name{print.join_keys} +\alias{print.join_keys} +\title{Prints \code{join_keys}.} \usage{ -\method{print}{JoinKeys}(x, ...) +\method{print}{join_keys}(x, ...) } \arguments{ \item{x}{an object used to select a method.} @@ -15,5 +15,5 @@ the \code{x} parameter } \description{ -Prints \code{JoinKeys}. +Prints \code{join_keys}. } diff --git a/man/teal_data-class.Rd b/man/teal_data-class.Rd index 3a56da95d..d6101689e 100644 --- a/man/teal_data-class.Rd +++ b/man/teal_data-class.Rd @@ -35,7 +35,7 @@ Access with \code{\link[=get_warnings]{get_warnings()}}.} \item{\code{messages}}{(\code{character}) messages raised when evaluating code.} -\item{\code{join_keys}}{(\code{JoinKeys}) object specifying joining keys for data sets in \verb{@env}. +\item{\code{join_keys}}{(\code{join_keys}) object specifying joining keys for data sets in \verb{@env}. Access or modify with \code{\link[=join_keys]{join_keys()}}.} \item{\code{datanames}}{(\code{character}) vector of names of data sets in \verb{@env}. diff --git a/man/teal_data.Rd b/man/teal_data.Rd index 403baa4e2..dbb065aed 100644 --- a/man/teal_data.Rd +++ b/man/teal_data.Rd @@ -16,7 +16,7 @@ teal_data( Either 1) an object of a \verb{Teal*} class, which is deprecated and will be removed in next release, or 2) any number of any objects provided as \code{name = value} pairs, which is available from version \verb{0.4.0}.} -\item{join_keys}{(\code{JoinKeys}) or a single (\code{join_key_set})\cr +\item{join_keys}{(\code{join_keys}) or a single (\code{join_key_set})\cr (optional) object with dataset column relationships used for joining. If empty then no joins between pairs of objects} diff --git a/man/update_join_keys_to_primary.Rd b/man/update_join_keys_to_primary.Rd index b6e977ce9..2102fd5d3 100644 --- a/man/update_join_keys_to_primary.Rd +++ b/man/update_join_keys_to_primary.Rd @@ -9,7 +9,7 @@ update_join_keys_to_primary(data_objects, join_keys) \arguments{ \item{data_objects}{(\code{list}) of \code{TealDataset}, \code{TealDatasetConnector} or \code{TealDataConnector} objects} -\item{join_keys}{(\code{JoinKeys}) object} +\item{join_keys}{(\code{join_keys}) object} } \description{ Add primary keys as join_keys to a dataset self diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index c56597583..1ce619617 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -7,7 +7,7 @@ update_keys_given_parents(join_keys_obj) } \arguments{ -\item{join_keys_obj}{(\code{JoinKeys}) object to update the keys.} +\item{join_keys_obj}{(\code{join_keys}) object to update the keys.} } \value{ (\code{self}) invisibly for chaining diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index 56387ff5e..ee6231469 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -1,4 +1,4 @@ -#' Generate a teal_data dataset with sample data and JoinKeys +#' Generate a teal_data dataset with sample data and join_keys helper_generator_teal_data <- function() { iris2 <- iris iris2$id <- rnorm(NROW(iris2)) @@ -9,12 +9,12 @@ helper_generator_teal_data <- function() { ds2 = iris2 ), code = "ds1 <- iris2; ds2 <- iris2", - join_keys = helper_generator_JoinKeys("ds1", keys = c("id")) + join_keys = helper_generator_join_keys("ds1", keys = c("id")) ) } -#' Generate a JoinKeys -helper_generator_JoinKeys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint +#' Generate a join_keys +helper_generator_join_keys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint join_keys( join_key(dataset_1, keys = keys) ) @@ -24,14 +24,14 @@ helper_generator_JoinKeys <- function(dataset_1 = "ds1", keys = c("id")) { # nol helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { jk <- join_keys(obj) - expect_s3_class(jk, class = c("JoinKeys", "list")) + expect_s3_class(jk, class = c("join_keys", "list")) expect_length(jk, 1) expect_length(jk[dataset_1, dataset_1], 1) obj } -#' Test suite for JoinKeys after manual adding a primary key +#' Test suite for join_keys after manual adding a primary key helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter dataset_1 = "ds1", new_dataset_1 = "ds2", @@ -41,13 +41,13 @@ helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter jk <- join_keys(obj) - expect_s3_class(jk, class = c("JoinKeys", "list")) + expect_s3_class(jk, class = c("join_keys", "list")) expect_length(jk, 2) expect_length(jk[dataset_1, dataset_1], 1) expect_length(jk[new_dataset_1, new_dataset_1], 1) } -#' Test suite for JoinKeys after manual adding a primary key +#' Test suite for join_keys after manual adding a primary key helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length_linter obj <- helper_test_getter_join_keys(obj, "ds1") @@ -126,7 +126,7 @@ helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length join_key(.ds(), .ds(), character(0)) ) - expect_s3_class(join_keys(obj), class = c("JoinKeys", "list")) + expect_s3_class(join_keys(obj), class = c("join_keys", "list")) expected_length <- 68 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` expect_length(join_keys(obj), expected_length) diff --git a/tests/testthat/test-TealData.R b/tests/testthat/test-TealData.R index e512dc407..00c728c41 100644 --- a/tests/testthat/test-TealData.R +++ b/tests/testthat/test-TealData.R @@ -256,7 +256,7 @@ testthat::test_that("TealData$get_parents returns an empty list even when parent testthat::expect_equal(data$get_parents(), list()) }) -testthat::test_that("TealData$mutate_join_keys returns a JoinKeys object with the updated join_keys", { +testthat::test_that("TealData$mutate_join_keys returns a join_keys object with the updated join_keys", { df1 <- data.frame(id = c("A", "B"), a = c(1L, 2L)) df2 <- data.frame(df2_id = c("A", "B"), id = c("A", "B"), b = c(1L, 2L)) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index faeb3190a..f37c5dfcb 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -5,8 +5,8 @@ test_that("join_keys.teal_data will successfully obtain object from teal_data", helper_test_getter_join_keys(obj, "ds1") }) -test_that("join_keys.JoinKeys will return itself", { - obj <- helper_generator_JoinKeys() +test_that("join_keys.join_keys will return itself", { + obj <- helper_generator_join_keys() expect_identical(obj, join_keys(obj)) helper_test_getter_join_keys(obj, "ds1") @@ -17,8 +17,8 @@ test_that("join_keys<-.teal_data shared test to setter (in mass)", { helper_test_setter_mass_join_keys_add(obj) }) -test_that("join_keys<-.JoinKeys shared test to setter (in mass)", { - obj <- helper_generator_JoinKeys() +test_that("join_keys<-.join_keys shared test to setter (in mass)", { + obj <- helper_generator_join_keys() helper_test_setter_mass_join_keys_add(obj) }) @@ -27,19 +27,19 @@ test_that("join_keys<-.teal_data shared test to getter and setter", { helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) -test_that("join_keys<-.JoinKeys shared test to getter and setter", { - obj <- helper_generator_JoinKeys() +test_that("join_keys<-.join_keys shared test to getter and setter", { + obj <- helper_generator_join_keys() helper_test_getter_join_keys_add(obj, "ds1", "ds2") }) -test_that("join_keys<-.JoinKeys to set via a join_key_set object", { +test_that("join_keys<-.join_keys to set via a join_key_set object", { obj <- join_keys() join_keys(obj) <- join_key("ds1", "ds2", "id") expect_equal(obj$ds1, list("ds2" = c("id" = "id"))) expect_equal(obj$ds2, list("ds1" = c("id" = "id"))) }) -test_that("join_keys<-.JoinKeys to set via multiple lists that progressively merge object", { +test_that("join_keys<-.join_keys to set via multiple lists that progressively merge object", { obj <- join_keys() join_keys(obj) <- list(join_key("ds1", "ds2", "id")) join_keys(obj) <- list(join_key("ds3", "ds4", "id_id")) @@ -52,7 +52,7 @@ test_that("join_keys<-.JoinKeys to set via multiple lists that progressively mer # # [[ and [[<- # -test_that("[[<-.JoinKeys creates symmetric relationship", { +test_that("[[<-.join_keys creates symmetric relationship", { jk <- join_keys() jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") @@ -64,12 +64,12 @@ test_that("[[<-.JoinKeys creates symmetric relationship", { d1 = list(d2 = c("A" = "B", "C" = "C")), d2 = list(d1 = c("B" = "A", "C" = "C")) ), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) }) -test_that("[[<-.JoinKeys is equivalent to using the constructor (double subscript)", { +test_that("[[<-.join_keys is equivalent to using the constructor (double subscript)", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), join_key("d3", "d4", c("D", "E")), @@ -85,7 +85,7 @@ test_that("[[<-.JoinKeys is equivalent to using the constructor (double subscrip expect_identical(jk, jk2) }) -test_that("[[<-.JoinKeys is equivalent to using the constructor (single subscript)", { +test_that("[[<-.join_keys is equivalent to using the constructor (single subscript)", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C" = "C")), join_key("d3", "d4", c("D", "E")), @@ -101,7 +101,7 @@ test_that("[[<-.JoinKeys is equivalent to using the constructor (single subscrip expect_identical(jk, jk2) }) -test_that("[<-.JoinKeys is equivalent to using the constructor (double subscript)", { +test_that("[<-.join_keys is equivalent to using the constructor (double subscript)", { jk <- join_keys( join_key("d1", "d2", c("A", "B")), join_key("d3", "d4", c("C", "D")), @@ -117,7 +117,7 @@ test_that("[<-.JoinKeys is equivalent to using the constructor (double subscript expect_identical(jk, jk2) }) -test_that("[.JoinKeys can subscript multiple values by index or name", { +test_that("[.join_keys can subscript multiple values by index or name", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), join_key("d3", "d4", c("D", "E")), @@ -131,15 +131,15 @@ test_that("[.JoinKeys can subscript multiple values by index or name", { jk[c("d1", "d5")], structure( list(d1 = jk[["d1"]], d5 = jk[["d5"]]), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) - expect_identical(jk[2], structure(list(d2 = jk[["d2"]]), class = c("JoinKeys", "list"))) - expect_identical(jk[c(1, 3)], structure(list(d1 = jk[["d1"]], d3 = jk[["d3"]]), class = c("JoinKeys", "list"))) + expect_identical(jk[2], structure(list(d2 = jk[["d2"]]), class = c("join_keys", "list"))) + expect_identical(jk[c(1, 3)], structure(list(d1 = jk[["d1"]], d3 = jk[["d3"]]), class = c("join_keys", "list"))) }) -test_that("[<-.JoinKeys cannot subscript multiple values", { +test_that("[<-.join_keys cannot subscript multiple values", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), join_key("d3", "d4", c("D", "E")), @@ -171,7 +171,7 @@ test_that("mutate_join_keys with empty name is changed to the key value", { expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) }) -test_that("[<-.JoinKeys with empty name is changed to the key value", { +test_that("[<-.join_keys with empty name is changed to the key value", { # set empty key name jk <- join_keys() jk["d1", "d2"] <- c("A" = "B", "C") @@ -188,7 +188,7 @@ test_that("[<-.JoinKeys with empty name is changed to the key value", { expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) }) -test_that("join_keys()[]<-.JoinKeys with empty name is changed to the key value", { +test_that("join_keys()[]<-.join_keys with empty name is changed to the key value", { # set empty key name jk <- join_keys() join_keys(jk)["d1", "d2"] <- c("A" = "B", "C") @@ -234,7 +234,7 @@ test_that("join_keys constructor creates symmetric relationship", { d1 = list(d2 = c("A" = "B", "C" = "C")), d2 = list(d1 = c("B" = "A", "C" = "C")) ), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) }) @@ -327,7 +327,7 @@ test_that("join_keys can create join_keys with compatible information", { ) }) -test_that("join_keys cannot create JoinKeys with invalid arguments", { +test_that("join_keys cannot create join_keys with invalid arguments", { # not using join_key expect_error(join_keys("d1", "d2", "A")) # key sets with the same pair of datasets but different values @@ -335,7 +335,7 @@ test_that("join_keys cannot create JoinKeys with invalid arguments", { expect_error(join_keys(join_key("d1", "d2", c("A" = "X")), join_key("d2", "d1", c("A" = "X")))) }) -test_that("join_keys can create JoinKeys with valid arguments", { +test_that("join_keys can create join_keys with valid arguments", { # no keys expect_silent(join_keys()) # list of keys @@ -362,26 +362,26 @@ test_that("join_keys[ can get all keys for a given dataset", { my_keys[dataset_1 = "d1"], structure( list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) expect_equal( my_keys[dataset_2 = "d1"], structure( list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) expect_equal( my_keys[dataset_1 = "d3"], structure( list("d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) }) -test_that("join_keys can get all keys from JoinKeys", { +test_that("join_keys can get all keys from join_keys", { my_keys <- join_keys( join_key("d1", "d2", c("A" = "C")), join_key("d1", "d3", c("A" = "B", "S" = "T")), @@ -394,13 +394,13 @@ test_that("join_keys can get all keys from JoinKeys", { my_keys[dataset_1 = "d1"], structure( list(d1 = all_keys[["d1"]]), - class = c("JoinKeys", "list") + class = c("join_keys", "list") ) ) }) test_that( - "join_keys join_key with unamed keys vector creates a JoinKeys with the same column names for both datasets ", + "join_keys join_key with unamed keys vector creates a join_keys with the same column names for both datasets ", { test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) @@ -417,19 +417,19 @@ test_that("join_keys if no keys between pair of datasets then getting them retur # # mutate_join_keys -test_that("mutate_join_keys.JoinKeys can mutate existing keys", { +test_that("mutate_join_keys.join_keys can mutate existing keys", { my_keys <- join_keys(join_key("d1", "d2", "A")) new_keys <- mutate_join_keys(my_keys, "d1", "d2", c("X" = "Y")) expect_equal(new_keys["d1", "d2"], c("X" = "Y")) }) -test_that("mutate_join_keys.JoinKeys mutating non-existing keys adds them", { +test_that("mutate_join_keys.join_keys mutating non-existing keys adds them", { my_keys <- join_keys(join_key("d1", "d2", "A")) new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) expect_equal(new_keys["d3", "d2"], c("Y" = "X")) }) -test_that("mutate_join_keys.JoinKeys can remove keys by setting them to character(0)", { +test_that("mutate_join_keys.join_keys can remove keys by setting them to character(0)", { my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) expect_equal(new_keys["d1", "d2"], character(0)) @@ -514,7 +514,7 @@ testthat::test_that( } ) -testthat::test_that("merge_join_keys does nothing when argument is a JoinKeys object with identical data", { +testthat::test_that("merge_join_keys does nothing when argument is a join_keys object with identical data", { x <- join_keys() y <- join_keys() join_keys(x) <- list( @@ -532,7 +532,7 @@ testthat::test_that("merge_join_keys does nothing when argument is a JoinKeys ob testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object with identical data", { +testthat::test_that("merge_join_keys does nothing when argument is a list of one join_keys object with identical data", { x <- join_keys() y <- join_keys() @@ -556,7 +556,7 @@ testthat::test_that("merge_join_keys does nothing when argument is a list of one }) testthat::test_that( - "merge_join_keys does nothing when argument is a list of many JoinKeys object with identical data", + "merge_join_keys does nothing when argument is a list of many join_keys object with identical data", { x <- join_keys() y <- join_keys() @@ -578,7 +578,7 @@ testthat::test_that( } ) -testthat::test_that("merge_join_keys clones data when argument is a list of one JoinKeys object that is a superset", { +testthat::test_that("merge_join_keys clones data when argument is a list of one join_keys object that is a superset", { x <- join_keys() y <- join_keys() @@ -600,7 +600,7 @@ testthat::test_that("merge_join_keys clones data when argument is a list of one testthat::expect_identical(join_keys(x), join_keys(y)) }) -testthat::test_that("merge_join_keys does nothing when argument is a list of one JoinKeys object that is a subset", { +testthat::test_that("merge_join_keys does nothing when argument is a list of one join_keys object that is a subset", { x <- join_keys() y <- join_keys() @@ -654,26 +654,26 @@ testthat::test_that("merge_join_keys merges mutually exclusive data", { # ----------------------------------------------------------------------------- # -# print.JoinKeys +# print.join_keys -testthat::test_that("print.JoinKeys for empty set", { +testthat::test_that("print.join_keys for empty set", { jk <- join_keys() testthat::expect_output( print(jk), - "An empty JoinKeys object." + "An empty join_keys object." ) }) -testthat::test_that("print.JoinKeys for a non-empty set", { +testthat::test_that("print.join_keys for a non-empty set", { jk <- join_keys() join_keys(jk) <- list(join_key("DF1", "DF2", c("id" = "fk"))) testthat::expect_output( print(jk), - "A JoinKeys object containing foreign keys between 2 datasets:" + "A join_keys object containing foreign keys between 2 datasets:" ) }) -testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they are empty", { +testthat::test_that("parents<- sets the parents of datasets when they are empty", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df2", c("id" = "fk"))) testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) @@ -687,7 +687,7 @@ testthat::test_that("JoinKeys$set_parents sets the parents of datasets when they # # cdisc_join_keys -test_that("cdisc_join_keys will generate JoinKeys for named list with non-named elements", { +test_that("cdisc_join_keys will generate join_keys for named list with non-named elements", { new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) jk <- join_keys(new_dataset) @@ -698,7 +698,7 @@ test_that("cdisc_join_keys will generate JoinKeys for named list with non-named expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) }) -test_that("cdisc_join_keys will generate JoinKeys for character list", { +test_that("cdisc_join_keys will generate join_keys for character list", { new_dataset <- cdisc_join_keys("ADSL", "ADTTE") jk <- join_keys(new_dataset) @@ -709,7 +709,7 @@ test_that("cdisc_join_keys will generate JoinKeys for character list", { expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) }) -test_that("cdisc_join_keys will generate JoinKeys for named list", { +test_that("cdisc_join_keys will generate join_keys for named list", { new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) jk <- join_keys(new_dataset) @@ -777,9 +777,9 @@ test_that("cdisc_join_keys does nothing with TealDataset", { # ----------------------------------------------------------------------------- # -# Subset-JoinKeys +# Subset-join_keys -test_that("[<-.JoinKeys assigns new relationship pair", { +test_that("[<-.join_keys assigns new relationship pair", { jk <- join_keys(join_key("ds1", keys = c("id"))) expect_length(jk["ds1", "ds2"], 0) @@ -789,7 +789,7 @@ test_that("[<-.JoinKeys assigns new relationship pair", { expect_identical(jk[["ds1"]][["ds2"]], jk["ds1", "ds2"]) }) -test_that("[<-.JoinKeys modifies existing relationship pair", { +test_that("[<-.join_keys modifies existing relationship pair", { jk <- join_keys(join_key("ds1", keys = c("id"))) jk["ds1", "ds1"] <- c("Species") diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 0805bff9a..0309dfc85 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -73,7 +73,7 @@ test_that("assert_parent_child will detect invalid key pairs", { expect_error(assert_parent_child(jk2)) }) -test_that("assert_parent_child will skip empty JoinKeys", { +test_that("assert_parent_child will skip empty join_keys", { jk <- join_keys() expect_silent(assert_parent_child(jk)) }) @@ -189,7 +189,7 @@ testthat::test_that("assert_parent_child throws error if no join_keys exist for join_keys(jk) <- list( join_key("df1", "df1", c("id" = "id")) ) - # Change class as trick to allow for corrupt JoinKeys + # Change class as trick to allow for corrupt join_keys class(jk) <- "list" jk[["df2"]][["df1"]] <- "id" class(jk) <- class(new_join_keys()) diff --git a/tests/testthat/test-teal_data.R b/tests/testthat/test-teal_data.R index baf821340..7fa114620 100644 --- a/tests/testthat/test-teal_data.R +++ b/tests/testthat/test-teal_data.R @@ -149,7 +149,7 @@ testthat::test_that("teal_data sets passed join_keys to datasets correctly", { testthat::expect_equal(join_keys(data), jk_expected) }) -testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when key names differ", { +testthat::test_that("teal_data sets passed join_keys to datasets correctly when key names differ", { df1 <- data.frame(id = c("A", "B"), a = c(1L, 2L)) df2 <- data.frame(df2_id = c("A", "B"), fk = c("A", "B"), b = c(1L, 2L)) df1 <- dataset("df1", df1, keys = "id") @@ -168,7 +168,7 @@ testthat::test_that("teal_data sets passed JoinKeys to datasets correctly when k testthat::expect_equal(join_keys(data), jk_expected) }) -testthat::test_that("teal_data sets passes JoinKeys to datasets correctly when key names differ (multiple keys)", { +testthat::test_that("teal_data sets passes join_keys to datasets correctly when key names differ (multiple keys)", { df1 <- data.frame(id = c("A", "B"), id2 = c("A", "B"), a = c(1L, 2L)) df2 <- data.frame(df2_id = c("A", "B"), fk = c("A", "B"), fk2 = c("A", "B"), b = c(1L, 2L)) df1 <- dataset("df1", df1, keys = "id") From d9834c8293fc996159f35cc0ce22da00f6fcb47b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 14:34:10 +0100 Subject: [PATCH 049/152] docs: update news with class rename --- NEWS.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 20517b37c..fb6b33d80 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,13 +2,15 @@ ### Enhancements * Simplified `join_key` to better support primary keys. -* `JoinKey` `R6` object was removed in favor of a list-like object. Subset operators and assignments are supported (`[`, `[[`, `[<-` and `[[<-`) +* `JoinKey` `R6` object was removed in favor of a list-like object with class name `join_keys`. Subset operators and assignments are supported (`[`, `[[`, `[<-` and `[[<-`) * `join_keys` function works as a constructor, getter and setter. ### Breaking changes * Introduced new data class (`teal_data`) which replaces deprecated `TealData`. New data class becomes a standard input for whole `teal` framework. * Deprecated `teal_data` constructor when `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects are provided. New delayed data loading functions introduced in `teal` package. +* `JoinKeySet` class was renamed to `join_key_set`. +* `JoinKeys` class was renamed to `join_keys` ### Miscellaneous * Specified minimal version of package dependencies. From 0e5ca24fe8865f430eedb044d3e57440ae871241 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 15:18:55 +0100 Subject: [PATCH 050/152] pr: reducing wordlist --- inst/WORDLIST | 42 +++++++----------------------------------- 1 file changed, 7 insertions(+), 35 deletions(-) diff --git a/inst/WORDLIST b/inst/WORDLIST index c734b019a..063052f75 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,44 +1,16 @@ -args -attrs -CallableCode -CallablePythonCode CDISC -cdisc -CDISCTealDataConnector -CDISCTealDataset -CDISCTealDatasetConnector -cloneable -csv -dataname -datanames -desc Forkers +Getter +Hoffmann +Pre +Reproducibility +SCDA +UI +cloneable formatters funder -Getter getter -github -Hoffmann -href -https -insightsengineering -io iteratively -mae -MAETealDataset -navbar -nesttemplate -Pre pre -PythonCodeClass -rds repo -Reproducibility reproducibility -SCDA -TealData -TealDataConnection -TealDataConnector -TealDataset -TealDatasetConnector -UI From 25deae7fae123d3eaae09ba27a87597bd7213784 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 15:51:19 +0100 Subject: [PATCH 051/152] adds c method and improves on join_keys getter --- NAMESPACE | 1 + R/join_keys.R | 58 ++++++++++++++++++++++++++++++++++-------------- man/join_keys.Rd | 13 +++++++---- 3 files changed, 51 insertions(+), 21 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c343488fc..4e76150ce 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,6 +9,7 @@ S3method("join_keys<-",teal_data) S3method("parents<-",join_keys) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) +S3method(c,join_keys) S3method(dataset,MultiAssayExperiment) S3method(dataset,data.frame) S3method(get_attrs,TealDataset) diff --git a/R/join_keys.R b/R/join_keys.R index 06aef1378..71a50bf34 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -48,44 +48,48 @@ #' jk <- join_keys() #' jk <- join_keys(join_key("a", "b", "c")) #' jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) -join_keys <- function(x = NULL, ...) { - if (is.null(x)) { +join_keys <- function(...) { + if (missing(...) || length(x) == 0) { return(new_join_keys()) } - UseMethod("join_keys", x) + x <- rlang::list2(...) + UseMethod("join_keys", x[[1]]) } #' @rdname join_keys #' @export -join_keys.join_keys <- function(x, ...) { - if (missing(...)) { - return(x) +join_keys.join_keys <- function(...) { + if (length(...) > 1) { + return(join_keys.default(...)) } - join_keys.default(x, ...) + x <- rlang::list2(...) + x[[1]] } #' @rdname join_keys #' @export -join_keys.teal_data <- function(x, ...) { - if (missing(...)) { - return(x@join_keys) +join_keys.teal_data <- function(...) { + if (length(...) > 1) { + return(join_keys.default(...)) } - join_keys.default(x, ...) + x <- rlang::list2(...) + x[[1]]@join_keys } #' @rdname join_keys #' @export -join_keys.TealData <- function(x, ...) { - if (missing(...)) { - return(x$get_join_keys()) +join_keys.TealData <- function(...) { + x <- rlang::list2(...) + if (length(...) > 1) { + return(join_keys.default(...)) } - join_keys.default(x, ...) + x[[1]]$get_join_keys() } #' @rdname join_keys #' @export -join_keys.default <- function(x, ...) { - x <- append(list(x), rlang::list2(...)) +join_keys.default <- function(...) { + x <- rlang::list2(...) # Constructor res <- new_join_keys() @@ -156,6 +160,26 @@ join_keys.default <- function(x, ...) { join_keys_obj } +#' @rdname join_keys +#' @export +#' +#' @examples +#' +#' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) +c.join_keys <- function(...) { + x <- rlang::list2(...) + + if (!length(x)) { + return(NULL) + } + checkmate::assert_list(x, types = c("join_keys", "list")) + jk <- x[[1]] + for (ix in seq_along(x[-1])) { + jk <- merge_join_keys.default(jk, x[[ix + 1]]) + } + jk +} + #' @rdname join_keys #' @export #' @examples diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 9b8516687..75fbfdccb 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -9,6 +9,7 @@ \alias{join_keys.default} \alias{join_keys<-} \alias{join_keys<-.join_keys} +\alias{c.join_keys} \alias{join_keys<-.teal_data} \alias{[.join_keys} \alias{[<-.join_keys} @@ -18,13 +19,13 @@ \usage{ cdisc_join_keys(...) -join_keys(x = NULL, ...) +join_keys(...) -\method{join_keys}{join_keys}(x, ...) +\method{join_keys}{join_keys}(...) -\method{join_keys}{teal_data}(x, ...) +\method{join_keys}{teal_data}(...) -\method{join_keys}{TealData}(x, ...) +\method{join_keys}{TealData}(...) \method{join_keys}{default}(x, ...) @@ -32,6 +33,8 @@ join_keys(join_keys_obj) <- value \method{join_keys}{join_keys}(join_keys_obj) <- value +\method{c}{join_keys}(...) + \method{join_keys}{teal_data}(join_keys_obj) <- value \method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) @@ -126,6 +129,8 @@ join_keys(jk) <- join_key("ds3", "ds4", "some_col2") join_keys(jk)["ds1", "ds3"] <- "some_col3" jk +c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) + # Setter for join_keys within teal_data ---- td <- teal_data() From 16cdb9b69f11ef7487df3b81f4aad8df69123204 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Wed, 8 Nov 2023 14:54:36 +0000 Subject: [PATCH 052/152] [skip actions] Roxygen Man Pages Auto Update --- man/join_keys.Rd | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 75fbfdccb..549194787 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -27,7 +27,7 @@ join_keys(...) \method{join_keys}{TealData}(...) -\method{join_keys}{default}(x, ...) +\method{join_keys}{default}(...) join_keys(join_keys_obj) <- value @@ -49,9 +49,6 @@ join_keys(join_keys_obj) <- value \item{...}{(optional), additional \code{join_key_set} objects when \code{x} is a \code{join_key_set}. If argument types are mixed the call will fail.} -\item{x}{(optional), when no argument is given the empty constructor is called. -Otherwise, it can be one of: \code{join_keys}, \code{teal_data} or \code{join_key_set}.} - \item{join_keys_obj}{(\code{join_keys}) object to extract the join keys} \item{value}{(\code{character} vector) value to assign.} @@ -59,6 +56,9 @@ Otherwise, it can be one of: \code{join_keys}, \code{teal_data} or \code{join_ke \item{dataset_1}{(\code{character}) name of first dataset.} \item{dataset_2}{(\code{character}) name of second dataset.} + +\item{x}{(optional), when no argument is given the empty constructor is called. +Otherwise, it can be one of: \code{join_keys}, \code{teal_data} or \code{join_key_set}.} } \value{ \code{join_keys} object. From d1c843ed220c62c111a516bb98cce4c007073c34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 15:59:02 +0100 Subject: [PATCH 053/152] simplifies getter functions --- R/join_keys.R | 15 ++++----------- R/parents.R | 2 +- 2 files changed, 5 insertions(+), 12 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 71a50bf34..617932ec9 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -49,19 +49,19 @@ #' jk <- join_keys(join_key("a", "b", "c")) #' jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) join_keys <- function(...) { - if (missing(...) || length(x) == 0) { + if (missing(...)) { return(new_join_keys()) } x <- rlang::list2(...) + if (length(x) > 1) { + return(join_keys.default(...)) + } UseMethod("join_keys", x[[1]]) } #' @rdname join_keys #' @export join_keys.join_keys <- function(...) { - if (length(...) > 1) { - return(join_keys.default(...)) - } x <- rlang::list2(...) x[[1]] } @@ -69,9 +69,6 @@ join_keys.join_keys <- function(...) { #' @rdname join_keys #' @export join_keys.teal_data <- function(...) { - if (length(...) > 1) { - return(join_keys.default(...)) - } x <- rlang::list2(...) x[[1]]@join_keys } @@ -80,9 +77,6 @@ join_keys.teal_data <- function(...) { #' @export join_keys.TealData <- function(...) { x <- rlang::list2(...) - if (length(...) > 1) { - return(join_keys.default(...)) - } x[[1]]$get_join_keys() } @@ -90,7 +84,6 @@ join_keys.TealData <- function(...) { #' @export join_keys.default <- function(...) { x <- rlang::list2(...) - # Constructor res <- new_join_keys() if (length(x) > 0) { diff --git a/R/parents.R b/R/parents.R index 87fd458d9..9c253c913 100644 --- a/R/parents.R +++ b/R/parents.R @@ -119,7 +119,7 @@ update_keys_given_parents <- function(join_keys_obj) { next } if (length(jk[d1, d2]) == 0) { - d2_parent <- parents(jk)[[d2]] + d2_parent <- parent(jk, d2) d2_pk <- jk[d2, d2] fk <- if (identical(d1, d2_parent)) { From df264e117b4d67b77c6dd8e07af05571de4e0729 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:16:51 +0100 Subject: [PATCH 054/152] fix: corrects linter error --- tests/testthat/test-join_keys.R | 41 ++++++++++++++++++--------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index f37c5dfcb..231971be5 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -532,28 +532,31 @@ testthat::test_that("merge_join_keys does nothing when argument is a join_keys o testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("merge_join_keys does nothing when argument is a list of one join_keys object with identical data", { - x <- join_keys() - y <- join_keys() +testthat::test_that( + "merge_join_keys does nothing when argument is a list of one join_keys object with identical data", + { + x <- join_keys() + y <- join_keys() - join_keys(x) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) + join_keys(x) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) + join_keys(y) <- list( + join_key("A", "B", c("a" = "b")), + join_key("A", "C", c("a" = "c", "aa" = "cc")), + join_key("Z", "Y", c("z" = "y")) + ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x))) - testthat::expect_identical(previous_output, join_keys(y)) + previous_output <- join_keys(y) + testthat::expect_silent(merge_join_keys(y, list(x))) + testthat::expect_identical(previous_output, join_keys(y)) - testthat::expect_silent(merge_join_keys(y, list(x, x))) - testthat::expect_identical(previous_output, join_keys(y)) -}) + testthat::expect_silent(merge_join_keys(y, list(x, x))) + testthat::expect_identical(previous_output, join_keys(y)) + } +) testthat::test_that( "merge_join_keys does nothing when argument is a list of many join_keys object with identical data", From 07b26042b3c33425fdaccdd9d644b9f8a2740406 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 8 Nov 2023 16:25:34 +0100 Subject: [PATCH 055/152] docs: correct documentation --- R/join_keys.R | 9 +++++---- man/join_keys.Rd | 10 +++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 617932ec9..610579ee4 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -15,10 +15,11 @@ #' have a join key of `col1`, then 2 join keys are created, `dat1 → dat2` and #' `dat2 → dat1`. The only exception is for a primary key. #' -#' @param x (optional), when no argument is given the empty constructor is called. -#' Otherwise, it can be one of: `join_keys`, `teal_data` or `join_key_set`. -#' @param ... (optional), additional `join_key_set` objects when `x` is a `join_key_set`. -#' If argument types are mixed the call will fail. +#' @param ... (optional), when no argument is given the empty constructor is called. +#' Otherwise, when called with only one argument of type: `join_keys` or `teal_data` +#' it will return the `join_keys` of that object. +#' When called with 1 or more `join_key_set` it will create a new `join_keys` with +#' constructed from the arguments. #' #' @return `join_keys` object. #' diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 549194787..d4b7ab81e 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -46,8 +46,11 @@ join_keys(join_keys_obj) <- value \method{[[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value } \arguments{ -\item{...}{(optional), additional \code{join_key_set} objects when \code{x} is a \code{join_key_set}. -If argument types are mixed the call will fail.} +\item{...}{(optional), when no argument is given the empty constructor is called. +Otherwise, when called with only one argument of type: \code{join_keys} or \code{teal_data} +it will return the \code{join_keys} of that object. +When called with 1 or more \code{join_key_set} it will create a new \code{join_keys} with +constructed from the arguments.} \item{join_keys_obj}{(\code{join_keys}) object to extract the join keys} @@ -56,9 +59,6 @@ If argument types are mixed the call will fail.} \item{dataset_1}{(\code{character}) name of first dataset.} \item{dataset_2}{(\code{character}) name of second dataset.} - -\item{x}{(optional), when no argument is given the empty constructor is called. -Otherwise, it can be one of: \code{join_keys}, \code{teal_data} or \code{join_key_set}.} } \value{ \code{join_keys} object. From 4c972098039b83c8184aa197a15ab2f9a9c309e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 9 Nov 2023 11:51:41 +0100 Subject: [PATCH 056/152] prevent update_keys_given_parents from being exported --- NAMESPACE | 1 - R/parents.R | 15 --------------- man/update_keys_given_parents.Rd | 13 ------------- 3 files changed, 29 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 4e76150ce..2ad642b4c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -140,7 +140,6 @@ export(set_keys) export(teal_data) export(teal_data_file) export(to_relational_data) -export(update_keys_given_parents) export(validate_metadata) import(shiny) import(teal.code) diff --git a/R/parents.R b/R/parents.R index 9c253c913..d003f2f2c 100644 --- a/R/parents.R +++ b/R/parents.R @@ -89,21 +89,6 @@ parents.join_keys <- function(join_keys_obj) { #' @param join_keys_obj (`join_keys`) object to update the keys. #' #' @return (`self`) invisibly for chaining -#' -#' @export -#' -#' @examples -#' jk <- join_keys() -#' join_keys(jk) <- list( -#' join_key("df1", "df1", c("id", "id2")), -#' join_key("df1", "df2", c("id" = "id")), -#' join_key("df1", "df3", c("id" = "id")) -#' ) -#' parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") -#' jk2 <- update_keys_given_parents(jk) -#' -#' jk[["df2"]] -#' jk2[["df2"]] update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 1ce619617..3ba49bfee 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -15,16 +15,3 @@ update_keys_given_parents(join_keys_obj) \description{ Updates the keys of the datasets based on the parents. } -\examples{ -jk <- join_keys() -join_keys(jk) <- list( - join_key("df1", "df1", c("id", "id2")), - join_key("df1", "df2", c("id" = "id")), - join_key("df1", "df3", c("id" = "id")) -) -parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") -jk2 <- update_keys_given_parents(jk) - -jk[["df2"]] -jk2[["df2"]] -} From 17baef069f20de18b72c2ed1980d300e70c8ca9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 9 Nov 2023 13:50:13 +0100 Subject: [PATCH 057/152] feat: remove `mutate_join_keys` method --- NAMESPACE | 3 -- R/TealData.R | 3 +- R/get_join_keys.R | 2 +- R/join_key.R | 2 +- R/join_keys.R | 62 ++++----------------------------- R/parents.R | 6 ++-- R/teal_data.R | 7 +--- _pkgdown.yml | 1 - man/get_join_keys.Rd | 6 ++-- man/join_key.Rd | 2 +- man/mutate_join_keys.Rd | 52 --------------------------- tests/testthat/test-join_keys.R | 62 ++++++++++++--------------------- 12 files changed, 41 insertions(+), 167 deletions(-) delete mode 100644 man/mutate_join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index 2ad642b4c..8311a36ac 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -55,8 +55,6 @@ S3method(mutate_data,TealDataAbstract) S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) -S3method(mutate_join_keys,join_keys) -S3method(mutate_join_keys,teal_data) S3method(parents,join_keys) S3method(print,join_keys) S3method(set_args,CallableCode) @@ -123,7 +121,6 @@ export(load_datasets) export(mae_dataset) export(mutate_data) export(mutate_dataset) -export(mutate_join_keys) export(parent) export(parents) export(python_cdisc_dataset_connector) diff --git a/R/TealData.R b/R/TealData.R index 918e3c21d..51e07625f 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -298,7 +298,8 @@ TealData <- R6::R6Class( # nolint #' @param val (named `character`) column names used to join #' @return (`self`) invisibly for chaining mutate_join_keys = function(dataset_1, dataset_2, val) { - private$join_keys <- mutate_join_keys(private$join_keys, dataset_1, dataset_2, val) + private$join_keys[[dataset_1]][[dataset_2]] <- val + private$join_keys }, # ___ check ==== diff --git a/R/get_join_keys.R b/R/get_join_keys.R index c8e2b3342..48c161a00 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -11,7 +11,7 @@ get_join_keys <- function(data) { } #' @rdname get_join_keys -#' @inheritParams mutate_join_keys +#' @inheritParams join_keys #' @param value value to assign #' @export `get_join_keys<-` <- function(x, dataset_1, dataset_2 = NULL, value) { diff --git a/R/join_key.R b/R/join_key.R index a5aa61444..687ef69dd 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -5,7 +5,7 @@ #' @details `join_key()` will create a relationship for the variables on a pair #' of datasets. #' -#' @inheritParams mutate_join_keys +#' @inheritParams join_keys #' @param dataset_2 (optional `character`) other dataset name. In case it is omitted, then it #' will create a primary key for `dataset_1`. #' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` diff --git a/R/join_keys.R b/R/join_keys.R index 610579ee4..f576f94e8 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -349,6 +349,13 @@ c.join_keys <- function(...) { # Accepting 1 subscript with valid `value` formal checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) + # Normalize values + norm_value <- lapply(names(value), function(.x) { + get_keys(join_key(dataset_1, .x, value[[.x]])) + }) + names(norm_value) <- names(value) + value <- norm_value + join_keys_obj <- NextMethod("[[<-", join_keys_obj) # Keep original parameters as variables will be overwritten for `NextMethod` call @@ -380,61 +387,6 @@ c.join_keys <- function(...) { join_keys_obj } -#' Mutate `join_keys` with a new values -#' -#' @description `r lifecycle::badge("experimental")` -#' Mutate `join_keys` with a new values -#' -#' @param x (`join_keys`) object to be modified -#' @param dataset_1 (`character`) one dataset name -#' @param dataset_2 (`character`) other dataset name -#' @param value (named `character`) column names used to join -#' -#' @return modified `join_keys` object -#' -#' @export -mutate_join_keys <- function(x, dataset_1, dataset_2, value) { - UseMethod("mutate_join_keys") -} - -#' @rdname mutate_join_keys -#' @export -#' @examples -#' -#' # join_keys ---- -#' -#' jk <- join_keys() -#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") -#' mutate_join_keys(jk, "ds2", "ds3", "another") -mutate_join_keys.join_keys <- function(x, dataset_1, dataset_2, value) { - checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2) - checkmate::assert_character(value, any.missing = FALSE) - join_pair(x, join_key(dataset_1, dataset_2, value)) -} - -#' @rdname mutate_join_keys -#' @export -#' @examples -#' -#' # teal_data ---- -#' -#' ADSL <- teal.data::example_cdisc_data("ADSL") -#' ADRS <- teal.data::example_cdisc_data("ADRS") -#' -#' x <- cdisc_data( -#' "ADSL" = ADSL, -#' "ADRS" = ADRS -#' ) -#' join_keys(x)["ADSL", "ADRS"] -#' -#' join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -#' join_keys(x)["ADSL", "ADRS"] -mutate_join_keys.teal_data <- function(x, dataset_1, dataset_2, value) { # nolint - join_keys(x) <- mutate_join_keys(join_keys(x), dataset_1, dataset_2, value) - join_keys(x) -} - #' @rdname merge_join_keys #' @keywords internal merge_join_keys <- function(join_keys_obj, new_join_keys) { diff --git a/R/parents.R b/R/parents.R index d003f2f2c..b326bb962 100644 --- a/R/parents.R +++ b/R/parents.R @@ -105,7 +105,7 @@ update_keys_given_parents <- function(join_keys_obj) { } if (length(jk[d1, d2]) == 0) { d2_parent <- parent(jk, d2) - d2_pk <- jk[d2, d2] + d2_pk <- jk[[d2]][[d2]] fk <- if (identical(d1, d2_parent)) { # first is parent of second -> parent keys -> first keys @@ -115,12 +115,12 @@ update_keys_given_parents <- function(join_keys_obj) { d2_pk } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { # both has the same parent -> parent keys - jk[d1_parent, d1_parent] + jk[[d1_parent]][[d1_parent]] } else { # cant find connection - leave empty next } - jk <- mutate_join_keys(jk, d1, d2, fk) + jk[[d1]][[d2]] <- fk # mutate join key duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) } } diff --git a/R/teal_data.R b/R/teal_data.R index a0ac7961b..69569741c 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -120,12 +120,7 @@ update_join_keys_to_primary <- function(data_objects, join_keys) { } else { dataname <- obj$get_dataname() if (length(join_keys[dataname, dataname]) == 0) { - join_keys <- mutate_join_keys( - join_keys, - dataname, - dataname, - obj$get_keys() - ) + join_keys[dataname, dataname] <- obj$get_keys() } } } diff --git a/_pkgdown.yml b/_pkgdown.yml index 929a5877e..2cb7c1bb5 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -102,7 +102,6 @@ reference: - load_datasets - mutate_data - mutate_dataset - - mutate_join_keys - set_args - set_keys - title: Helpers diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 6fd4df3e9..d141c9457 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -12,11 +12,9 @@ get_join_keys(x, dataset_1, dataset_2 = NULL) <- value \arguments{ \item{data}{`` - object to extract the join keys} -\item{x}{(\code{join_keys}) object to be modified} +\item{dataset_1}{(\code{character}) name of first dataset.} -\item{dataset_1}{(\code{character}) one dataset name} - -\item{dataset_2}{(\code{character}) other dataset name} +\item{dataset_2}{(\code{character}) name of second dataset.} \item{value}{value to assign} } diff --git a/man/join_key.Rd b/man/join_key.Rd index 72ecd0426..90ed7c3c9 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -7,7 +7,7 @@ join_key(dataset_1, dataset_2 = dataset_1, keys) } \arguments{ -\item{dataset_1}{(\code{character}) one dataset name} +\item{dataset_1}{(\code{character}) name of first dataset.} \item{dataset_2}{(optional \code{character}) other dataset name. In case it is omitted, then it will create a primary key for \code{dataset_1}.} diff --git a/man/mutate_join_keys.Rd b/man/mutate_join_keys.Rd deleted file mode 100644 index b5c582726..000000000 --- a/man/mutate_join_keys.Rd +++ /dev/null @@ -1,52 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{mutate_join_keys} -\alias{mutate_join_keys} -\alias{mutate_join_keys.join_keys} -\alias{mutate_join_keys.teal_data} -\title{Mutate \code{join_keys} with a new values} -\usage{ -mutate_join_keys(x, dataset_1, dataset_2, value) - -\method{mutate_join_keys}{join_keys}(x, dataset_1, dataset_2, value) - -\method{mutate_join_keys}{teal_data}(x, dataset_1, dataset_2, value) -} -\arguments{ -\item{x}{(\code{join_keys}) object to be modified} - -\item{dataset_1}{(\code{character}) one dataset name} - -\item{dataset_2}{(\code{character}) other dataset name} - -\item{value}{(named \code{character}) column names used to join} -} -\value{ -modified \code{join_keys} object -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -Mutate \code{join_keys} with a new values -} -\examples{ - -# join_keys ---- - -jk <- join_keys() -join_keys(jk) <- join_key("ds1", "ds2", "some_col") -mutate_join_keys(jk, "ds2", "ds3", "another") - -# teal_data ---- - -ADSL <- teal.data::example_cdisc_data("ADSL") -ADRS <- teal.data::example_cdisc_data("ADRS") - -x <- cdisc_data( - "ADSL" = ADSL, - "ADRS" = ADRS -) -join_keys(x)["ADSL", "ADRS"] - -join_keys(x) <- mutate_join_keys(x, "ADSL", "ADRS", c("COLUMN1" = "COLUMN2")) -join_keys(x)["ADSL", "ADRS"] -} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 231971be5..6373c8750 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -149,28 +149,34 @@ test_that("[<-.join_keys cannot subscript multiple values", { expect_error(jk[1:2] <- NULL) }) -# ----------------------------------------------------------------------------- -# -# mutate_join_keys (empty value name) -# - -test_that("mutate_join_keys with empty name is changed to the key value", { - # set empty key name - jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "C")) - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) +test_that("[[<- can mutate existing keys", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d1"]][["d2"]] <- c("X" = "Y") + expect_equal(my_keys[["d1"]][["d2"]], c("X" = "Y")) + expect_equal(my_keys[["d2"]][["d1"]], c("Y" = "X")) +}) - # set key on non-empty variable name equal to "" - jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "C" = "")) - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) +test_that("[[<- mutating non-existing keys adds them", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d2"]][["d3"]] <- c("X" = "Y") + expect_equal(my_keys[["d2"]][["d3"]], c("X" = "Y")) + expect_equal(my_keys[["d3"]][["d2"]], c("Y" = "X")) +}) - # set key on empty variable name equal to "" - expect_message( - jk <- mutate_join_keys(join_keys(), "d1", "d2", c("A" = "B", "")), - "are ignored" +test_that("[[<- can remove keys by setting them to character(0)", { + my_keys <- join_keys( + join_key("d1", "d2", "A"), + join_key("d3", "d4", c("A" = "B", "C" = "D")) ) - expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) + my_keys[["d1"]][["d2"]] <- character(0) + expect_equal(my_keys[["d1"]][["d2"]], character(0)) }) +# ----------------------------------------------------------------------------- +# +# mutate_join_keys (empty value name) +# + test_that("[<-.join_keys with empty name is changed to the key value", { # set empty key name jk <- join_keys() @@ -413,28 +419,6 @@ test_that("join_keys if no keys between pair of datasets then getting them retur expect_equal(my_keys["d1", "d4"], character(0)) }) -# ----------------------------------------------------------------------------- -# -# mutate_join_keys - -test_that("mutate_join_keys.join_keys can mutate existing keys", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - new_keys <- mutate_join_keys(my_keys, "d1", "d2", c("X" = "Y")) - expect_equal(new_keys["d1", "d2"], c("X" = "Y")) -}) - -test_that("mutate_join_keys.join_keys mutating non-existing keys adds them", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - new_keys <- mutate_join_keys(my_keys, "d2", "d3", c("X" = "Y")) - expect_equal(new_keys["d3", "d2"], c("Y" = "X")) -}) - -test_that("mutate_join_keys.join_keys can remove keys by setting them to character(0)", { - my_keys <- join_keys(join_key("d1", "d2", "A"), join_key("d3", "d4", c("A" = "B", "C" = "D"))) - new_keys <- mutate_join_keys(my_keys, "d1", "d2", character(0)) - expect_equal(new_keys["d1", "d2"], character(0)) -}) - # ----------------------------------------------------------------------------- # # merge_join_keys From ae267d8017c6bf869cdffe5b62da85deb9550549 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 01:39:45 +0100 Subject: [PATCH 058/152] feat: removes double subscript index and better support for [ operations --- NAMESPACE | 2 +- R/TealData.R | 2 +- R/cdisc_join_keys.R | 6 +- R/get_join_keys.R | 3 +- R/join_keys.R | 261 ++++++++++---------- R/parents.R | 4 +- R/teal_data.R | 12 +- man/get_join_keys.Rd | 4 +- man/join_keys.Rd | 63 +++-- man/join_pair.Rd | 17 -- man/length.join_keys.Rd | 14 ++ man/update_join_keys_to_primary.Rd | 4 +- tests/testthat/helper-get_join_keys.R | 63 +++-- tests/testthat/test-join_keys.R | 333 ++++++++++++-------------- tests/testthat/test-parents.R | 10 +- 15 files changed, 384 insertions(+), 414 deletions(-) delete mode 100644 man/join_pair.Rd create mode 100644 man/length.join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index 8311a36ac..bf59ae1e9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,7 +2,6 @@ S3method("[",join_keys) S3method("[<-",join_keys) -S3method("[[",join_keys) S3method("[[<-",join_keys) S3method("join_keys<-",join_keys) S3method("join_keys<-",teal_data) @@ -45,6 +44,7 @@ S3method(join_keys,TealData) S3method(join_keys,default) S3method(join_keys,join_keys) S3method(join_keys,teal_data) +S3method(length,join_keys) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) S3method(load_datasets,TealData) diff --git a/R/TealData.R b/R/TealData.R index 51e07625f..7beef553d 100644 --- a/R/TealData.R +++ b/R/TealData.R @@ -184,7 +184,7 @@ TealData <- R6::R6Class( # nolint } else if (is.null(dataset_2)) { private$join_keys[[dataset_1]] } else { - private$join_keys[[dataset_1, dataset_2]] + private$join_keys[[dataset_1]][[dataset_2]] } }, diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index a102c0cfc..9815ccc2f 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -21,7 +21,7 @@ cdisc_join_keys <- function(...) { name <- names(data_objects)[ix] if (checkmate::test_class(item, "join_key_set")) { - jk[get_dataset_1(item), get_dataset_2(item)] <- get_keys(item) + jk[[get_dataset_1(item)]][[get_dataset_2(item)]] <- get_keys(item) } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { @@ -32,10 +32,10 @@ cdisc_join_keys <- function(...) { if (name %in% names(default_cdisc_keys)) { # Set default primary keys keys_list <- default_cdisc_keys[[name]] - jk[name] <- keys_list$primary + jk[[name]][[name]] <- keys_list$primary if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { - jk[name, keys_list$parent] <- keys_list$foreign + jk[[name]][[keys_list$parent]] <- keys_list$foreign } } } diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 48c161a00..978cc9f8e 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -12,9 +12,10 @@ get_join_keys <- function(data) { #' @rdname get_join_keys #' @inheritParams join_keys +#' @param dataset_2 (`character(1)`) name of a dataset. #' @param value value to assign #' @export -`get_join_keys<-` <- function(x, dataset_1, dataset_2 = NULL, value) { +`get_join_keys<-` <- function(data, dataset_1, dataset_2 = NULL, value) { lifecycle::deprecate_stop( when = " 0.3.1", what = "`get_join_keys<-`()", diff --git a/R/join_keys.R b/R/join_keys.R index f576f94e8..4fd9830ef 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -36,8 +36,8 @@ #' #' # or #' jk <- join_keys() -#' jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") -#' jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +#' jk[["dataset_A"]][["dataset_B"]] <- c("col_1" = "col_a") +#' jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") #' jk #' #' td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) @@ -47,8 +47,8 @@ #' join_keys(jk) #' #' jk <- join_keys() -#' jk <- join_keys(join_key("a", "b", "c")) -#' jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) +#' jk <- c(jk, join_keys(join_key("a", "b", "c"))) +#' jk <- c(jk, join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c"))) join_keys <- function(...) { if (missing(...)) { return(new_join_keys()) @@ -116,8 +116,9 @@ join_keys.default <- function(...) { #' #' jk <- join_keys() #' join_keys(jk) <- join_key("ds1", "ds2", "some_col") -#' join_keys(jk) <- join_key("ds3", "ds4", "some_col2") -#' join_keys(jk)["ds1", "ds3"] <- "some_col3" +#' join_keys(jk) <- c(join_keys(jk), join_key("ds3", "ds4", "some_col2")) +#' +#' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk `join_keys<-.join_keys` <- function(join_keys_obj, value) { if (missing(value)) { @@ -127,26 +128,25 @@ join_keys.default <- function(...) { # Assume assignment of join keys as a merge operation # Needed to support join_keys(jk)[ds1, ds2] <- "key" if (checkmate::test_class(value, classes = c("join_keys", "list"))) { - return(merge_join_keys(join_keys_obj, value)) - } - - # Assignment of list of join_key_set will merge it with existing join_keys - if (length(join_keys_obj) > 0 && checkmate::test_list(value, types = "join_key_set", min.len = 1)) { - jk <- new_join_keys() - join_keys(jk) <- value - return(merge_join_keys(join_keys_obj, jk)) + return(value) } if (inherits(value, "join_key_set")) value <- list(value) checkmate::assert_list(value, types = "join_key_set", min.len = 1) + join_keys_obj <- new_join_keys() + # check if any join_key_sets share the same datasets but different values for (idx_1 in seq_along(value)) { for (idx_2 in seq_along(value[idx_1])) { assert_compatible_keys(value[[idx_1]], value[[idx_2]]) } - join_keys_obj <- join_pair(join_keys_obj, value[[idx_1]]) + dataset_1 <- get_dataset_1(value[[idx_1]]) + dataset_2 <- get_dataset_2(value[[idx_1]]) + keys <- get_keys(value[[idx_1]]) + + join_keys_obj[[dataset_1]][[dataset_2]] <- keys } logger::log_trace("join_keys keys are set.") @@ -166,12 +166,9 @@ c.join_keys <- function(...) { if (!length(x)) { return(NULL) } - checkmate::assert_list(x, types = c("join_keys", "list")) - jk <- x[[1]] - for (ix in seq_along(x[-1])) { - jk <- merge_join_keys.default(jk, x[[ix + 1]]) - } - jk + checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) + + merge_join_keys.join_keys(x[[1]], x[-1]) } #' @rdname join_keys @@ -181,9 +178,9 @@ c.join_keys <- function(...) { #' # Setter for join_keys within teal_data ---- #' #' td <- teal_data() -#' join_keys(td)["ds1", "ds2"] <- "key1" -#' join_keys(td)["ds2", "ds2"] <- "key2" -#' join_keys(td) <- join_keys(join_key("ds3", "ds2", "key3")) +#' join_keys(td)[["ds1"]][["ds2"]] <- "key1" +#' join_keys(td)[["ds2"]][["ds2"]] <- "key2" +#' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) #' join_keys(td) `join_keys<-.teal_data` <- function(join_keys_obj, value) { if (missing(value)) { @@ -205,7 +202,6 @@ c.join_keys <- function(...) { #' #' @param join_keys_obj (`join_keys`) object to extract the join keys #' @param dataset_1 (`character`) name of first dataset. -#' @param dataset_2 (`character`) name of second dataset. #' #' @export #' @@ -214,47 +210,32 @@ c.join_keys <- function(...) { #' # Getter for join_keys ---- #' #' jk <- join_keys() -#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") +#' jk[["ds1"]][["ds2"]] <- "some_col" +#' jk[["ds1"]][["ds3"]] <- "some_col2" +#' #' jk["ds1"] -#' jk[dataset_2 = "ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -#' -#' # Double subscript -#' jk["ds1", "ds2"] -`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) { +`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL - if (missing(dataset_2)) dataset_2 <- NULL - if ( - checkmate::test_integerish(dataset_1) || - (length(dataset_1) >= 2 && is.null(dataset_2)) - ) { + + if (checkmate::test_integerish(dataset_1)) { res <- NextMethod("[", join_keys_obj) class(res) <- c("join_keys", "list") return(res) } else if (length(dataset_1) >= 2) { - res <- lapply(dataset_1, function(x) join_keys_obj[[x]][[dataset_2]]) + res <- lapply(dataset_1, function(x) join_keys_obj[[x]]) names(res) <- dataset_1 - return(res) - } else if ( - (is.null(dataset_1) && is.null(dataset_2)) - ) { - return(join_keys_obj) - } else if (is.null(dataset_1)) { - res <- join_keys_obj[dataset_2] class(res) <- c("join_keys", "list") return(res) - } else if (is.null(dataset_2)) { - res <- NextMethod("[", join_keys_obj) - class(res) <- c("join_keys", "list") - return(res) - } - result <- join_keys_obj[[dataset_1]][[dataset_2]] - if (is.null(result)) { - return(character(0)) + } else if (is.null(dataset_1)) { + return(join_keys_obj) } - result + + res <- NextMethod("[", join_keys_obj) + class(res) <- c("join_keys", "list") + res } #' @rdname join_keys @@ -270,44 +251,64 @@ c.join_keys <- function(...) { #' #' # Setter via index ---- #' -#' jk <- join_keys() -#' join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") +#' jk <- join_keys( +#' join_key("ds1", "ds2", "col12"), +#' join_key("ds3", "ds4", "col34") +#' ) #' #' # overwrites previously defined key -#' jk["ds1", "ds2"] <- "(new) pair key" +#' jk["ds1"] <- list(ds2 = "(new)co12") +#' jk["ds1"] <- list(ds3 = "col13", ds4 = "col14") +#' jk +#' +#' jk[c("ds1", "ds2")] <- list(ds5 = "col*5") +#' jk[c(1, 2)] <- list(ds5 = "col**5") #' #' # Creates primary key by only defining `dataset_1` #' jk["ds1"] <- "primary_key" #' jk -`[<-.join_keys` <- function(join_keys_obj, dataset_1, dataset_2 = dataset_1, value) { +`[<-.join_keys` <- function(join_keys_obj, dataset_1, value) { + checkmate::assert( + combine = "or", + checkmate::check_character(dataset_1), + checkmate::check_integerish(dataset_1) + ) + if (checkmate::test_integerish(dataset_1)) { - stop(paste( - "Assigment via index number is not supported with `join_keys` object,", - "please use a dataset name as index and one at a time." - )) - } else if (length(dataset_1) > 1) { - stop(paste( - "Assigment of multiple `join_keys` at the same time is not supported,", - "please only assign one pair at a time." - )) + dataset_1 <- names(join_keys_obj)[dataset_1] } - join_keys_obj[[dataset_1, dataset_2]] <- value - join_keys_obj -} + checkmate::assert( + combine = "or", + checkmate::check_character(value), + checkmate::check_list(value, names = "named", types = "character", null.ok = TRUE) + ) -#' @rdname join_keys -#' @export -#' @examples -#' -#' jk <- join_keys(join_key("ds1", "ds2", "key")) -#' jk[["ds1"]] -#' jk[["ds1", "ds2"]] -`[[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { - if (!is.null(dataset_1) && !is.null(dataset_2)) { - return(join_keys_obj[[dataset_1]][[dataset_2]]) + # Assume characters as being primary keys + if (checkmate::test_character(value)) { + value <- lapply(dataset_1, function(dataset_ix) { + value + }) + names(value) <- dataset_1 + } + + original_value <- value + for (dataset_ix in dataset_1) { + if (is.null(value)) { + inner_items <- names(join_keys_obj[[dataset_ix]]) + value <- structure( + vector(mode = "list", length = length(inner_items)), + names = inner_items + ) + } + + for (new_ix in names(value)) { + join_keys_obj[[dataset_ix]][[new_ix]] <- value[[new_ix]] + } + value <- original_value } - NextMethod("[[", join_keys_obj) + + join_keys_obj } #' @rdname join_keys @@ -317,34 +318,18 @@ c.join_keys <- function(...) { #' jk <- join_keys() #' jk[["ds1"]] <- list() #' jk[["ds2"]][["ds3"]] <- "key" -#' jk[["ds3", "ds4"]] <- "new_key" #' #' jk <- join_keys() #' jk[["ds1"]] <- list() #' jk[["ds2"]][["ds3"]] <- "key" #' jk[["ds4"]] <- list(ds5 = "new") -#' jk[["ds6", "ds7"]] <- "yada" -#' jk[["ds8", "ds9"]] <- c(A = "B", "C") -`[[<-.join_keys` <- function(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) { +#' +#' jk <- join_keys() +#' jk[["ds2"]][["ds3"]] <- "key" +#' jk[["ds2"]][["ds3"]] <- NULL +#' jk +`[[<-.join_keys` <- function(join_keys_obj, dataset_1, value) { checkmate::assert_string(dataset_1) - checkmate::assert_string(dataset_2, null.ok = TRUE) - - # Accepting 2 subscripts - if (!is.null(dataset_2)) { - checkmate::assert_character(value) - - # Normalize value - new_join_key <- join_key(dataset_1, dataset_2, value) - dataset_1 <- get_dataset_1(new_join_key) - dataset_2 <- get_dataset_2(new_join_key) - value <- get_keys(new_join_key) - - if (is.null(join_keys_obj[[dataset_1]])) { - join_keys_obj[[dataset_1]] <- list() - } - join_keys_obj[[dataset_1]][[dataset_2]] <- value - return(join_keys_obj) - } # Accepting 1 subscript with valid `value` formal checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) @@ -353,17 +338,33 @@ c.join_keys <- function(...) { norm_value <- lapply(names(value), function(.x) { get_keys(join_key(dataset_1, .x, value[[.x]])) }) + names(norm_value) <- names(value) value <- norm_value - join_keys_obj <- NextMethod("[[<-", join_keys_obj) - # Keep original parameters as variables will be overwritten for `NextMethod` call original_value <- value ds1 <- dataset_1 + # In case an pair is removed, also remove the symmetric pair + removed_names <- setdiff(names(join_keys_obj[[dataset_1]]), names(value)) + if (length(removed_names) > 0) { + for (.x in removed_names) { + value <- join_keys_obj[[.x]] + value[[ds1]] <- NULL + dataset_1 <- .x + join_keys_obj <- NextMethod("[[<-", join_keys_obj) + } + + # Restore original values + dataset_1 <- ds1 + value <- original_value + } + + join_keys_obj <- NextMethod("[[<-", join_keys_obj) + # Iterate on all new values to create symmetrical pair - for (ds2 in names(value)) { + for (ds2 in names(original_value)) { if (ds2 == ds1) next value <- join_keys_obj[[ds2]] %||% list() @@ -410,14 +411,21 @@ merge_join_keys.default <- function(join_keys_obj, new_join_keys) { #' #' @keywords internal merge_join_keys.join_keys <- function(join_keys_obj, new_join_keys) { - checkmate::assert_class(join_keys_obj, classes = c("join_keys", "list")) - - if (checkmate::test_class(new_join_keys, classes = c("join_keys", "list"))) { + if ( + checkmate::test_class(new_join_keys, "join_key_set") || + checkmate::test_class(new_join_keys, "join_keys") + ) { new_join_keys <- list(new_join_keys) } lapply(new_join_keys, assert_join_keys_alike) + if (checkmate::test_list(new_join_keys, types = "join_key_set")) { + jk_temp <- new_join_keys() + join_keys(jk_temp) <- new_join_keys + new_join_keys <- list(jk_temp) + } + checkmate::assert_list(new_join_keys, types = c("join_keys"), min.len = 1) for (el in new_join_keys) { @@ -432,6 +440,16 @@ merge_join_keys.join_keys <- function(join_keys_obj, new_join_keys) { .S3method("merge_join_keys", "teal_data", merge_join_keys.default) .S3method("merge_join_keys", "join_keys", merge_join_keys.join_keys) +#' Length of `join_keys` object. +#' @inheritParams base::length +#' @export +length.join_keys <- function(x) { + if (NextMethod("length", x) == 0) { + return(0) + } + sum(vapply(x, function(.x) !is.null(.x) && length(.x) > 0, logical(1))) +} + #' Prints `join_keys`. #' #' @inheritParams base::print @@ -446,11 +464,12 @@ print.join_keys <- function(x, ...) { if (length(keys_list) > 0) { cat(sprintf( "A join_keys object containing foreign keys between %s datasets:\n", - length(keys_list) + length(x) )) # Hide parents attr(keys_list, "__parents__") <- NULL # nolint: object_name_linter - print.default(keys_list[sort(names(keys_list))]) + non_empty_ix <- vapply(keys_list, function(.x) !is.null(.x) && length(.x) > 0, logical(1)) + print.default(keys_list[sort(names(keys_list))][non_empty_ix]) } else { cat("An empty join_keys object.") } @@ -475,24 +494,6 @@ new_join_keys <- function() { ) } -#' Helper function to add a new pair to a `join_keys` object -#' -#' @param join_keys_obj (`join_keys`) Object with existing pairs. -#' @param join_key_obj (`join_key_set`) relationship pair to add. -#' -#' @keywords internal -join_pair <- function(join_keys_obj, join_key_obj) { - checkmate::assert_class(join_keys_obj, c("join_keys", "list")) - checkmate::assert_class(join_key_obj, "join_key_set") - - dataset_1 <- get_dataset_1(join_key_obj) - dataset_2 <- get_dataset_2(join_key_obj) - keys <- get_keys(join_key_obj) - - join_keys_obj[[dataset_1]][[dataset_2]] <- keys - join_keys_obj -} - #' Assert the `join_keys` class membership of an argument #' @inheritParams checkmate::assert_class #' @@ -601,8 +602,8 @@ assert_parent_child <- function(join_keys_obj) { name_from <- names(jk_parents)[[idx1]] for (idx2 in seq_along(jk_parents[[idx1]])) { name_to <- jk_parents[[idx1]][[idx2]] - keys_from <- jk[name_from, name_to] - keys_to <- jk[name_to, name_from] + keys_from <- jk[[name_from]][[name_to]] + keys_to <- jk[[name_to]][[name_from]] if (length(keys_from) == 0 && length(keys_to) == 0) { stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) } diff --git a/R/parents.R b/R/parents.R index b326bb962..042ad2d93 100644 --- a/R/parents.R +++ b/R/parents.R @@ -97,13 +97,13 @@ update_keys_given_parents <- function(join_keys_obj) { datanames <- names(jk) duplicate_pairs <- list() for (d1 in datanames) { - d1_pk <- jk[d1, d1] + d1_pk <- jk[[d1]][[d1]] d1_parent <- parents(jk)[[d1]] for (d2 in datanames) { if (paste(d2, d1) %in% duplicate_pairs) { next } - if (length(jk[d1, d2]) == 0) { + if (length(jk[[d1]][[d2]]) == 0) { d2_parent <- parent(jk, d2) d2_pk <- jk[[d2]][[d2]] diff --git a/R/teal_data.R b/R/teal_data.R index 69569741c..0a7519393 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -110,19 +110,19 @@ teal_data_file <- function(path, code = get_code(path)) { #' Add primary keys as join_keys to a dataset self #' #' @param data_objects (`list`) of `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects -#' @param join_keys (`join_keys`) object +#' @param join_keys_obj (`join_keys`) object #' #' @keywords internal -update_join_keys_to_primary <- function(data_objects, join_keys) { +update_join_keys_to_primary <- function(data_objects, join_keys_obj) { for (obj in data_objects) { if (inherits(obj, "TealDataConnector")) { - join_keys <- update_join_keys_to_primary(obj$get_items(), join_keys) + join_keys_obj <- update_join_keys_to_primary(obj$get_items(), join_keys_obj) } else { dataname <- obj$get_dataname() - if (length(join_keys[dataname, dataname]) == 0) { - join_keys[dataname, dataname] <- obj$get_keys() + if (length(join_keys_obj[[dataname]][[dataname]]) == 0) { + join_keys_obj[[dataname]][[dataname]] <- obj$get_keys() } } } - join_keys + join_keys_obj } diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index d141c9457..69d0e6aa2 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -7,14 +7,14 @@ \usage{ get_join_keys(data) -get_join_keys(x, dataset_1, dataset_2 = NULL) <- value +get_join_keys(data, dataset_1, dataset_2 = NULL) <- value } \arguments{ \item{data}{`` - object to extract the join keys} \item{dataset_1}{(\code{character}) name of first dataset.} -\item{dataset_2}{(\code{character}) name of second dataset.} +\item{dataset_2}{(\code{character(1)}) name of a dataset.} \item{value}{value to assign} } diff --git a/man/join_keys.Rd b/man/join_keys.Rd index d4b7ab81e..640f6d1a8 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -13,7 +13,6 @@ \alias{join_keys<-.teal_data} \alias{[.join_keys} \alias{[<-.join_keys} -\alias{[[.join_keys} \alias{[[<-.join_keys} \title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} \usage{ @@ -37,13 +36,11 @@ join_keys(join_keys_obj) <- value \method{join_keys}{teal_data}(join_keys_obj) <- value -\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) +\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL) -\method{[}{join_keys}(join_keys_obj, dataset_1, dataset_2 = dataset_1) <- value +\method{[}{join_keys}(join_keys_obj, dataset_1) <- value -\method{[[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL, value) - -\method{[[}{join_keys}(join_keys_obj, dataset_1 = NULL, dataset_2 = NULL) <- value +\method{[[}{join_keys}(join_keys_obj, dataset_1) <- value } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. @@ -57,8 +54,6 @@ constructed from the arguments.} \item{value}{(\code{character} vector) value to assign.} \item{dataset_1}{(\code{character}) name of first dataset.} - -\item{dataset_2}{(\code{character}) name of second dataset.} } \value{ \code{join_keys} object. @@ -107,8 +102,8 @@ jk # or jk <- join_keys() -jk["dataset_A", "dataset_B"] <- c("col_1" = "col_a") -jk["dataset_A", "dataset_C"] <- c("col_2" = "col_x", "col_3" = "col_y") +jk[["dataset_A"]][["dataset_B"]] <- c("col_1" = "col_a") +jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") jk td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) @@ -118,15 +113,16 @@ jk <- join_keys() join_keys(jk) jk <- join_keys() -jk <- join_keys(join_key("a", "b", "c")) -jk <- join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c")) +jk <- c(jk, join_keys(join_key("a", "b", "c"))) +jk <- c(jk, join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c"))) # Using the setter (assignment) ---- jk <- join_keys() join_keys(jk) <- join_key("ds1", "ds2", "some_col") -join_keys(jk) <- join_key("ds3", "ds4", "some_col2") -join_keys(jk)["ds1", "ds3"] <- "some_col3" +join_keys(jk) <- c(join_keys(jk), join_key("ds3", "ds4", "some_col2")) + +join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" jk c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) @@ -134,48 +130,51 @@ c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) # Setter for join_keys within teal_data ---- td <- teal_data() -join_keys(td)["ds1", "ds2"] <- "key1" -join_keys(td)["ds2", "ds2"] <- "key2" -join_keys(td) <- join_keys(join_key("ds3", "ds2", "key3")) +join_keys(td)[["ds1"]][["ds2"]] <- "key1" +join_keys(td)[["ds2"]][["ds2"]] <- "key2" +join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) # Getter for join_keys ---- jk <- join_keys() -join_keys(jk) <- join_key("ds1", "ds2", "some_col") +jk[["ds1"]][["ds2"]] <- "some_col" +jk[["ds1"]][["ds3"]] <- "some_col2" + jk["ds1"] -jk[dataset_2 = "ds1"] jk[1:2] jk[c("ds1", "ds2")] -# Double subscript -jk["ds1", "ds2"] - # Setter via index ---- -jk <- join_keys() -join_keys(jk) <- join_key("ds1", "ds2", "(original) pair key") +jk <- join_keys( + join_key("ds1", "ds2", "col12"), + join_key("ds3", "ds4", "col34") +) # overwrites previously defined key -jk["ds1", "ds2"] <- "(new) pair key" +jk["ds1"] <- list(ds2 = "(new)co12") +jk["ds1"] <- list(ds3 = "col13", ds4 = "col14") +jk + +jk[c("ds1", "ds2")] <- list(ds5 = "col*5") +jk[c(1, 2)] <- list(ds5 = "col**5") # Creates primary key by only defining `dataset_1` jk["ds1"] <- "primary_key" jk -jk <- join_keys(join_key("ds1", "ds2", "key")) -jk[["ds1"]] -jk[["ds1", "ds2"]] - jk <- join_keys() jk[["ds1"]] <- list() jk[["ds2"]][["ds3"]] <- "key" -jk[["ds3", "ds4"]] <- "new_key" jk <- join_keys() jk[["ds1"]] <- list() jk[["ds2"]][["ds3"]] <- "key" jk[["ds4"]] <- list(ds5 = "new") -jk[["ds6", "ds7"]] <- "yada" -jk[["ds8", "ds9"]] <- c(A = "B", "C") + +jk <- join_keys() +jk[["ds2"]][["ds3"]] <- "key" +jk[["ds2"]][["ds3"]] <- NULL +jk } diff --git a/man/join_pair.Rd b/man/join_pair.Rd deleted file mode 100644 index 5366f412a..000000000 --- a/man/join_pair.Rd +++ /dev/null @@ -1,17 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{join_pair} -\alias{join_pair} -\title{Helper function to add a new pair to a \code{join_keys} object} -\usage{ -join_pair(join_keys_obj, join_key_obj) -} -\arguments{ -\item{join_keys_obj}{(\code{join_keys}) Object with existing pairs.} - -\item{join_key_obj}{(\code{join_key_set}) relationship pair to add.} -} -\description{ -Helper function to add a new pair to a \code{join_keys} object -} -\keyword{internal} diff --git a/man/length.join_keys.Rd b/man/length.join_keys.Rd new file mode 100644 index 000000000..80cbbe1cc --- /dev/null +++ b/man/length.join_keys.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{length.join_keys} +\alias{length.join_keys} +\title{Length of \code{join_keys} object.} +\usage{ +\method{length}{join_keys}(x) +} +\arguments{ +\item{x}{an \R object. For replacement, a vector or factor.} +} +\description{ +Length of \code{join_keys} object. +} diff --git a/man/update_join_keys_to_primary.Rd b/man/update_join_keys_to_primary.Rd index 2102fd5d3..7302fcf6e 100644 --- a/man/update_join_keys_to_primary.Rd +++ b/man/update_join_keys_to_primary.Rd @@ -4,12 +4,12 @@ \alias{update_join_keys_to_primary} \title{Add primary keys as join_keys to a dataset self} \usage{ -update_join_keys_to_primary(data_objects, join_keys) +update_join_keys_to_primary(data_objects, join_keys_obj) } \arguments{ \item{data_objects}{(\code{list}) of \code{TealDataset}, \code{TealDatasetConnector} or \code{TealDataConnector} objects} -\item{join_keys}{(\code{join_keys}) object} +\item{join_keys_obj}{(\code{join_keys}) object} } \description{ Add primary keys as join_keys to a dataset self diff --git a/tests/testthat/helper-get_join_keys.R b/tests/testthat/helper-get_join_keys.R index ee6231469..190e9e684 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/tests/testthat/helper-get_join_keys.R @@ -26,7 +26,7 @@ helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { expect_s3_class(jk, class = c("join_keys", "list")) expect_length(jk, 1) - expect_length(jk[dataset_1, dataset_1], 1) + expect_length(jk[[dataset_1]][[dataset_1]], 1) obj } @@ -43,8 +43,8 @@ helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter expect_s3_class(jk, class = c("join_keys", "list")) expect_length(jk, 2) - expect_length(jk[dataset_1, dataset_1], 1) - expect_length(jk[new_dataset_1, new_dataset_1], 1) + expect_length(jk[[dataset_1]][[dataset_1]], 1) + expect_length(jk[[new_dataset_1]][[new_dataset_1]], 1) } #' Test suite for join_keys after manual adding a primary key @@ -69,16 +69,13 @@ helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length # Primary key (each adds 1) join_keys(obj)[.ds()] <- .key() - join_keys(obj)[.ds(add = 0), .ds()] <- .key(2) - join_keys(obj)[.ds(add = 0), .ds()] <- .key(4) - join_keys(obj)[.ds(add = 0), .ds()] <- character(0) - expect_error(join_keys(obj)[.ds(add = 0), .ds()] <- .key(3)) + expect_error(join_keys(obj)[.ds()] <- .key(3)) - join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(1)) - join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(2)) - join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(4)) - join_keys(obj) <- join_key(.ds(add = 0), .ds(), character(0)) - expect_error(join_keys(obj) <- join_key(.ds(add = 0), .ds(), .key(3))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(1))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(2))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(4))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), character(0))) + expect_error(join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(3)))) # Relationship pair (each adds 2) join_keys(obj)[[.ds()]][[.ds()]] <- .key(1) @@ -87,14 +84,7 @@ helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length join_keys(obj)[[.ds()]][[.ds()]] <- .key(4) join_keys(obj)[[.ds()]][[.ds()]] <- character(0) - # Relationship pair alt 1 (each adds 2) - join_keys(obj)[[.ds(), .ds()]] <- .key(1) - join_keys(obj)[[.ds(), .ds()]] <- .key(2) - join_keys(obj)[[.ds(), .ds()]] <- .key(3) - join_keys(obj)[[.ds(), .ds()]] <- .key(4) - join_keys(obj)[[.ds(), .ds()]] <- character(0) - - # Relationship pair alt 2 (each adds 2) + # Relationship pair alternative (each adds 2) join_keys(obj)[[.ds()]] <- setNames(list(.key(1)), .ds()) join_keys(obj)[[.ds()]] <- setNames(list(.key(2)), .ds()) join_keys(obj)[[.ds()]] <- setNames(list(.key(3)), .ds()) @@ -102,14 +92,15 @@ helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length join_keys(obj)[[.ds()]] <- setNames(list(character(0)), .ds()) # Using join_key (each adds 2) - join_keys(obj) <- join_key(.ds(), .ds(), .key(1)) - join_keys(obj) <- join_key(.ds(), .ds(), .key(2)) - join_keys(obj) <- join_key(.ds(), .ds(), .key(3)) - join_keys(obj) <- join_key(.ds(), .ds(), .key(4)) - join_keys(obj) <- join_key(.ds(), .ds(), character(0)) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(1))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(2))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(3))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(4))) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), character(0))) # (each join_key adds 2) - join_keys(obj) <- list( + join_keys(obj) <- c( + join_keys(obj), join_key(.ds(), .ds(), .key(1)), join_key(.ds(), .ds(), .key(2)), join_key(.ds(), .ds(), .key(3)), @@ -118,22 +109,24 @@ helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length ) # (each join_key adds 2) - join_keys(obj) <- join_keys( - join_key(.ds(), .ds(), .key(1)), - join_key(.ds(), .ds(), .key(2)), - join_key(.ds(), .ds(), .key(3)), - join_key(.ds(), .ds(), .key(4)), - join_key(.ds(), .ds(), character(0)) + join_keys(obj) <- c( + join_keys(obj), join_keys( + join_key(.ds(), .ds(), .key(1)), + join_key(.ds(), .ds(), .key(2)), + join_key(.ds(), .ds(), .key(3)), + join_key(.ds(), .ds(), .key(4)), + join_key(.ds(), .ds(), character(0)) + ) ) expect_s3_class(join_keys(obj), class = c("join_keys", "list")) - expected_length <- 68 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` + expected_length <- 55 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` expect_length(join_keys(obj), expected_length) - join_keys(obj) <- join_key("ds-manual", .ds(), .key(1)) + join_keys(obj) <- c(join_keys(obj), join_key("ds-manual", .ds(), .key(1))) expect_length(join_keys(obj), expected_length + 2) # adds 2 new datasets - join_keys(obj) <- join_key(.ds(), "ds-manual", .key(1)) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), "ds-manual", .key(1))) expect_length(join_keys(obj), expected_length + 2 + 1) # adds 1 new dataset as ds-manual already exists } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 6373c8750..0c62ac000 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -34,18 +34,18 @@ test_that("join_keys<-.join_keys shared test to getter and setter", { test_that("join_keys<-.join_keys to set via a join_key_set object", { obj <- join_keys() - join_keys(obj) <- join_key("ds1", "ds2", "id") + join_keys(obj) <- c(obj, join_key("ds1", "ds2", "id")) expect_equal(obj$ds1, list("ds2" = c("id" = "id"))) expect_equal(obj$ds2, list("ds1" = c("id" = "id"))) }) -test_that("join_keys<-.join_keys to set via multiple lists that progressively merge object", { +test_that("c.join_keys to set via multiple lists that progressively merge object", { obj <- join_keys() - join_keys(obj) <- list(join_key("ds1", "ds2", "id")) - join_keys(obj) <- list(join_key("ds3", "ds4", "id_id")) - join_keys(obj) <- join_key("ds5", "ds6", "id_id_id") + obj <- c(obj, join_key("ds1", "ds2", "id")) + obj <- c(obj, join_key("ds3", "ds4", "id_id"), join_key("ds5", "ds6", "id_id")) + obj <- c(obj, join_key("ds7", "ds8", "id_id_id")) - expect_length(obj, 6) + expect_length(obj, 8) }) # ----------------------------------------------------------------------------- @@ -69,22 +69,6 @@ test_that("[[<-.join_keys creates symmetric relationship", { ) }) -test_that("[[<-.join_keys is equivalent to using the constructor (double subscript)", { - jk <- join_keys( - join_key("d1", "d2", c("A" = "B", "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) - ) - - jk2 <- join_keys() - - jk2[["d1", "d2"]] <- c("A" = "B", "C") - jk2[["d3", "d4"]] <- c("D", "E") - jk2[["d5", "d6"]] <- c("F", "K" = "k") - - expect_identical(jk, jk2) -}) - test_that("[[<-.join_keys is equivalent to using the constructor (single subscript)", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C" = "C")), @@ -101,7 +85,7 @@ test_that("[[<-.join_keys is equivalent to using the constructor (single subscri expect_identical(jk, jk2) }) -test_that("[<-.join_keys is equivalent to using the constructor (double subscript)", { +test_that("[<-.join_keys is equivalent to using the constructor", { jk <- join_keys( join_key("d1", "d2", c("A", "B")), join_key("d3", "d4", c("C", "D")), @@ -110,9 +94,9 @@ test_that("[<-.join_keys is equivalent to using the constructor (double subscrip jk2 <- join_keys() - jk2["d1", "d2"] <- c("A", "B") - jk2["d3", "d4"] <- c("C", "D") - jk2["d5", "d6"] <- c("E", "F") + jk2["d1"] <- list(d2 = c("A", "B")) + jk2["d3"] <- list(d4 = c("C", "D")) + jk2["d5"] <- list(d6 = c("E", "F")) expect_identical(jk, jk2) }) @@ -142,11 +126,16 @@ test_that("[.join_keys can subscript multiple values by index or name", { test_that("[<-.join_keys cannot subscript multiple values", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) + join_key("d2", "d3", c("D", "E")), + join_key("d4", "d3", c("F", "K" = "k")), + join_key("d4", "d1", c("F", "K" = "k")) ) - expect_error(jk[1:2] <- NULL) + jk[1:2] <- NULL + + expect_length(jk, 2) + expect_identical(jk[["d4"]][["d3"]], c("F" = "F", "K" = "k")) + expect_identical(jk[["d3"]][["d4"]], c("F" = "F", "k" = "K")) }) test_that("[[<- can mutate existing keys", { @@ -172,60 +161,98 @@ test_that("[[<- can remove keys by setting them to character(0)", { expect_equal(my_keys[["d1"]][["d2"]], character(0)) }) +test_that("[[<-.join_keys removes keys with NULL", { + jk <- join_keys() + + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") + jk[["d1"]][["d2"]] <- NULL + + expect_identical( + jk, + structure( + list( + d1 = structure(list(), names = character(0)), + d2 = structure(list(), names = character(0)) + ), + class = c("join_keys", "list") + ) + ) +}) + +test_that("[[<-.join_keys removes keys with NULL and keeps existing", { + jk <- join_keys() + + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") + jk[["d2"]][["d3"]] <- c("A" = "B", "C" = "C") + jk[["d1"]][["d4"]] <- c("A" = "B", "C" = "C") + jk[["d1"]][["d2"]] <- NULL + + expect_null(jk[["d1"]][["d2"]]) + expect_null(jk[["d2"]][["d1"]]) + + expect_failure(expect_null(jk[["d2"]][["d3"]])) + expect_failure(expect_null(jk[["d3"]][["d2"]])) + expect_failure(expect_null(jk[["d1"]][["d4"]])) + expect_failure(expect_null(jk[["d4"]][["d1"]])) + + expect_length(jk, 4) +}) + + # ----------------------------------------------------------------------------- # # mutate_join_keys (empty value name) # -test_that("[<-.join_keys with empty name is changed to the key value", { +test_that("[[<-.join_keys with empty name is changed to the key value", { # set empty key name jk <- join_keys() - jk["d1", "d2"] <- c("A" = "B", "C") - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + jk[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" jk <- join_keys() - jk["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" jk <- join_keys() - expect_message(jk["d1", "d2"] <- c("A" = "B", ""), "are ignored") - expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) + expect_message(jk[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B"), c("A"))) }) test_that("join_keys()[]<-.join_keys with empty name is changed to the key value", { # set empty key name jk <- join_keys() - join_keys(jk)["d1", "d2"] <- c("A" = "B", "C") - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" jk <- join_keys() - join_keys(jk)["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(jk["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", "C" = "") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" jk <- join_keys() - expect_message(join_keys(jk)["d1", "d2"] <- c("A" = "B", ""), "are ignored") - expect_equal(jk["d1", "d2"], setNames(c("B"), c("A"))) + expect_message(join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B"), c("A"))) }) test_that("join_keys()[]<-.teal_data with empty name is changed to the key value", { # set empty key name td <- teal_data() - join_keys(td)["d1", "d2"] <- c("A" = "B", "C") - expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on non-empty variable name equal to "" td <- teal_data() - join_keys(td)["d1", "d2"] <- c("A" = "B", "C" = "") - expect_equal(join_keys(td)["d1", "d2"], setNames(c("B", "C"), c("A", "C"))) + join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", "C" = "") + expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) # set key on empty variable name equal to "" td <- teal_data() - expect_message(join_keys(td)["d1", "d2"] <- c("A" = "B", ""), "are ignored") - expect_equal(join_keys(td)["d1", "d2"], setNames(c("B"), c("A"))) + expect_message(join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B"), c("A"))) }) # ----------------------------------------------------------------------------- @@ -355,7 +382,7 @@ test_that("join_keys can create join_keys with valid arguments", { test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) - expect_equal(my_keys["d2", "d1"], c("C" = "A")) + expect_equal(my_keys[["d2"]][["d1"]], c("C" = "A")) }) test_that("join_keys[ can get all keys for a given dataset", { @@ -371,13 +398,6 @@ test_that("join_keys[ can get all keys for a given dataset", { class = c("join_keys", "list") ) ) - expect_equal( - my_keys[dataset_2 = "d1"], - structure( - list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), - class = c("join_keys", "list") - ) - ) expect_equal( my_keys[dataset_1 = "d3"], structure( @@ -409,14 +429,14 @@ test_that( "join_keys join_key with unamed keys vector creates a join_keys with the same column names for both datasets ", { test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) - expect_equal(unname(test_keys["d1", "d2"]), names(test_keys["d1", "d2"])) + expect_equal(unname(test_keys[["d1"]][["d2"]]), names(test_keys[["d1"]][["d2"]])) } ) -test_that("join_keys if no keys between pair of datasets then getting them returns character(0)", { +test_that("join_keys if no keys between pair of datasets then getting them returns NULL", { my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_equal(my_keys["d1", "d3"], character(0)) - expect_equal(my_keys["d1", "d4"], character(0)) + expect_equal(my_keys[["d1"]][["d3"]], NULL) + expect_equal(my_keys[["d1"]][["d4"]], NULL) }) # ----------------------------------------------------------------------------- @@ -437,7 +457,7 @@ testthat::test_that("merge_join_keys can handle edge case: calling object is emp testthat::expect_identical(join_keys(x), join_keys(x)) }) -testthat::test_that("merge_join_keys can handle edge case: argument is an empty object", { +testthat::test_that("c.join_keys can handle edge case: argument is an empty object", { x <- join_keys() y <- join_keys() join_keys(y) <- list( @@ -450,193 +470,174 @@ testthat::test_that("merge_join_keys can handle edge case: argument is an empty testthat::expect_identical(previous_output, join_keys(y)) }) -testthat::test_that("merge_join_keys can handle edge case: argument is a list of empty objects", { +testthat::test_that("c.join_keys can handle edge case: argument is a list of empty objects", { x <- join_keys() - y <- join_keys() - - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x, x))) - testthat::expect_identical(previous_output, join_keys(y)) + previous_output <- y + testthat::expect_silent(c(y, x, x)) + testthat::expect_identical(previous_output, y) - testthat::expect_silent(merge_join_keys(y, list(x, x, x))) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_silent(c(y, x, x, x)) + testthat::expect_identical(previous_output, y) }) testthat::test_that( "merge_join_keys throws error when improper argument is passed in without modifying the caller", { - y <- join_keys() - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) previous_output <- join_keys(y) - testthat::expect_error(y <- merge_join_keys(y)) - testthat::expect_identical(previous_output, join_keys(y)) + + testthat::expect_error(y <- merge_join_keys()) + testthat::expect_identical(previous_output, y) testthat::expect_error(y <- merge_join_keys(y, 1)) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_identical(previous_output, y) testthat::expect_error(y <- merge_join_keys(y, "A")) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_identical(previous_output, y) testthat::expect_error(y <- merge_join_keys(y, list())) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_identical(previous_output, y) testthat::expect_error(y <- merge_join_keys(list(1))) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_identical(previous_output, y) - testthat::expect_error(y <- merge_join_keys(y, list("A"))) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_error(y <- merge_join_keys(y, "A")) + testthat::expect_identical(previous_output, y) } ) testthat::test_that("merge_join_keys does nothing when argument is a join_keys object with identical data", { - x <- join_keys() - y <- join_keys() - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - previous_output <- join_keys(y) + previous_output <- y testthat::expect_silent(merge_join_keys(y, x)) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_identical(previous_output, y) }) testthat::test_that( "merge_join_keys does nothing when argument is a list of one join_keys object with identical data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x))) - testthat::expect_identical(previous_output, join_keys(y)) + previous_output <- y + testthat::expect_silent(c(y, x)) + testthat::expect_identical(previous_output, y) - testthat::expect_silent(merge_join_keys(y, list(x, x))) - testthat::expect_identical(previous_output, join_keys(y)) + testthat::expect_silent(c(y, x, x)) + testthat::expect_identical(previous_output, y) } ) testthat::test_that( "merge_join_keys does nothing when argument is a list of many join_keys object with identical data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, list(x, x, x, x, x, x, x, x))) - testthat::expect_identical(previous_output, join_keys(y)) + previous_output <- y + testthat::expect_silent(c(y, x, x, x, x, x, x, x, x)) + testthat::expect_identical(previous_output, y) } ) testthat::test_that("merge_join_keys clones data when argument is a list of one join_keys object that is a superset", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")), join_key("ZZ", "YY", c("zz" = "yy")) ) - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) - previous_output <- join_keys(y) - testthat::expect_silent(y <- merge_join_keys(y, list(x))) - testthat::expect_false(identical(previous_output, join_keys(y))) - testthat::expect_identical(join_keys(x), join_keys(y)) + previous_output <- y + testthat::expect_silent(y <- c(y, x)) + testthat::expect_false(identical(previous_output, y)) + testthat::expect_identical(x, y) }) testthat::test_that("merge_join_keys does nothing when argument is a list of one join_keys object that is a subset", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")), join_key("ZZ", "YY", c("zz" = "yy")) ) - join_keys(y) <- list( + y <- join_keys( join_key("A", "B", c("a" = "b")), join_key("A", "C", c("a" = "c", "aa" = "cc")), join_key("Z", "Y", c("z" = "y")) ) previous_output <- join_keys(x) - testthat::expect_silent(x <- merge_join_keys(x, list(y))) + testthat::expect_silent(x <- c(x, y)) testthat::expect_identical(previous_output, join_keys(x)) }) testthat::test_that("merge_join_keys merges mutually exclusive data", { - x <- join_keys() - y <- join_keys() - - join_keys(x) <- list( + x <- join_keys( join_key("A", "B", c("a" = "b")) ) - join_keys(y) <- list( + y <- join_keys( join_key("Z", "Y", c("z" = "y")) ) z <- join_keys() - z <- merge_join_keys(z, list(x, y)) - manual_join <- c(join_keys(x), join_keys(y)) + z <- c(z, x, y) + manual_join <- c(x, y) class(manual_join) <- class(new_join_keys()) - testthat::expect_identical(manual_join, join_keys(z)) + testthat::expect_identical(manual_join, z) - x <- merge_join_keys(x, y) - y <- merge_join_keys(y, x) + x <- c(x, y) + y <- c(y, x) - testthat::expect_identical(join_keys(x), join_keys(z)) - testthat::expect_true(all(join_keys(y) %in% join_keys(z)) && all(join_keys(z) %in% join_keys(y))) - testthat::expect_true(all(join_keys(y) %in% join_keys(x)) && all(join_keys(x) %in% join_keys(y))) + testthat::expect_identical(x, z) + testthat::expect_true(all(y %in% z) && all(z %in% y)) + testthat::expect_true(all(y %in% x) && all(x %in% y)) - testthat::expect_identical(names(z), c("A", "B", "Z", "Y")) - testthat::expect_equal(length(join_keys(z)), 4) - testthat::expect_identical(join_keys(z)$A$B, c("a" = "b")) - testthat::expect_identical(join_keys(z)$B$A, c("b" = "a")) - testthat::expect_identical(join_keys(z)$Z$Y, c("z" = "y")) - testthat::expect_identical(join_keys(z)$Y$Z, c("y" = "z")) + testthat::expect_identical(sort(names(z)), c("A", "B", "Y", "Z")) + testthat::expect_equal(length(z), 4) + testthat::expect_identical(z$A$B, c("a" = "b")) + testthat::expect_identical(z$B$A, c("b" = "a")) + testthat::expect_identical(z$Z$Y, c("z" = "y")) + testthat::expect_identical(z$Y$Z, c("y" = "z")) }) # ----------------------------------------------------------------------------- @@ -678,33 +679,33 @@ test_that("cdisc_join_keys will generate join_keys for named list with non-named new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) jk <- join_keys(new_dataset) - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will generate join_keys for character list", { new_dataset <- cdisc_join_keys("ADSL", "ADTTE") jk <- join_keys(new_dataset) - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will generate join_keys for named list", { new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) jk <- join_keys(new_dataset) - expect_identical(unname(jk["ADSL", "ADSL"]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk["ADTTE", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$primary) + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - expect_identical(unname(jk["ADSL", "ADTTE"]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk["ADTTE", "ADSL"]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) }) test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { @@ -712,11 +713,11 @@ test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { internal_keys <- default_cdisc_keys[["ADTTE"]] jk <- cdisc_join_keys("ADTTE") - primary_keys <- unname(jk["ADTTE", "ADTTE"]) + primary_keys <- unname(jk[["ADTTE"]][["ADTTE"]]) expect_equal(primary_keys, internal_keys$primary) - foreign_keys <- unname(jk["ADTTE", internal_keys$parent]) + foreign_keys <- unname(jk[["ADTTE"]][[internal_keys$parent]]) expect_equal(foreign_keys, internal_keys$foreign) }) @@ -728,10 +729,10 @@ test_that("cdisc_join_keys will retrieve known primary and foreign keys", { function(.x) { internal_keys <- default_cdisc_keys[[.x]] jk <- cdisc_join_keys(.x) - primary_keys <- unname(jk[.x, .x]) + primary_keys <- unname(jk[[.x]][[.x]]) expect_equal(primary_keys, internal_keys$primary) if (!is.null(internal_keys$foreign)) { - foreign_keys <- unname(jk[.x, internal_keys$parent]) + foreign_keys <- unname(jk[[.x]][[internal_keys$parent]]) expect_equal(foreign_keys, internal_keys$foreign) } character(0) @@ -747,7 +748,7 @@ test_that("cdisc_join_keys will retrieve known primary keys", { datasets, function(.x) { jk <- cdisc_join_keys(.x) - expect_equal(unname(jk[.x, .x]), get_cdisc_keys(.x)) + expect_equal(unname(jk[[.x]][[.x]]), get_cdisc_keys(.x)) character(0) }, character(0) @@ -761,25 +762,3 @@ test_that("cdisc_join_keys does nothing with TealDataset", { adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) }) - -# ----------------------------------------------------------------------------- -# -# Subset-join_keys - -test_that("[<-.join_keys assigns new relationship pair", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - expect_length(jk["ds1", "ds2"], 0) - - jk["ds1", "ds2"] <- c("id") - expect_identical(jk["ds1", "ds2"], c(id = "id")) - expect_identical(jk[["ds1"]][["ds2"]], jk["ds1", "ds2"]) -}) - -test_that("[<-.join_keys modifies existing relationship pair", { - jk <- join_keys(join_key("ds1", keys = c("id"))) - - jk["ds1", "ds1"] <- c("Species") - expect_failure(expect_identical(jk["ds1", "ds1"], c(id = "id"))) - expect_identical(jk[["ds1"]][["ds1"]], c(Species = "Species")) -}) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 0309dfc85..43382dd20 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -54,21 +54,21 @@ test_that("parents<- will add to parents attribute using list, `[` and `[[` nota test_that("assert_parent_child will detect empty keys", { jk <- join_keys() - jk["ds1", "ds2"] <- character(0) + jk[["ds1"]][["ds2"]] <- character(0) parents(jk) <- list(ds1 = "ds2") expect_error(assert_parent_child(jk)) }) test_that("assert_parent_child will detect invalid key pairs", { jk <- join_keys() - jk["ds1", "ds2"] <- "key1" - jk["ds2", "ds1"] <- character(0) + jk[["ds1"]][["ds2"]] <- "key1" + jk[["ds2"]][["ds1"]] <- character(0) parents(jk) <- list(ds1 = "ds2") expect_error(assert_parent_child(jk)) jk2 <- join_keys() - jk2["ds2", "ds1"] <- "key1" - jk2["ds1", "ds2"] <- character(0) + jk2[["ds2"]][["ds1"]] <- "key1" + jk2[["ds1"]][["ds2"]] <- character(0) parents(jk2) <- list(ds1 = "ds2") expect_error(assert_parent_child(jk2)) }) From 05bc1d333d161a437b356fea127c47c4ed9cfbda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 10:34:59 +0100 Subject: [PATCH 059/152] adds test for cdisc and reorganizes files --- tests/testthat/test-cdisc_join_keys.R | 94 +++++++++++++++++++++++++++ tests/testthat/test-join_keys.R | 92 -------------------------- 2 files changed, 94 insertions(+), 92 deletions(-) create mode 100644 tests/testthat/test-cdisc_join_keys.R diff --git a/tests/testthat/test-cdisc_join_keys.R b/tests/testthat/test-cdisc_join_keys.R new file mode 100644 index 000000000..08e37a3e5 --- /dev/null +++ b/tests/testthat/test-cdisc_join_keys.R @@ -0,0 +1,94 @@ +test_that("cdisc_join_keys merges joins keys with CDISC default join_keys", { + result <- cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") + + expect_named(result, c("ADSL", "ADTTE", "dataset_A", "dataset_B"), ignore.order = TRUE) + expect_identical(result[["dataset_B"]][["dataset_A"]], c("col_a" = "col_1")) +}) + +test_that("cdisc_join_keys will generate join_keys for named list with non-named elements", { + new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) + jk <- join_keys(new_dataset) + + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will generate join_keys for character list", { + new_dataset <- cdisc_join_keys("ADSL", "ADTTE") + jk <- join_keys(new_dataset) + + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will generate join_keys for named list", { + new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) + jk <- join_keys(new_dataset) + + expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) + expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) + + expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) + expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) +}) + +test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { + datasets <- names(default_cdisc_keys) + + internal_keys <- default_cdisc_keys[["ADTTE"]] + jk <- cdisc_join_keys("ADTTE") + primary_keys <- unname(jk[["ADTTE"]][["ADTTE"]]) + + expect_equal(primary_keys, internal_keys$primary) + + foreign_keys <- unname(jk[["ADTTE"]][[internal_keys$parent]]) + expect_equal(foreign_keys, internal_keys$foreign) +}) + +test_that("cdisc_join_keys will retrieve known primary and foreign keys", { + datasets <- names(default_cdisc_keys) + + vapply( + datasets, + function(.x) { + internal_keys <- default_cdisc_keys[[.x]] + jk <- cdisc_join_keys(.x) + primary_keys <- unname(jk[[.x]][[.x]]) + expect_equal(primary_keys, internal_keys$primary) + if (!is.null(internal_keys$foreign)) { + foreign_keys <- unname(jk[[.x]][[internal_keys$parent]]) + expect_equal(foreign_keys, internal_keys$foreign) + } + character(0) + }, + character(0) + ) +}) + +test_that("cdisc_join_keys will retrieve known primary keys", { + datasets <- names(default_cdisc_keys) + + vapply( + datasets, + function(.x) { + jk <- cdisc_join_keys(.x) + expect_equal(unname(jk[[.x]][[.x]]), get_cdisc_keys(.x)) + character(0) + }, + character(0) + ) +}) + +test_that("cdisc_join_keys does nothing with TealDataset", { + adae_cf <- callable_function( + function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) + ) + adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) + expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 0c62ac000..4c02f4101 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -670,95 +670,3 @@ testthat::test_that("parents<- sets the parents of datasets when they are empty" list(df1 = character(0), df2 = "df1") ) }) - -# ----------------------------------------------------------------------------- -# -# cdisc_join_keys - -test_that("cdisc_join_keys will generate join_keys for named list with non-named elements", { - new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate join_keys for character list", { - new_dataset <- cdisc_join_keys("ADSL", "ADTTE") - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate join_keys for named list", { - new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - internal_keys <- default_cdisc_keys[["ADTTE"]] - jk <- cdisc_join_keys("ADTTE") - primary_keys <- unname(jk[["ADTTE"]][["ADTTE"]]) - - expect_equal(primary_keys, internal_keys$primary) - - foreign_keys <- unname(jk[["ADTTE"]][[internal_keys$parent]]) - expect_equal(foreign_keys, internal_keys$foreign) -}) - -test_that("cdisc_join_keys will retrieve known primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - internal_keys <- default_cdisc_keys[[.x]] - jk <- cdisc_join_keys(.x) - primary_keys <- unname(jk[[.x]][[.x]]) - expect_equal(primary_keys, internal_keys$primary) - if (!is.null(internal_keys$foreign)) { - foreign_keys <- unname(jk[[.x]][[internal_keys$parent]]) - expect_equal(foreign_keys, internal_keys$foreign) - } - character(0) - }, - character(0) - ) -}) - -test_that("cdisc_join_keys will retrieve known primary keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - jk <- cdisc_join_keys(.x) - expect_equal(unname(jk[[.x]][[.x]]), get_cdisc_keys(.x)) - character(0) - }, - character(0) - ) -}) - -test_that("cdisc_join_keys does nothing with TealDataset", { - adae_cf <- callable_function( - function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) - ) - adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) -}) From 3e118ed9e929e23bbe25789a6b23098aaaf64636 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 11:37:31 +0100 Subject: [PATCH 060/152] feat: support logical indices --- R/join_keys.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/join_keys.R b/R/join_keys.R index 4fd9830ef..34cc8e8d7 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -220,7 +220,7 @@ c.join_keys <- function(...) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL - if (checkmate::test_integerish(dataset_1)) { + if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { res <- NextMethod("[", join_keys_obj) class(res) <- c("join_keys", "list") return(res) From e798836a0ccaa29c579d803f84f0a503e53b21ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 12:05:24 +0100 Subject: [PATCH 061/152] tests: better comparison of join_keys using testthat 2e --- tests/testthat/helper-compare.R | 36 +++++++++++++++++++++++++++++++++ tests/testthat/test-join_keys.R | 3 ++- 2 files changed, 38 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/helper-compare.R diff --git a/tests/testthat/helper-compare.R b/tests/testthat/helper-compare.R new file mode 100644 index 000000000..5056956c3 --- /dev/null +++ b/tests/testthat/helper-compare.R @@ -0,0 +1,36 @@ +#' Compare 2 join keys by ordering names and removing NULL elements +#' +#' Code borrowed from waldo. This should be removed in favor of using testthat 3e +#' that has an option to compare lists as maps. +#' +#' `expect_identical(x, y, list_as_map = TRUE)` +#' +#' +#' @inheritParams testthat::compare +#' +#' @keywords internal +compare.join_keys <- function(x, y, ...) { + as_map <- function(x) { + attr(x, "extra_class") <- class(x) + attr(x, "class") <- "list" + + # Remove nulls + is_null <- vapply(x, is.null, logical(1)) + x <- x[!is_null] + + # Sort named components, preserving positions of unnamed + nx <- rlang::names2(x) + is_named <- nx != "" + if (any(is_named)) { + idx <- seq_along(x) + idx[is_named] <- idx[is_named][order(nx[is_named])] + x <- x[idx] + } + + x + } + + compare(as_map(x), as_map(y)) +} + +.S3method("compare", "join_keys", compare.join_keys) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 4c02f4101..768a3066e 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -628,7 +628,8 @@ testthat::test_that("merge_join_keys merges mutually exclusive data", { x <- c(x, y) y <- c(y, x) - testthat::expect_identical(x, z) + testthat::expect_equal(x, z) + testthat::expect_equal(y, z) testthat::expect_true(all(y %in% z) && all(z %in% y)) testthat::expect_true(all(y %in% x) && all(x %in% y)) From 9fc728ffcbba09de2886f59e0377f5ac931d5cf5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 12:07:12 +0100 Subject: [PATCH 062/152] docs: adds missing method --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 2cb7c1bb5..028b096ff 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -122,6 +122,7 @@ reference: - join_key - join_keys - join_keys<- + - length.join_keys - parent - parents - parents<- From 954ea59a3fa344058c47b97ad867793559588d27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 13:33:43 +0100 Subject: [PATCH 063/152] feat: [.join_keys will return symmetrical keys, adds default_cdisc_join_keys --- NAMESPACE | 1 + R/cdisc_join_keys.R | 16 ++++++++++ R/join_keys.R | 27 ++++++++-------- R/zzz.R | 7 +++++ man/default_cdisc_join_keys.Rd | 9 ++++++ tests/testthat/test-cdisc_join_keys.R | 24 +++++++++++++++ tests/testthat/test-join_keys.R | 44 ++++++++++++++++++++++----- 7 files changed, 108 insertions(+), 20 deletions(-) create mode 100644 man/default_cdisc_join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index bf59ae1e9..af320ed9b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -98,6 +98,7 @@ export(dataset) export(dataset_connector) export(dataset_connector_file) export(dataset_file) +export(default_cdisc_join_keys) export(example_cdisc_data) export(fun_cdisc_dataset_connector) export(fun_dataset_connector) diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index 9815ccc2f..fbdf1ebb9 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -25,15 +25,21 @@ cdisc_join_keys <- function(...) { } else if ( checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) ) { + # Do nothing. This is handled by `teal_data()` } else { if ((is.null(name) || identical(trimws(name), "")) && is.character(item)) { name <- item } + if (name %in% names(default_cdisc_keys)) { # Set default primary keys keys_list <- default_cdisc_keys[[name]] jk[[name]][[name]] <- keys_list$primary + if (!is.null(keys_list$parent)) { + parents(jk)[[name]] <- keys_list$parent + } + if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { jk[[name]][[keys_list$parent]] <- keys_list$foreign } @@ -43,3 +49,13 @@ cdisc_join_keys <- function(...) { jk } + +#' List containing the default `CDISC` join keys +#' +#' @details +#' This data object is created at loading time from `cdisc_datasets/cdisc_datasets.yaml`. +#' +#' @name default_cdisc_join_keys +#' @docType data +#' @export +NULL diff --git a/R/join_keys.R b/R/join_keys.R index 34cc8e8d7..585b9a918 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -220,22 +220,23 @@ c.join_keys <- function(...) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL - if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { - res <- NextMethod("[", join_keys_obj) - class(res) <- c("join_keys", "list") - return(res) - } else if (length(dataset_1) >= 2) { - res <- lapply(dataset_1, function(x) join_keys_obj[[x]]) - names(res) <- dataset_1 - class(res) <- c("join_keys", "list") - return(res) - } else if (is.null(dataset_1)) { + if (is.null(dataset_1)) { return(join_keys_obj) } - res <- NextMethod("[", join_keys_obj) - class(res) <- c("join_keys", "list") - res + if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { + dataset_1 <- names(join_keys_obj)[dataset_1] + } + + # When retrieving a relationship pair, it will also return the symmetric key + new_jk <- new_join_keys() + for (ix in dataset_1) { + new_jk[[ix]] <- join_keys_obj[[ix]] + } + common_parents_ix <- names(parents(join_keys_obj)) %in% names(new_jk) + if (any(common_parents_ix)) parents(new_jk) <- parents(join_keys_obj)[common_parents_ix] + + new_jk } #' @rdname join_keys diff --git a/R/zzz.R b/R/zzz.R index aa1402424..620002b83 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -6,6 +6,13 @@ ) # nolint assign("default_cdisc_keys", default_cdisc_keys, envir = parent.env(environment())) + # update default_cdisc_join_keys + assign( + "default_cdisc_join_keys", + do.call(cdisc_join_keys, as.list(names(default_cdisc_keys))), + envir = parent.env(environment()) + ) + # Set up the teal logger instance teal.logger::register_logger("teal.data") diff --git a/man/default_cdisc_join_keys.Rd b/man/default_cdisc_join_keys.Rd new file mode 100644 index 000000000..545acaa2a --- /dev/null +++ b/man/default_cdisc_join_keys.Rd @@ -0,0 +1,9 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cdisc_join_keys.R +\docType{data} +\name{default_cdisc_join_keys} +\alias{default_cdisc_join_keys} +\title{List containing the default \code{CDISC} join keys} +\description{ +List containing the default \code{CDISC} join keys +} diff --git a/tests/testthat/test-cdisc_join_keys.R b/tests/testthat/test-cdisc_join_keys.R index 08e37a3e5..a249d86f0 100644 --- a/tests/testthat/test-cdisc_join_keys.R +++ b/tests/testthat/test-cdisc_join_keys.R @@ -71,6 +71,23 @@ test_that("cdisc_join_keys will retrieve known primary and foreign keys", { ) }) +test_that("cdisc_join_keys will set parents of datasets", { + datasets <- names(default_cdisc_keys) + + vapply( + datasets, + function(.x) { + jk <- cdisc_join_keys(.x) + parent_name <- default_cdisc_keys[[.x]][["parent"]] + if (!is.null(parent_name)) { + expect_identical(parent(jk, .x), parent_name) + } + character(0) + }, + character(0) + ) +}) + test_that("cdisc_join_keys will retrieve known primary keys", { datasets <- names(default_cdisc_keys) @@ -92,3 +109,10 @@ test_that("cdisc_join_keys does nothing with TealDataset", { adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) }) + +test_that("default_cdisc_join_keys can get a valid `join_keys` object", { + ds1 <- sample(names(default_cdisc_keys), 3) + result <- default_cdisc_join_keys[ds1] + expect_gte(length(result), 3) + expect_gte(length(parents(result)), 3) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 768a3066e..c8f846372 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -109,18 +109,35 @@ test_that("[.join_keys can subscript multiple values by index or name", { ) expect_length(jk[1:2], 2) - expect_length(jk[c("d1", "d5")], 2) + expect_length(jk[c("d1", "d5")], 4) expect_identical( jk[c("d1", "d5")], structure( - list(d1 = jk[["d1"]], d5 = jk[["d5"]]), + list( + d1 = jk[["d1"]], + d2 = jk[["d2"]], + d5 = jk[["d5"]], + d6 = jk[["d6"]] + ), class = c("join_keys", "list") ) ) - expect_identical(jk[2], structure(list(d2 = jk[["d2"]]), class = c("join_keys", "list"))) - expect_identical(jk[c(1, 3)], structure(list(d1 = jk[["d1"]], d3 = jk[["d3"]]), class = c("join_keys", "list"))) + expect_identical( + jk[2], + structure( + list(d2 = jk[["d2"]], d1 = jk[["d1"]]), + class = c("join_keys", "list") + ) + ) + expect_identical( + jk[c(1, 3)], + structure( + list(d1 = jk[["d1"]], d2 = jk[["d2"]], d3 = jk[["d3"]], d4 = jk[["d4"]]), + class = c("join_keys", "list") + ) + ) }) test_that("[<-.join_keys cannot subscript multiple values", { @@ -394,14 +411,23 @@ test_that("join_keys[ can get all keys for a given dataset", { expect_equal( my_keys[dataset_1 = "d1"], structure( - list("d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T"))), + list( + "d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")), + "d2" = list(d1 = c("C" = "A")), + "d3" = list(d1 = c("B" = "A", "T" = "S")) + ), class = c("join_keys", "list") ) ) + expect_equal( my_keys[dataset_1 = "d3"], structure( - list("d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L"))), + list( + "d1" = list(d3 = c("A" = "B", "S" = "T")), + "d2" = list(d3 = c("C" = "U", "L" = "M")), + "d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L")) + ), class = c("join_keys", "list") ) ) @@ -419,7 +445,11 @@ test_that("join_keys can get all keys from join_keys", { expect_equal( my_keys[dataset_1 = "d1"], structure( - list(d1 = all_keys[["d1"]]), + list( + "d1" = all_keys[["d1"]], + "d2" = list(d1 = all_keys[["d2"]][["d1"]]), + "d3" = list(d1 = all_keys[["d3"]][["d1"]]) + ), class = c("join_keys", "list") ) ) From a1f652abb97e34481bfeeb434f312570682ab4b7 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 10 Nov 2023 12:36:20 +0000 Subject: [PATCH 064/152] [skip actions] Roxygen Man Pages Auto Update --- man/default_cdisc_join_keys.Rd | 3 +++ 1 file changed, 3 insertions(+) diff --git a/man/default_cdisc_join_keys.Rd b/man/default_cdisc_join_keys.Rd index 545acaa2a..7934e89b0 100644 --- a/man/default_cdisc_join_keys.Rd +++ b/man/default_cdisc_join_keys.Rd @@ -7,3 +7,6 @@ \description{ List containing the default \code{CDISC} join keys } +\details{ +This data object is created at loading time from \code{cdisc_datasets/cdisc_datasets.yaml}. +} From 25a48684c84d68133cba6c58c0e0bb994fd19257 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 13:38:46 +0100 Subject: [PATCH 065/152] docs: adds missing method in pkgdown --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 028b096ff..e51e49fd4 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -109,6 +109,7 @@ reference: contents: - datanames - datanames<- + - default_cdisc_join_keys - col_labels - col_labels<- - col_relabel From 37703eb6464741a2b39f91adac0fd1f203449623 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 13:45:15 +0100 Subject: [PATCH 066/152] feat: ensures dag in parents --- R/parents.R | 5 ++ tests/testthat/test-parents.R | 117 +++++++++++++++++++++------------- 2 files changed, 79 insertions(+), 43 deletions(-) diff --git a/R/parents.R b/R/parents.R index 042ad2d93..c48d0b92f 100644 --- a/R/parents.R +++ b/R/parents.R @@ -80,6 +80,11 @@ parents.join_keys <- function(join_keys_obj) { old_parents[[dataset]] <- value[[dataset]] } } + + if (is_dag(old_parents)) { + stop("Cycle detected in a parent and child dataset graph.") + } + attr(join_keys_obj, "__parents__") <- old_parents # nolint: object_name_linter join_keys_obj } diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 43382dd20..e237dc722 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -1,3 +1,8 @@ +# ----------------------------------------------------------------------------- +# +# parents() +# + test_that("parents will return empty list when empty/not set", { jk <- join_keys() expect_identical(parents(jk), list()) @@ -8,6 +13,30 @@ test_that("parents will return empty NULL when there is no parent", { expect_null(parents(jk)[["ds1"]]) }) +testthat::test_that("parents returns a list of all parents", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) + testthat::expect_identical(parents(jk), list(df1 = character(0), df2 = "df1")) +}) + +testthat::test_that("parents returns an empty list when no parents are present", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_identical(parents(jk), list()) +}) + +testthat::test_that("parents throws error when dataname input is provided", { + jk <- join_keys() + join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) + testthat::expect_error(parents(jk, "df1"), "unused argument \\(\"df1\"\\)") +}) + +# ----------------------------------------------------------------------------- +# +# parents<- +# + test_that("parents<- will add to parents attribute using `[` notation", { jk <- join_keys() parents(jk)["ds1"] <- "ds2" @@ -52,30 +81,20 @@ test_that("parents<- will add to parents attribute using list, `[` and `[[` nota expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4", ds5 = "ds6", ds7 = "ds8")) }) -test_that("assert_parent_child will detect empty keys", { - jk <- join_keys() - jk[["ds1"]][["ds2"]] <- character(0) - parents(jk) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk)) -}) - -test_that("assert_parent_child will detect invalid key pairs", { - jk <- join_keys() - jk[["ds1"]][["ds2"]] <- "key1" - jk[["ds2"]][["ds1"]] <- character(0) - parents(jk) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk)) - - jk2 <- join_keys() - jk2[["ds2"]][["ds1"]] <- "key1" - jk2[["ds1"]][["ds2"]] <- character(0) - parents(jk2) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk2)) -}) - -test_that("assert_parent_child will skip empty join_keys", { - jk <- join_keys() - expect_silent(assert_parent_child(jk)) +test_that("parents<- ensures it is a directed acyclical graph (DAG)", { + cyclic_jk <- join_keys( + join_key("a", "b", "id"), + join_key("b", "c", "id"), + join_key("c", "a", "id") + ) + expect_error( + parents(cyclic_jk) <- list( + a = "b", + b = "c", + c = "a" + ), + "Cycle detected" + ) }) testthat::test_that("parents<- throws error when overwriting the parent value with a different value", { @@ -92,6 +111,11 @@ testthat::test_that("parents<- works when overwriting the parent value with the testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) }) +# ----------------------------------------------------------------------------- +# +# parent() +# + testthat::test_that("parent returns the parent name of the dataset", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) @@ -108,25 +132,6 @@ testthat::test_that("parent returns NULL when dataset is not found or not passed testthat::expect_null(parent(jk, "df3")) }) -testthat::test_that("get_parents returns a list of all parents", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_identical(parents(jk), list(df1 = character(0), df2 = "df1")) -}) - -testthat::test_that("parents returns an empty list when no parents are present", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_identical(parents(jk), list()) -}) - -testthat::test_that("parents throws error when dataname input is provided", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_error(parents(jk, "df1"), "unused argument \\(\"df1\"\\)") -}) - # ----------------------------------------------------------------------------- # # update_keys_given_parents @@ -167,6 +172,32 @@ testthat::test_that("update_keys_given_parents updates the join_keys when presen # # assert_parent_child +test_that("assert_parent_child will detect empty keys", { + jk <- join_keys() + jk[["ds1"]][["ds2"]] <- character(0) + parents(jk) <- list(ds1 = "ds2") + expect_error(assert_parent_child(jk)) +}) + +test_that("assert_parent_child will detect invalid key pairs", { + jk <- join_keys() + jk[["ds1"]][["ds2"]] <- "key1" + jk[["ds2"]][["ds1"]] <- character(0) + parents(jk) <- list(ds1 = "ds2") + expect_error(assert_parent_child(jk)) + + jk2 <- join_keys() + jk2[["ds2"]][["ds1"]] <- "key1" + jk2[["ds1"]][["ds2"]] <- character(0) + parents(jk2) <- list(ds1 = "ds2") + expect_error(assert_parent_child(jk2)) +}) + +test_that("assert_parent_child will skip empty join_keys", { + jk <- join_keys() + expect_silent(assert_parent_child(jk)) +}) + testthat::test_that("assert_parent_child does nothing if no parents are present", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) From 3571a0c8af84bce80bbdf91a8325f9e7e2d03809 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 17:33:47 +0100 Subject: [PATCH 067/152] remove use of NextMethod inside [[<-.join_keys --- R/join_keys.R | 54 +++++++++++++++++++-------------- tests/testthat/test-join_keys.R | 6 ++-- 2 files changed, 33 insertions(+), 27 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 585b9a918..3d0ed16aa 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -330,6 +330,10 @@ c.join_keys <- function(...) { #' jk[["ds2"]][["ds3"]] <- NULL #' jk `[[<-.join_keys` <- function(join_keys_obj, dataset_1, value) { + if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { + dataset_1 <- names(join_keys_obj)[[dataset_1]] + } + checkmate::assert_string(dataset_1) # Accepting 1 subscript with valid `value` formal @@ -343,33 +347,24 @@ c.join_keys <- function(...) { names(norm_value) <- names(value) value <- norm_value - # Keep original parameters as variables will be overwritten for `NextMethod` call - original_value <- value - ds1 <- dataset_1 + # + # Remove classes to use list-based get/assign operations + join_keys_obj <- unclass(join_keys_obj) - # In case an pair is removed, also remove the symmetric pair + # In case a pair is removed, also remove the symmetric pair removed_names <- setdiff(names(join_keys_obj[[dataset_1]]), names(value)) if (length(removed_names) > 0) { - for (.x in removed_names) { - value <- join_keys_obj[[.x]] - value[[ds1]] <- NULL - dataset_1 <- .x - join_keys_obj <- NextMethod("[[<-", join_keys_obj) - } - - # Restore original values - dataset_1 <- ds1 - value <- original_value + for (.x in removed_names) join_keys_obj[[.x]][[dataset_1]] <- NULL } - join_keys_obj <- NextMethod("[[<-", join_keys_obj) + join_keys_obj[[dataset_1]] <- value # Iterate on all new values to create symmetrical pair - for (ds2 in names(original_value)) { - if (ds2 == ds1) next + for (ds2 in names(value)) { + if (ds2 == dataset_1) next - value <- join_keys_obj[[ds2]] %||% list() - new_value <- original_value[[ds2]] + keep_value <- join_keys_obj[[ds2]] %||% list() + new_value <- value[[ds2]] if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { new_value <- setNames(new_value, new_value) @@ -380,12 +375,25 @@ c.join_keys <- function(...) { new_value <- setNames(names(new_value), new_value) } - # Change variables for NextMethod call - dataset_1 <- ds2 - value[[ds1]] <- new_value - join_keys_obj <- NextMethod("[[<-", join_keys_obj) + keep_value[[dataset_1]] <- new_value + + # Assign symmetrical + join_keys_obj[[ds2]] <- keep_value } + # Remove NULL or empty keys + empty_ix <- vapply( + join_keys_obj, + function(.x) is.null(.x) || length(.x) == 0, + logical(1) + ) + preserve_attr <- attributes(join_keys_obj)[!names(attributes(join_keys_obj)) %in% "names"] + join_keys_obj <- join_keys_obj[!empty_ix] + attributes(join_keys_obj) <- modifyList(attributes(join_keys_obj), preserve_attr) + + # + # restore class + class(join_keys_obj) <- c("join_keys", "list") join_keys_obj } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index c8f846372..5b7a68453 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -187,10 +187,8 @@ test_that("[[<-.join_keys removes keys with NULL", { expect_identical( jk, structure( - list( - d1 = structure(list(), names = character(0)), - d2 = structure(list(), names = character(0)) - ), + list(), + names = character(0), class = c("join_keys", "list") ) ) From 72427dafebff68a1a17dfec063bc7394a58209aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 10 Nov 2023 17:49:33 +0100 Subject: [PATCH 068/152] feat: adds names<-.join_keys changes names at first and second levels --- NAMESPACE | 1 + R/join_keys.R | 22 ++++++++++++++++++++++ man/names-set-.join_keys.Rd | 17 +++++++++++++++++ tests/testthat/test-join_keys.R | 25 +++++++++++++++++++++++++ 4 files changed, 65 insertions(+) create mode 100644 man/names-set-.join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index af320ed9b..442f33751 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ S3method("[<-",join_keys) S3method("[[<-",join_keys) S3method("join_keys<-",join_keys) S3method("join_keys<-",teal_data) +S3method("names<-",join_keys) S3method("parents<-",join_keys) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) diff --git a/R/join_keys.R b/R/join_keys.R index 3d0ed16aa..5bb590465 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -196,6 +196,28 @@ c.join_keys <- function(...) { join_keys_obj } +#' The Names of an `join_keys` Object +#' @inheritParams base::`names<-` +#' @export +`names<-.join_keys` <- function(x, value) { + x <- unclass(x) + # Update inner keys + for (old_name in setdiff(names(x), value)) { + old_entry <- x[[old_name]] + new_name <- value[names(x) == old_name] + + # Change 2nd-tier first + for (sub_name in names(old_entry)) { + names(x[[sub_name]])[names(x[[sub_name]]) == old_name] <- new_name + } + + # Change in first tier + names(x)[names(x) == old_name] <- new_name + } + class(x) <- c("join_keys", "list") + x +} + #' @rdname join_keys #' @details #' Getter for `join_keys` that returns the relationship between pairs of datasets. diff --git a/man/names-set-.join_keys.Rd b/man/names-set-.join_keys.Rd new file mode 100644 index 000000000..892694a8d --- /dev/null +++ b/man/names-set-.join_keys.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{names<-.join_keys} +\alias{names<-.join_keys} +\title{The Names of an \code{join_keys} Object} +\usage{ +\method{names}{join_keys}(x) <- value +} +\arguments{ +\item{x}{an \R object.} + +\item{value}{a character vector of up to the same length as \code{x}, or + \code{NULL}.} +} +\description{ +The Names of an \code{join_keys} Object +} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 5b7a68453..18688fe24 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -213,6 +213,31 @@ test_that("[[<-.join_keys removes keys with NULL and keeps existing", { expect_length(jk, 4) }) +# ----------------------------------------------------------------------------- +# +# names<-.join_keys +# + +test_that("names<-.join_keys will replace names at first and second levels", { + jk <- join_keys( + join_key("a", keys = "k4"), + join_key("a", "b", "k1"), + join_key("a", "c", "k3"), + join_key("d", "b", "k2"), + ) + + expect_named(jk, c("a", "b", "c", "d"), ignore.order = TRUE) + + names(jk)[1:2] <- c("aa", "bb") + + expect_named(jk, c("aa", "bb", "c", "d"), ignore.order = TRUE) + + expect_identical(jk[["aa"]][["c"]], c("k3" = "k3")) + expect_identical(jk[["aa"]][["bb"]], c("k1" = "k1")) + expect_identical(jk[["aa"]][["aa"]], c("k4" = "k4")) + + expect_length(names(jk), 4) +}) # ----------------------------------------------------------------------------- # From a3c82b7ce03da54aa01abba1a8f6495f37f9b10f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 13 Nov 2023 16:27:14 +0100 Subject: [PATCH 069/152] fix: [.join_keys subset only keeps parent foreign keys --- R/join_keys.R | 11 +++++++- tests/testthat/test-join_keys.R | 45 ++++++++++++++++++++++++++++++++- 2 files changed, 54 insertions(+), 2 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 5bb590465..63bcee604 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -253,8 +253,17 @@ c.join_keys <- function(...) { # When retrieving a relationship pair, it will also return the symmetric key new_jk <- new_join_keys() for (ix in dataset_1) { - new_jk[[ix]] <- join_keys_obj[[ix]] + ix_parent <- parent(join_keys_obj, ix) + + ix_valid_names <- names(join_keys_obj[[ix]]) %in% c(ix_parent, dataset_1) + new_jk[[ix]] <- join_keys_obj[[ix]][ix_valid_names] + + # Add primary key of parent + if (length(ix_parent) > 0) { + new_jk[[ix_parent]][[ix_parent]] <- join_keys_obj[[ix_parent]][[ix_parent]] + } } + common_parents_ix <- names(parents(join_keys_obj)) %in% names(new_jk) if (any(common_parents_ix)) parents(new_jk) <- parents(join_keys_obj)[common_parents_ix] diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 18688fe24..431bc132b 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -50,7 +50,7 @@ test_that("c.join_keys to set via multiple lists that progressively merge object # ----------------------------------------------------------------------------- # -# [[ and [[<- +# [, [<-, [[ and [[<- # test_that("[[<-.join_keys creates symmetric relationship", { jk <- join_keys() @@ -140,6 +140,49 @@ test_that("[.join_keys can subscript multiple values by index or name", { ) }) +test_that("[.join_keys only keeps parents and common keys in index", { + jk <- join_keys( + join_key("d1", keys = "1"), + join_key("d2", keys = "2"), + join_key("d3", keys = "3"), + join_key("d4", keys = "4"), + join_key("d5", keys = "5"), + # + join_key("d1", "d2", c("1-2" = "2-1")), + join_key("d2", "d3", c("2-3" = "3-2")), + join_key("d3", "d4", c("3-4" = "4-3")), + join_key("d4", "d5", c("4-5" = "5-4")) + ) + + parents(jk) <- list( + "d2" = "d1", + "d3" = "d1", + "d4" = "d1", + "d5" = "d1" + ) + + # Include parent + expect_length(jk[c("d1")], 1) + expect_length(jk[c("d2")], 2) + expect_length(jk[c("d2", "d3")], 3) + expect_length(jk[c(2, 3, 4)], 4) + expect_length(jk[c(1, 3)], 2) + expect_length(jk[c("d1", "d3")], 2) + + # Only keeps relevant parents + expect_length(parents(jk[c("d2", "d3")]), 2) + expect_equal(parents(jk[c("d2", "d3")]), list("d2" = "d1", "d3" = "d1")) + + # Checks names + expect_named(jk[c("d2", "d3")], c("d1", "d2", "d3"), ignore.order = TRUE) + # Deep check + sliced_jk <- jk[c("d2", "d3")] + + expect_identical(sliced_jk[["d1"]], list(d2 = jk[["d1"]][["d2"]], d1 = jk[["d1"]][["d1"]])) + expect_identical(sliced_jk[["d2"]], list(d2 = jk[["d2"]][["d2"]], d1 = jk[["d2"]][["d1"]], d3 = jk[["d2"]][["d3"]])) + expect_identical(sliced_jk[["d3"]], list(d3 = jk[["d3"]][["d3"]], d2 = jk[["d3"]][["d2"]])) +}) + test_that("[<-.join_keys cannot subscript multiple values", { jk <- join_keys( join_key("d1", "d2", c("A" = "B", "C")), From 033bb49744a1773f6362290279fccc9aa0e4cbef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 13 Nov 2023 16:30:16 +0100 Subject: [PATCH 070/152] pr: improve on quality test of default_cdisc_join_keys --- tests/testthat/test-cdisc_join_keys.R | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-cdisc_join_keys.R b/tests/testthat/test-cdisc_join_keys.R index a249d86f0..388a1e7ae 100644 --- a/tests/testthat/test-cdisc_join_keys.R +++ b/tests/testthat/test-cdisc_join_keys.R @@ -111,8 +111,13 @@ test_that("cdisc_join_keys does nothing with TealDataset", { }) test_that("default_cdisc_join_keys can get a valid `join_keys` object", { - ds1 <- sample(names(default_cdisc_keys), 3) + ds1 <- c("ADTTE", "ADEX", "ADRS") result <- default_cdisc_join_keys[ds1] - expect_gte(length(result), 3) - expect_gte(length(parents(result)), 3) + expect_length(result, 4) + expect_length(parents(result), 3) + + ds2 <- c("ADTTE", "ADSL") + result2 <- default_cdisc_join_keys[ds2] + expect_length(result2, 2) + expect_length(parents(result2), 1) }) From 19f4c8bb3f34c93344af5828ac5be520b085eb35 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 13 Nov 2023 16:37:53 +0100 Subject: [PATCH 071/152] pr: break join_key tests into smaller chunks --- tests/testthat/test-join_key.R | 25 ++++++++++++++++--------- 1 file changed, 16 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-join_key.R b/tests/testthat/test-join_key.R index 9a099d771..3cfcc576b 100644 --- a/tests/testthat/test-join_key.R +++ b/tests/testthat/test-join_key.R @@ -1,19 +1,26 @@ -test_that("join_key throws error with invalid keys arguments", { - # invalid types +test_that("join_key throws error with NULL keys", { expect_error(join_key("d1", "d2", keys = NULL)) +}) + +test_that("join_key throws error with NA keys", { + expect_error(join_key("d1", "d2", keys = NA)) + expect_error(join_key("d1", "d2", keys = c("X" = "A", "B", NA))) +}) + +test_that("join_key throws error with numeric keys", { expect_error(join_key("d1", "d2", keys = 1:10)) +}) - # not fully named - expect_error(join_key("d1", "d2", keys = c("X" = "A", "B")), NA) - keys <- c("A", "C" = "B") - names(keys)[1] <- "" - expect_error(join_key("d1", "d2", keys), NA) +test_that("join_key throws error with data keys", { + expect_error(join_key("d1", "d2", keys = Sys.time() + seq(1, 5))) +}) - # duplicates in names or values +test_that("join_key throws error with invalid duplicate names in keys/values", { expect_error(join_key("d1", "d2", keys = c("A" = "A", "A" = "B"))) expect_error(join_key("d1", "d2", keys = c("C" = "A", "D" = "A"))) +}) - # names(keys)!= keys if datasets are the same +test_that("join_key throws error with invalid primary keys (names != keys)", { expect_error(join_key("d1", "d1", keys = c("B" = "A", "A" = "B"))) expect_error(join_key("d1", keys = c("B" = "A", "A" = "B"))) }) From e663b66783f1f67332dd235e81f80a5e51d0152f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 13 Nov 2023 17:55:34 +0100 Subject: [PATCH 072/152] pr: move helpers to R folder --- R/join_keys.R | 6 +- .../testhat-helpers.R | 53 ++++++++++---- man/join_keys.Rd | 2 +- man/local_join_keys.Rd | 19 +++++ man/local_teal_data.Rd | 14 ++++ man/test_join_keys_add.Rd | 29 ++++++++ man/test_join_keys_bare.Rd | 20 ++++++ man/test_join_keys_combinatory.Rd | 19 +++++ tests/testthat/helper-compare.R | 3 +- tests/testthat/test-join_keys.R | 71 ++++++++++++------- 10 files changed, 197 insertions(+), 39 deletions(-) rename tests/testthat/helper-get_join_keys.R => R/testhat-helpers.R (70%) create mode 100644 man/local_join_keys.Rd create mode 100644 man/local_teal_data.Rd create mode 100644 man/test_join_keys_add.Rd create mode 100644 man/test_join_keys_bare.Rd create mode 100644 man/test_join_keys_combinatory.Rd diff --git a/R/join_keys.R b/R/join_keys.R index 63bcee604..836673b08 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -238,7 +238,7 @@ c.join_keys <- function(...) { #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL) { +`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, keep_all_foreign_keys = FALSE) { # Protection against missing being passed through functions if (missing(dataset_1)) dataset_1 <- NULL @@ -256,6 +256,10 @@ c.join_keys <- function(...) { ix_parent <- parent(join_keys_obj, ix) ix_valid_names <- names(join_keys_obj[[ix]]) %in% c(ix_parent, dataset_1) + if (keep_all_foreign_keys) { + ix_valid_names <- rep(TRUE, length(names(join_keys_obj[[ix]]))) + } + new_jk[[ix]] <- join_keys_obj[[ix]][ix_valid_names] # Add primary key of parent diff --git a/tests/testthat/helper-get_join_keys.R b/R/testhat-helpers.R similarity index 70% rename from tests/testthat/helper-get_join_keys.R rename to R/testhat-helpers.R index 190e9e684..c529e2a11 100644 --- a/tests/testthat/helper-get_join_keys.R +++ b/R/testhat-helpers.R @@ -1,5 +1,7 @@ #' Generate a teal_data dataset with sample data and join_keys -helper_generator_teal_data <- function() { +#' +#' @return `teal_data` +local_teal_data <- function() { iris2 <- iris iris2$id <- rnorm(NROW(iris2)) iris2$id <- apply(iris2, 1, rlang::hash) @@ -9,19 +11,30 @@ helper_generator_teal_data <- function() { ds2 = iris2 ), code = "ds1 <- iris2; ds2 <- iris2", - join_keys = helper_generator_join_keys("ds1", keys = c("id")) + join_keys = local_join_keys("ds1", keys = c("id")) ) } #' Generate a join_keys -helper_generator_join_keys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint +#' +#' @param dataset_1 `character(1)` name of dataset to add. +#' @param keys `character(1)` primary key for `dataset_1` (optionally named). +#' +#' @return `join_keys` object with a primary key +local_join_keys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint join_keys( join_key(dataset_1, keys = keys) ) } #' Test suite for default join_keys generated by helper -helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { +#' +#' @param obj Object with `join_keys` to perform operations (can be `join_keys` +#' or `teal_data`). It should only contain a primary key. +#' @param dataset_1 `character(1)` name of existing dataset to test. +#' +#' @return `obj` itself without any modifications +test_join_keys_bare <- function(obj, dataset_1 = "ds1") { jk <- join_keys(obj) expect_s3_class(jk, class = c("join_keys", "list")) @@ -32,11 +45,19 @@ helper_test_getter_join_keys <- function(obj, dataset_1 = "ds1") { } #' Test suite for join_keys after manual adding a primary key -helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter - dataset_1 = "ds1", - new_dataset_1 = "ds2", - new_keys = c("id")) { - obj <- helper_test_getter_join_keys(obj, dataset_1) +#' +#' @param obj Object with `join_keys` to perform operations (can be `join_keys` +#' or `teal_data`) +#' @param dataset_1 `character(1)` name of existing dataset. +#' @param new_dataset_1 `character(1)` name of new dataset to add. +#' @param new_keys +#' +#' @return `obj` itself modified with a new foreign key. +test_join_keys_add <- function(obj, + dataset_1 = "ds1", + new_dataset_1 = "ds2", + new_keys = c("id")) { + obj <- test_join_keys_bare(obj, dataset_1) join_keys(obj)[new_dataset_1] <- c(new_keys) # primary key jk <- join_keys(obj) @@ -47,9 +68,17 @@ helper_test_getter_join_keys_add <- function(obj, # nolint: object_length_linter expect_length(jk[[new_dataset_1]][[new_dataset_1]], 1) } -#' Test suite for join_keys after manual adding a primary key -helper_test_setter_mass_join_keys_add <- function(obj) { # nolint: object_length_linter - obj <- helper_test_getter_join_keys(obj, "ds1") +#' Test suite for join_keys that performs a mass modification +#' +#' The goal of this helper is to modify the `join_keys` with all variants of a +#' valid foreign key. +#' +#' @param obj Object with `join_keys` to perform operations (can be `join_keys` +#' or `teal_data`) +#' +#' @return `obj` itself modified with a new foreign key. +test_join_keys_combinatory <- function(obj) { + obj <- test_join_keys_bare(obj, "ds1") counter <- 2 .ds <- function(add = 1, prefix = "ds") { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 640f6d1a8..f00ea7c6a 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -36,7 +36,7 @@ join_keys(join_keys_obj) <- value \method{join_keys}{teal_data}(join_keys_obj) <- value -\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL) +\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, keep_all_foreign_keys = FALSE) \method{[}{join_keys}(join_keys_obj, dataset_1) <- value diff --git a/man/local_join_keys.Rd b/man/local_join_keys.Rd new file mode 100644 index 000000000..712f20763 --- /dev/null +++ b/man/local_join_keys.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{local_join_keys} +\alias{local_join_keys} +\title{Generate a join_keys} +\usage{ +local_join_keys(dataset_1 = "ds1", keys = c("id")) +} +\arguments{ +\item{dataset_1}{\code{character(1)} name of dataset to add.} + +\item{keys}{\code{character(1)} primary key for \code{dataset_1} (optionally named).} +} +\value{ +\code{join_keys} object with a primary key +} +\description{ +Generate a join_keys +} diff --git a/man/local_teal_data.Rd b/man/local_teal_data.Rd new file mode 100644 index 000000000..9bb037b9d --- /dev/null +++ b/man/local_teal_data.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{local_teal_data} +\alias{local_teal_data} +\title{Generate a teal_data dataset with sample data and join_keys} +\usage{ +local_teal_data() +} +\value{ +\code{teal_data} +} +\description{ +Generate a teal_data dataset with sample data and join_keys +} diff --git a/man/test_join_keys_add.Rd b/man/test_join_keys_add.Rd new file mode 100644 index 000000000..78c44a796 --- /dev/null +++ b/man/test_join_keys_add.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{test_join_keys_add} +\alias{test_join_keys_add} +\title{Test suite for join_keys after manual adding a primary key} +\usage{ +test_join_keys_add( + obj, + dataset_1 = "ds1", + new_dataset_1 = "ds2", + new_keys = c("id") +) +} +\arguments{ +\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} +or \code{teal_data})} + +\item{dataset_1}{\code{character(1)} name of existing dataset.} + +\item{new_dataset_1}{\code{character(1)} name of new dataset to add.} + +\item{new_keys}{} +} +\value{ +\code{obj} itself modified with a new foreign key. +} +\description{ +Test suite for join_keys after manual adding a primary key +} diff --git a/man/test_join_keys_bare.Rd b/man/test_join_keys_bare.Rd new file mode 100644 index 000000000..7c8cef2aa --- /dev/null +++ b/man/test_join_keys_bare.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{test_join_keys_bare} +\alias{test_join_keys_bare} +\title{Test suite for default join_keys generated by helper} +\usage{ +test_join_keys_bare(obj, dataset_1 = "ds1") +} +\arguments{ +\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} +or \code{teal_data}). It should only contain a primary key.} + +\item{dataset_1}{\code{character(1)} name of existing dataset to test.} +} +\value{ +\code{obj} itself without any modifications +} +\description{ +Test suite for default join_keys generated by helper +} diff --git a/man/test_join_keys_combinatory.Rd b/man/test_join_keys_combinatory.Rd new file mode 100644 index 000000000..ceccf7a26 --- /dev/null +++ b/man/test_join_keys_combinatory.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{test_join_keys_combinatory} +\alias{test_join_keys_combinatory} +\title{Test suite for join_keys that performs a mass modification} +\usage{ +test_join_keys_combinatory(obj) +} +\arguments{ +\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} +or \code{teal_data})} +} +\value{ +\code{obj} itself modified with a new foreign key. +} +\description{ +The goal of this helper is to modify the \code{join_keys} with all variants of a +valid foreign key. +} diff --git a/tests/testthat/helper-compare.R b/tests/testthat/helper-compare.R index 5056956c3..ead2439e8 100644 --- a/tests/testthat/helper-compare.R +++ b/tests/testthat/helper-compare.R @@ -5,6 +5,8 @@ #' #' `expect_identical(x, y, list_as_map = TRUE)` #' +#' note: this needs to be located in an environment that contains `testthat` +#' namespace, as it extends a S3 method of that package. #' #' @inheritParams testthat::compare #' @@ -32,5 +34,4 @@ compare.join_keys <- function(x, y, ...) { compare(as_map(x), as_map(y)) } - .S3method("compare", "join_keys", compare.join_keys) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 431bc132b..1d6c12845 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -1,35 +1,35 @@ test_that("join_keys.teal_data will successfully obtain object from teal_data", { - obj <- helper_generator_teal_data() + obj <- local_teal_data() expect_identical(obj@join_keys, join_keys(obj)) - helper_test_getter_join_keys(obj, "ds1") + test_join_keys_bare(obj, "ds1") }) test_that("join_keys.join_keys will return itself", { - obj <- helper_generator_join_keys() + obj <- local_join_keys() expect_identical(obj, join_keys(obj)) - helper_test_getter_join_keys(obj, "ds1") + test_join_keys_bare(obj, "ds1") }) test_that("join_keys<-.teal_data shared test to setter (in mass)", { - obj <- helper_generator_teal_data() - helper_test_setter_mass_join_keys_add(obj) + obj <- local_teal_data() + test_join_keys_combinatory(obj) }) test_that("join_keys<-.join_keys shared test to setter (in mass)", { - obj <- helper_generator_join_keys() - helper_test_setter_mass_join_keys_add(obj) + obj <- local_join_keys() + test_join_keys_combinatory(obj) }) test_that("join_keys<-.teal_data shared test to getter and setter", { - obj <- helper_generator_teal_data() - helper_test_getter_join_keys_add(obj, "ds1", "ds2") + obj <- local_teal_data() + test_join_keys_add(obj, "ds1", "ds2") }) test_that("join_keys<-.join_keys shared test to getter and setter", { - obj <- helper_generator_join_keys() - helper_test_getter_join_keys_add(obj, "ds1", "ds2") + obj <- local_join_keys() + test_join_keys_add(obj, "ds1", "ds2") }) test_that("join_keys<-.join_keys to set via a join_key_set object", { @@ -103,16 +103,22 @@ test_that("[<-.join_keys is equivalent to using the constructor", { test_that("[.join_keys can subscript multiple values by index or name", { jk <- join_keys( + join_key("d1", "d1", c("A")), join_key("d1", "d2", c("A" = "B", "C")), join_key("d3", "d4", c("D", "E")), join_key("d5", "d6", c("F", "K" = "k")) ) expect_length(jk[1:2], 2) - expect_length(jk[c("d1", "d5")], 4) + expect_identical(jk[1:2], jk[c("d1", "d2")]) + expect_identical(jk[c(1, 5)], jk[c("d1", "d5")]) + + expect_length(jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], 4) + expect_length(jk[c("d1", "d5")], 1) + expect_equal(jk[c("d1", "d5")], list(d1 = list(d1 = c("A" = "A")))) expect_identical( - jk[c("d1", "d5")], + jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], structure( list( d1 = jk[["d1"]], @@ -125,19 +131,33 @@ test_that("[.join_keys can subscript multiple values by index or name", { ) expect_identical( - jk[2], + jk[1], structure( - list(d2 = jk[["d2"]], d1 = jk[["d1"]]), + list(d1 = jk[["d1"]]["d1"]), class = c("join_keys", "list") ) ) + expect_identical( - jk[c(1, 3)], + jk[c(1, 3), keep_all_foreign_keys = TRUE], structure( list(d1 = jk[["d1"]], d2 = jk[["d2"]], d3 = jk[["d3"]], d4 = jk[["d4"]]), class = c("join_keys", "list") ) ) + + parents(jk) <- list("d2" = "d1") + expect_identical( + jk[2], + structure( + list( + d2 = jk[["d2"]], + d1 = list(d2 = jk[["d1"]][["d2"]], d1 = jk[["d1"]][["d1"]]) + ), + class = c("join_keys", "list"), + "__parents__" = parents(jk) + ) + ) }) test_that("[.join_keys only keeps parents and common keys in index", { @@ -474,8 +494,12 @@ test_that("join_keys[ can get all keys for a given dataset", { join_key("d1", "d3", c("A" = "B", "S" = "T")), join_key("d2", "d3", c("C" = "U", "L" = "M")) ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") + + expect_length(my_keys[dataset_1 = "d1"], 0) + expect_equal( - my_keys[dataset_1 = "d1"], + my_keys[dataset_1 = "d1", keep_all_foreign_keys = TRUE], structure( list( "d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")), @@ -491,8 +515,7 @@ test_that("join_keys[ can get all keys for a given dataset", { structure( list( "d1" = list(d3 = c("A" = "B", "S" = "T")), - "d2" = list(d3 = c("C" = "U", "L" = "M")), - "d3" = list(d1 = c("B" = "A", "T" = "S"), d2 = c("U" = "C", "M" = "L")) + "d3" = list(d1 = c("B" = "A", "T" = "S")) ), class = c("join_keys", "list") ) @@ -509,12 +532,12 @@ test_that("join_keys can get all keys from join_keys", { all_keys <- my_keys expect_equal(names(all_keys), c("d1", "d2", "d3")) expect_equal( - my_keys[dataset_1 = "d1"], + my_keys[c("d1", "d2", "d3")], structure( list( - "d1" = all_keys[["d1"]], - "d2" = list(d1 = all_keys[["d2"]][["d1"]]), - "d3" = list(d1 = all_keys[["d3"]][["d1"]]) + "d1" = list(d2 = all_keys[["d1"]][["d2"]], d3 = all_keys[["d1"]][["d3"]]), + "d2" = list(d1 = all_keys[["d2"]][["d1"]], d3 = all_keys[["d2"]][["d3"]]), + "d3" = list(d1 = all_keys[["d3"]][["d1"]], d2 = all_keys[["d3"]][["d2"]]) ), class = c("join_keys", "list") ) From 860018d047b4bfe7221d6d3c7ab4dbcd5a1f3e04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Mon, 13 Nov 2023 18:28:10 +0100 Subject: [PATCH 073/152] fix: join_keys setter for teal_data --- R/join_keys.R | 5 ---- tests/testthat/test-join_keys.R | 49 +++++++++++++++++++++++++++++++-- 2 files changed, 46 insertions(+), 8 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 836673b08..0d83dee51 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -187,11 +187,6 @@ c.join_keys <- function(...) { return(join_keys_obj) } - if (checkmate::test_class(value, c("join_keys", "list"))) { - join_keys_obj@join_keys <- merge_join_keys(join_keys_obj@join_keys, value) - return(join_keys_obj) - } - join_keys(join_keys_obj@join_keys) <- value join_keys_obj } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 1d6c12845..778ba44ab 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -48,6 +48,41 @@ test_that("c.join_keys to set via multiple lists that progressively merge object expect_length(obj, 8) }) +test_that("join_keys<-.join_keys overwrites existing join_keys", { + jk <- join_keys( + join_key("d1", "d2", c("A" = "B", "C" = "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + + join_keys(jk) <- join_keys( + join_key("d1", "d1", "primary") + ) + + expect_length(jk, 1) + expect_identical(jk[["d1"]], list(d1 = c("primary" = "primary"))) +}) + +test_that("join_keys<-.teal_data overwrites existing join_keys", { + td <- teal_data( + iris = iris, + join_keys = join_keys( + join_key("d1", "d2", c("A" = "B", "C" = "C")), + join_key("d3", "d4", c("D", "E")), + join_key("d5", "d6", c("F", "K" = "k")) + ) + ) + + expect_length(join_keys(td), 6) + + join_keys(td) <- join_keys( + join_key("d1", "d1", "primary") + ) + + expect_length(join_keys(td), 1) + expect_identical(join_keys(td)[["d1"]], list(d1 = c("primary" = "primary"))) +}) + # ----------------------------------------------------------------------------- # # [, [<-, [[ and [[<- @@ -115,7 +150,13 @@ test_that("[.join_keys can subscript multiple values by index or name", { expect_length(jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], 4) expect_length(jk[c("d1", "d5")], 1) - expect_equal(jk[c("d1", "d5")], list(d1 = list(d1 = c("A" = "A")))) + expect_equal( + jk[c("d1", "d5")], + structure( + list(d1 = list(d1 = c("A" = "A"))), + class = c("join_keys", "list") + ) + ) expect_identical( jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], @@ -506,7 +547,8 @@ test_that("join_keys[ can get all keys for a given dataset", { "d2" = list(d1 = c("C" = "A")), "d3" = list(d1 = c("B" = "A", "T" = "S")) ), - class = c("join_keys", "list") + class = c("join_keys", "list"), + "__parents__" = list("d2" = "d1", "d3" = "d1") ) ) @@ -517,7 +559,8 @@ test_that("join_keys[ can get all keys for a given dataset", { "d1" = list(d3 = c("A" = "B", "S" = "T")), "d3" = list(d1 = c("B" = "A", "T" = "S")) ), - class = c("join_keys", "list") + class = c("join_keys", "list"), + "__parents__" = list("d3" = "d1") ) ) }) From 2922b0e0015b43b48f36ec5ab137851b3237c245 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 01:42:50 +0100 Subject: [PATCH 074/152] fix: improve on parents handling (check and subsetting) --- R/cdisc_data.R | 4 +- R/cdisc_join_keys.R | 7 +- R/join_keys.R | 26 ++++++- R/parents.R | 4 + tests/testthat/test-cdisc_data.R | 2 +- tests/testthat/test-join_keys.R | 47 +++++++----- tests/testthat/test-parents.R | 124 +++++++++++++++---------------- 7 files changed, 122 insertions(+), 92 deletions(-) diff --git a/R/cdisc_data.R b/R/cdisc_data.R index 2ac7f7fe4..7381cac0e 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -90,7 +90,9 @@ deprecated_join_keys_extract <- function(data_objects, join_keys) { stop("Cycle detected in a parent and child dataset graph.") } - parents(join_keys) <- new_parents + # Keep non-check setting of parents (this will be removed in refactor) + attr(join_keys, "__parents__") <- new_parents + # parents(join_keys) <- new_parents join_keys <- update_keys_given_parents(join_keys) join_keys diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index fbdf1ebb9..2047207d0 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -37,12 +37,11 @@ cdisc_join_keys <- function(...) { jk[[name]][[name]] <- keys_list$primary if (!is.null(keys_list$parent)) { + if (!is.null(keys_list$foreign)) { + jk[[name]][[keys_list$parent]] <- keys_list$foreign + } parents(jk)[[name]] <- keys_list$parent } - - if (!is.null(keys_list$parent) && !is.null(keys_list$foreign)) { - jk[[name]][[keys_list$parent]] <- keys_list$foreign - } } } } diff --git a/R/join_keys.R b/R/join_keys.R index 0d83dee51..b75f28e92 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -247,10 +247,28 @@ c.join_keys <- function(...) { # When retrieving a relationship pair, it will also return the symmetric key new_jk <- new_join_keys() - for (ix in dataset_1) { + queue <- dataset_1 + bin <- character(0) + + # Need to iterate on a mutating queue if subset of a dataset will also + # select its parent as that parent might have relationships with others + # already selected. + while (length(queue) > 0) { + ix <- queue[1] + queue <- queue[-1] + + if (ix %in% bin) { + next + } + bin <- c(bin, ix) + ix_parent <- parent(join_keys_obj, ix) - ix_valid_names <- names(join_keys_obj[[ix]]) %in% c(ix_parent, dataset_1) + if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) { + queue <- c(queue, ix_parent) + } + + ix_valid_names <- names(join_keys_obj[[ix]]) %in% c(queue, bin) if (keep_all_foreign_keys) { ix_valid_names <- rep(TRUE, length(names(join_keys_obj[[ix]]))) } @@ -263,7 +281,9 @@ c.join_keys <- function(...) { } } - common_parents_ix <- names(parents(join_keys_obj)) %in% names(new_jk) + common_parents_ix <- names(parents(join_keys_obj)) %in% names(new_jk) & + parents(join_keys_obj) %in% names(new_jk) + if (any(common_parents_ix)) parents(new_jk) <- parents(join_keys_obj)[common_parents_ix] new_jk diff --git a/R/parents.R b/R/parents.R index c48d0b92f..9698b81ce 100644 --- a/R/parents.R +++ b/R/parents.R @@ -86,6 +86,8 @@ parents.join_keys <- function(join_keys_obj) { } attr(join_keys_obj, "__parents__") <- old_parents # nolint: object_name_linter + + assert_parent_child(join_keys_obj) join_keys_obj } @@ -94,6 +96,8 @@ parents.join_keys <- function(join_keys_obj) { #' @param join_keys_obj (`join_keys`) object to update the keys. #' #' @return (`self`) invisibly for chaining +#' +#' @keywords internal update_keys_given_parents <- function(join_keys_obj) { jk <- join_keys(join_keys_obj) diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index be37571fd..d0e1b66b6 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -1,4 +1,4 @@ -cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = join_keys()) { +cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = cdisc_join_keys()) { adsl_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL")))) adtte_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) adae_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 778ba44ab..983881d43 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -193,7 +193,7 @@ test_that("[.join_keys can subscript multiple values by index or name", { structure( list( d2 = jk[["d2"]], - d1 = list(d2 = jk[["d1"]][["d2"]], d1 = jk[["d1"]][["d1"]]) + d1 = list(d1 = jk[["d1"]][["d1"]], d2 = jk[["d1"]][["d2"]]) ), class = c("join_keys", "list"), "__parents__" = parents(jk) @@ -204,44 +204,53 @@ test_that("[.join_keys can subscript multiple values by index or name", { test_that("[.join_keys only keeps parents and common keys in index", { jk <- join_keys( join_key("d1", keys = "1"), - join_key("d2", keys = "2"), - join_key("d3", keys = "3"), - join_key("d4", keys = "4"), - join_key("d5", keys = "5"), + join_key("d2", keys = c("1", "2")), + join_key("d3", keys = c("2", "3")), + join_key("d4", keys = c("3", "4")), + join_key("d5", keys = c("4", "5")), # - join_key("d1", "d2", c("1-2" = "2-1")), - join_key("d2", "d3", c("2-3" = "3-2")), - join_key("d3", "d4", c("3-4" = "4-3")), - join_key("d4", "d5", c("4-5" = "5-4")) + join_key("d1", "d2", c("1")), + join_key("d2", "d3", c("2")), + join_key("d3", "d4", c("3")), + join_key("d4", "d5", c("4")) ) parents(jk) <- list( "d2" = "d1", - "d3" = "d1", - "d4" = "d1", - "d5" = "d1" + "d3" = "d2", + "d4" = "d3", + "d5" = "d4" ) # Include parent expect_length(jk[c("d1")], 1) - expect_length(jk[c("d2")], 2) + expect_length(jk[c("d2")], 2) # d2 parent is d1, so it's added expect_length(jk[c("d2", "d3")], 3) expect_length(jk[c(2, 3, 4)], 4) - expect_length(jk[c(1, 3)], 2) - expect_length(jk[c("d1", "d3")], 2) + expect_length(jk[c(1, 3)], 3) # d3 parent is d2, so it's added + expect_length(jk[c("d1", "d4")], 4) # d4 parent is d3, d3 parent is d2, so both are added # Only keeps relevant parents expect_length(parents(jk[c("d2", "d3")]), 2) - expect_equal(parents(jk[c("d2", "d3")]), list("d2" = "d1", "d3" = "d1")) + expect_equal(parents(jk[c("d2", "d3")]), list("d2" = "d1", "d3" = "d2")) # Checks names expect_named(jk[c("d2", "d3")], c("d1", "d2", "d3"), ignore.order = TRUE) # Deep check sliced_jk <- jk[c("d2", "d3")] - expect_identical(sliced_jk[["d1"]], list(d2 = jk[["d1"]][["d2"]], d1 = jk[["d1"]][["d1"]])) - expect_identical(sliced_jk[["d2"]], list(d2 = jk[["d2"]][["d2"]], d1 = jk[["d2"]][["d1"]], d3 = jk[["d2"]][["d3"]])) - expect_identical(sliced_jk[["d3"]], list(d3 = jk[["d3"]][["d3"]], d2 = jk[["d3"]][["d2"]])) + expect_identical( + sliced_jk[["d1"]], + list(d1 = jk[["d1"]][["d1"]], d2 = jk[["d1"]][["d2"]]) + ) + expect_identical( + sliced_jk[["d2"]], + list(d2 = jk[["d2"]][["d2"]], d1 = jk[["d2"]][["d1"]], d3 = jk[["d2"]][["d3"]]) + ) + expect_identical( + sliced_jk[["d3"]], + list(d3 = jk[["d3"]][["d3"]], d2 = jk[["d3"]][["d2"]]) + ) }) test_that("[<-.join_keys cannot subscript multiple values", { diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index e237dc722..872e03766 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -10,7 +10,7 @@ test_that("parents will return empty list when empty/not set", { test_that("parents will return empty NULL when there is no parent", { jk <- join_keys() - expect_null(parents(jk)[["ds1"]]) + expect_null(parents(jk)[["d1"]]) }) testthat::test_that("parents returns a list of all parents", { @@ -37,48 +37,53 @@ testthat::test_that("parents throws error when dataname input is provided", { # parents<- # -test_that("parents<- will add to parents attribute using `[` notation", { +test_that("parents<- does nothing with empty value", { jk <- join_keys() - parents(jk)["ds1"] <- "ds2" - parents(jk)["ds3"] <- "ds4" + jk2 <- `parents<-`(jk) - expect_length(parents(jk), 2) - expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) + expect_length(parents(jk2), 0) + expect_equal(jk, jk2) }) -test_that("parents<- will add to parents attribute using `[[` notation", { +test_that("parents<- will fail if datasets don't exist", { jk <- join_keys() - parents(jk)[["ds1"]] <- "ds2" - parents(jk)[["ds3"]] <- "ds4" - - expect_length(parents(jk), 2) - expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) + expect_error(parents(jk)["d1"] <- "d2") + expect_error(parents(jk)["d3"] <- "d4") }) -test_that("parents<- does nothing with empty value", { - jk <- join_keys() - jk2 <- `parents<-`(jk) +test_that("parents<- will add to parents attribute using `[` notation", { + jk <- join_keys( + join_key("d1", "d2", "k"), + join_key("d3", "d4", "q") + ) + parents(jk)["d1"] <- "d2" + parents(jk)["d3"] <- "d4" - expect_length(parents(jk2), 0) - expect_equal(jk, jk2) + expect_length(parents(jk), 2) + expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) }) -test_that("parents<- will add to parents attribute using list", { - jk <- join_keys() - parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") +test_that("parents<- will add to parents attribute using `[[` notation", { + jk <- join_keys( + join_key("d1", "d2", "k"), + join_key("d3", "d4", "q") + ) + parents(jk)[["d1"]] <- "d2" + parents(jk)[["d3"]] <- "d4" expect_length(parents(jk), 2) - expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4")) + expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) }) -test_that("parents<- will add to parents attribute using list, `[` and `[[` notation", { - jk <- join_keys() - parents(jk)[["ds1"]] <- "ds2" - parents(jk) <- list(ds3 = "ds4", "ds5" = "ds6") - parents(jk)["ds7"] <- "ds8" +test_that("parents<- will add to parents attribute using list", { + jk <- join_keys( + join_key("d1", "d2", "k"), + join_key("d3", "d4", "q") + ) + parents(jk) <- list(d1 = "d2", "d3" = "d4") - expect_length(parents(jk), 4) - expect_identical(parents(jk), list(ds1 = "ds2", ds3 = "ds4", ds5 = "ds6", ds7 = "ds8")) + expect_length(parents(jk), 2) + expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) }) test_that("parents<- ensures it is a directed acyclical graph (DAG)", { @@ -170,52 +175,45 @@ testthat::test_that("update_keys_given_parents updates the join_keys when presen # ----------------------------------------------------------------------------- # -# assert_parent_child +# assert_parent_child errors -test_that("assert_parent_child will detect empty keys", { +test_that("parents<-.join_keys (assert_parent_child) will detect empty keys", { jk <- join_keys() - jk[["ds1"]][["ds2"]] <- character(0) - parents(jk) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk)) + jk[["d1"]][["d2"]] <- character(0) + expect_error( + parents(jk) <- list(d1 = "d2"), + "No join keys from .* to its parent .* and vice versa" + ) }) -test_that("assert_parent_child will detect invalid key pairs", { +test_that("parents<-.join_keys (assert_parent_child) will detect invalid key pairs", { jk <- join_keys() - jk[["ds1"]][["ds2"]] <- "key1" - jk[["ds2"]][["ds1"]] <- character(0) - parents(jk) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk)) + jk[["d1"]][["d2"]] <- "key1" + jk[["d2"]][["d1"]] <- character(0) + expect_error( + parents(jk) <- list(d1 = "d2"), + "No join keys from .* to its parent .* and vice versa" + ) jk2 <- join_keys() - jk2[["ds2"]][["ds1"]] <- "key1" - jk2[["ds1"]][["ds2"]] <- character(0) - parents(jk2) <- list(ds1 = "ds2") - expect_error(assert_parent_child(jk2)) -}) - -test_that("assert_parent_child will skip empty join_keys", { - jk <- join_keys() - expect_silent(assert_parent_child(jk)) -}) - -testthat::test_that("assert_parent_child does nothing if no parents are present", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) - testthat::expect_identical(parents(jk), list()) - testthat::expect_silent(assert_parent_child(jk)) + jk2[["d2"]][["d1"]] <- "key1" + jk2[["d1"]][["d2"]] <- character(0) + expect_error( + parents(jk2) <- list(d1 = "d2"), + "No join keys from .* to its parent .* and vice versa" + ) }) -testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { +testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { jk <- join_keys() join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") testthat::expect_error( - assert_parent_child(jk), + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), "No join keys from df2 to its parent \\(df1\\) and vice versa" ) }) -testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { +testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { jk <- join_keys() join_keys(jk) <- list( join_key("df1", "df1", c("id" = "id")) @@ -224,14 +222,13 @@ testthat::test_that("assert_parent_child throws error if no join_keys exist for class(jk) <- "list" jk[["df2"]][["df1"]] <- "id" class(jk) <- class(new_join_keys()) - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") testthat::expect_error( - assert_parent_child(jk), + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), "No join keys from df2 parent name \\(df1\\) to df2" ) }) -testthat::test_that("assert_parent_child throws error if no join_keys exist for child-parent", { +testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { jk <- join_keys() join_keys(jk) <- list( join_key("df1", "df1", c("id" = "id")) @@ -239,9 +236,8 @@ testthat::test_that("assert_parent_child throws error if no join_keys exist for class(jk) <- "list" jk[["df1"]][["df2"]] <- "id" class(jk) <- class(new_join_keys()) - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") - testthat::expect_error( - assert_parent_child(jk), + expect_error( + parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), "No join keys from df2 to its parent \\(df1\\)" ) }) From 1efb3ad065c702714bcec0589001813d3ed0db9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 01:50:40 +0100 Subject: [PATCH 075/152] cleanup: move cdisc helper fn --- R/testhat-helpers.R | 64 ++++++++++++++++++++++++++++--- man/local_join_keys.Rd | 5 ++- man/local_teal_data.Rd | 5 ++- man/test_join_keys_add.Rd | 5 ++- man/test_join_keys_bare.Rd | 5 ++- man/test_join_keys_combinatory.Rd | 3 +- man/update_keys_given_parents.Rd | 1 + tests/testthat/test-cdisc_data.R | 40 ++----------------- 8 files changed, 77 insertions(+), 51 deletions(-) diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index c529e2a11..f70e31465 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -1,6 +1,8 @@ -#' Generate a teal_data dataset with sample data and join_keys +#' (test helper) Generate a teal_data dataset with sample data and join_keys #' #' @return `teal_data` +#' +#' @keywords internal local_teal_data <- function() { iris2 <- iris iris2$id <- rnorm(NROW(iris2)) @@ -15,25 +17,29 @@ local_teal_data <- function() { ) } -#' Generate a join_keys +#' (test helper) Generate a join_keys #' #' @param dataset_1 `character(1)` name of dataset to add. #' @param keys `character(1)` primary key for `dataset_1` (optionally named). #' #' @return `join_keys` object with a primary key +#' +#' @keywords internal local_join_keys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint join_keys( join_key(dataset_1, keys = keys) ) } -#' Test suite for default join_keys generated by helper +#' (test helper) Test suite for default join_keys generated by helper #' #' @param obj Object with `join_keys` to perform operations (can be `join_keys` #' or `teal_data`). It should only contain a primary key. #' @param dataset_1 `character(1)` name of existing dataset to test. #' #' @return `obj` itself without any modifications +#' +#' @keywords internal test_join_keys_bare <- function(obj, dataset_1 = "ds1") { jk <- join_keys(obj) @@ -44,7 +50,7 @@ test_join_keys_bare <- function(obj, dataset_1 = "ds1") { obj } -#' Test suite for join_keys after manual adding a primary key +#' (test helper) Test suite for join_keys after manual adding a primary key #' #' @param obj Object with `join_keys` to perform operations (can be `join_keys` #' or `teal_data`) @@ -53,6 +59,8 @@ test_join_keys_bare <- function(obj, dataset_1 = "ds1") { #' @param new_keys #' #' @return `obj` itself modified with a new foreign key. +#' +#' @keywords internal test_join_keys_add <- function(obj, dataset_1 = "ds1", new_dataset_1 = "ds2", @@ -68,7 +76,7 @@ test_join_keys_add <- function(obj, expect_length(jk[[new_dataset_1]][[new_dataset_1]], 1) } -#' Test suite for join_keys that performs a mass modification +#' (test helper) Test suite for join_keys that performs a mass modification #' #' The goal of this helper is to modify the `join_keys` with all variants of a #' valid foreign key. @@ -77,6 +85,8 @@ test_join_keys_add <- function(obj, #' or `teal_data`) #' #' @return `obj` itself modified with a new foreign key. +#' +#' @keywords internal test_join_keys_combinatory <- function(obj) { obj <- test_join_keys_bare(obj, "ds1") @@ -159,3 +169,47 @@ test_join_keys_combinatory <- function(obj) { join_keys(obj) <- c(join_keys(obj), join_key(.ds(), "ds-manual", .key(1))) expect_length(join_keys(obj), expected_length + 2 + 1) # adds 1 new dataset as ds-manual already exists } + +#' (test helper) Create test data for CDISC data +#' +#' @inheritParams cdisc_data +#' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr +#' (optional) object with dataset column relationships used for joining. +#' If empty then no joins between pairs of objects. +#' +#' @return a cdisc data of `ADSL`, `ADTTE` and `ADAE` +#' +#' @keywords internal +local_cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = cdisc_join_keys()) { + adsl_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL")))) + adtte_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) + adae_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) + + adsl <- cdisc_dataset( + dataname = "ADSL", + x = adsl_raw, + code = "ADSL <- as.data.frame(as.list(setNames(nm = get_cdisc_keys(\"ADSL\"))))" + ) + adtte_cf <- callable_function( + function() { + as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) + } + ) + adtte <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"), vars = list(x = adsl)) + adae_cf <- callable_function( + function() { + as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) + } + ) + adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) + adae_rdc <- cdisc_data_connector( + connection = data_connection(open_fun = callable_function(function() "open function")), + connectors = list(adae_cdc) + ) + + load_dataset(adsl) + load_dataset(adtte) + load_dataset(adae_cdc) + + cdisc_data(adsl, adtte, adae_rdc, check = check, join_keys = join_keys1) +} diff --git a/man/local_join_keys.Rd b/man/local_join_keys.Rd index 712f20763..9f9b01442 100644 --- a/man/local_join_keys.Rd +++ b/man/local_join_keys.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/testhat-helpers.R \name{local_join_keys} \alias{local_join_keys} -\title{Generate a join_keys} +\title{(test helper) Generate a join_keys} \usage{ local_join_keys(dataset_1 = "ds1", keys = c("id")) } @@ -15,5 +15,6 @@ local_join_keys(dataset_1 = "ds1", keys = c("id")) \code{join_keys} object with a primary key } \description{ -Generate a join_keys +(test helper) Generate a join_keys } +\keyword{internal} diff --git a/man/local_teal_data.Rd b/man/local_teal_data.Rd index 9bb037b9d..c0fc05fca 100644 --- a/man/local_teal_data.Rd +++ b/man/local_teal_data.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/testhat-helpers.R \name{local_teal_data} \alias{local_teal_data} -\title{Generate a teal_data dataset with sample data and join_keys} +\title{(test helper) Generate a teal_data dataset with sample data and join_keys} \usage{ local_teal_data() } @@ -10,5 +10,6 @@ local_teal_data() \code{teal_data} } \description{ -Generate a teal_data dataset with sample data and join_keys +(test helper) Generate a teal_data dataset with sample data and join_keys } +\keyword{internal} diff --git a/man/test_join_keys_add.Rd b/man/test_join_keys_add.Rd index 78c44a796..7e0a6f167 100644 --- a/man/test_join_keys_add.Rd +++ b/man/test_join_keys_add.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/testhat-helpers.R \name{test_join_keys_add} \alias{test_join_keys_add} -\title{Test suite for join_keys after manual adding a primary key} +\title{(test helper) Test suite for join_keys after manual adding a primary key} \usage{ test_join_keys_add( obj, @@ -25,5 +25,6 @@ or \code{teal_data})} \code{obj} itself modified with a new foreign key. } \description{ -Test suite for join_keys after manual adding a primary key +(test helper) Test suite for join_keys after manual adding a primary key } +\keyword{internal} diff --git a/man/test_join_keys_bare.Rd b/man/test_join_keys_bare.Rd index 7c8cef2aa..f6282776c 100644 --- a/man/test_join_keys_bare.Rd +++ b/man/test_join_keys_bare.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/testhat-helpers.R \name{test_join_keys_bare} \alias{test_join_keys_bare} -\title{Test suite for default join_keys generated by helper} +\title{(test helper) Test suite for default join_keys generated by helper} \usage{ test_join_keys_bare(obj, dataset_1 = "ds1") } @@ -16,5 +16,6 @@ or \code{teal_data}). It should only contain a primary key.} \code{obj} itself without any modifications } \description{ -Test suite for default join_keys generated by helper +(test helper) Test suite for default join_keys generated by helper } +\keyword{internal} diff --git a/man/test_join_keys_combinatory.Rd b/man/test_join_keys_combinatory.Rd index ceccf7a26..ad29fe4a0 100644 --- a/man/test_join_keys_combinatory.Rd +++ b/man/test_join_keys_combinatory.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/testhat-helpers.R \name{test_join_keys_combinatory} \alias{test_join_keys_combinatory} -\title{Test suite for join_keys that performs a mass modification} +\title{(test helper) Test suite for join_keys that performs a mass modification} \usage{ test_join_keys_combinatory(obj) } @@ -17,3 +17,4 @@ or \code{teal_data})} The goal of this helper is to modify the \code{join_keys} with all variants of a valid foreign key. } +\keyword{internal} diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 3ba49bfee..169cf8d13 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -15,3 +15,4 @@ update_keys_given_parents(join_keys_obj) \description{ Updates the keys of the datasets based on the parents. } +\keyword{internal} diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index d0e1b66b6..fdbd7a0ba 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -1,39 +1,5 @@ -cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = cdisc_join_keys()) { - adsl_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL")))) - adtte_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) - adae_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) - - adsl <- cdisc_dataset( - dataname = "ADSL", - x = adsl_raw, - code = "ADSL <- as.data.frame(as.list(setNames(nm = get_cdisc_keys(\"ADSL\"))))" - ) - adtte_cf <- callable_function( - function() { - as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) - } - ) - adtte <- cdisc_dataset_connector("ADTTE", adtte_cf, keys = get_cdisc_keys("ADTTE"), vars = list(x = adsl)) - adae_cf <- callable_function( - function() { - as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) - } - ) - adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - adae_rdc <- cdisc_data_connector( - connection = data_connection(open_fun = callable_function(function() "open function")), - connectors = list(adae_cdc) - ) - - load_dataset(adsl) - load_dataset(adtte) - load_dataset(adae_cdc) - - cdisc_data(adsl, adtte, adae_rdc, check = check, join_keys = join_keys1) -} - testthat::test_that("cdisc_data accepts TealDataset, TealDatasetConnector, TealDataConnector objects", { - lifecycle::expect_deprecated(data <- cdisc_data_mixed_call(), "should use data directly") + lifecycle::expect_deprecated(data <- local_cdisc_data_mixed_call(), "should use data directly") testthat::expect_identical(data$get_datanames(), c("ADSL", "ADTTE", "ADAE")) }) @@ -46,7 +12,7 @@ testthat::test_that("cdisc_data returns teal_data object for objects different t }) testthat::test_that("cdisc_data sets the join_keys internally", { - data <- cdisc_data_mixed_call() + data <- local_cdisc_data_mixed_call() jks <- join_keys( join_key("ADSL", "ADSL", c("STUDYID", "USUBJID")), @@ -64,7 +30,7 @@ testthat::test_that( "cdisc_data sets the join_keys internally based on parents relations when primary keys are altered", { jks <- join_keys(join_key("ADSL", "ADSL", c("STUDYID"))) - data <- cdisc_data_mixed_call(join_keys1 = jks) + data <- local_cdisc_data_mixed_call(join_keys1 = jks) jks <- join_keys( join_key("ADSL", "ADSL", c("STUDYID")), From 357da4972c639a8f83f1105f45ba23c394db248e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 01:55:48 +0100 Subject: [PATCH 076/152] cleanup: add missing man page and remove redundant test of private fn --- R/testhat-helpers.R | 4 ++-- man/local_cdisc_data_mixed_call.Rd | 24 ++++++++++++++++++++ tests/testthat/test-parents.R | 36 ------------------------------ 3 files changed, 26 insertions(+), 38 deletions(-) create mode 100644 man/local_cdisc_data_mixed_call.Rd diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index f70e31465..63c06b05b 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -170,14 +170,14 @@ test_join_keys_combinatory <- function(obj) { expect_length(join_keys(obj), expected_length + 2 + 1) # adds 1 new dataset as ds-manual already exists } -#' (test helper) Create test data for CDISC data +#' (test helper) Create test data for `CDISC` data #' #' @inheritParams cdisc_data #' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr #' (optional) object with dataset column relationships used for joining. #' If empty then no joins between pairs of objects. #' -#' @return a cdisc data of `ADSL`, `ADTTE` and `ADAE` +#' @return a `CDISC` data set with the following tables: `ADSL`, `ADTTE` and `ADAE` #' #' @keywords internal local_cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = cdisc_join_keys()) { diff --git a/man/local_cdisc_data_mixed_call.Rd b/man/local_cdisc_data_mixed_call.Rd new file mode 100644 index 000000000..ac0a1e17d --- /dev/null +++ b/man/local_cdisc_data_mixed_call.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/testhat-helpers.R +\name{local_cdisc_data_mixed_call} +\alias{local_cdisc_data_mixed_call} +\title{(test helper) Create test data for \code{CDISC} data} +\usage{ +local_cdisc_data_mixed_call(check = TRUE, join_keys1 = cdisc_join_keys()) +} +\arguments{ +\item{check}{(\code{logical}) reproducibility check - whether to perform a check that the pre-processing +code included in the object definitions actually produces those objects. +If \code{check} is true and preprocessing code is empty an error will be thrown.} + +\item{join_keys}{(\code{join_keys}) or a single (\code{join_key_set})\cr +(optional) object with dataset column relationships used for joining. +If empty then no joins between pairs of objects.} +} +\value{ +a \code{CDISC} data set with the following tables: \code{ADSL}, \code{ADTTE} and \code{ADAE} +} +\description{ +(test helper) Create test data for \code{CDISC} data +} +\keyword{internal} diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 872e03766..1bc1e1363 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -137,42 +137,6 @@ testthat::test_that("parent returns NULL when dataset is not found or not passed testthat::expect_null(parent(jk, "df3")) }) -# ----------------------------------------------------------------------------- -# -# update_keys_given_parents -# - -testthat::test_that("update_keys_given_parents does not update the join_keys when no presents are present", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - jk <- update_keys_given_parents(jk) - testthat::expect_equal(jk, join_keys(join_key("df1", "df2", c("id" = "id")))) -}) - -testthat::test_that("update_keys_given_parents updates the join_keys when presents are present", { - jk <- join_keys() - - join_keys(jk) <- list( - join_key("df1", "df1", c("id", "id2")), - join_key("df1", "df2", c("id" = "id")), - join_key("df1", "df3", c("id" = "id")) - ) - - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") - jk <- update_keys_given_parents(jk) - - expected_jk <- join_keys( - join_key("df1", "df1", c("id", "id2")), - join_key("df1", "df2", c("id" = "id")), - join_key("df1", "df3", c("id" = "id")), - join_key("df2", "df2", c("id", "id2")), - join_key("df2", "df3", c("id", "id2")), - join_key("df3", "df3", c("id", "id2")) - ) - parents(expected_jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1") - testthat::expect_equal(jk, expected_jk) -}) - # ----------------------------------------------------------------------------- # # assert_parent_child errors From 0568c086973958883645ad23e950d82b2d742f3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 10:25:13 +0100 Subject: [PATCH 077/152] Apply suggestions from code review MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- R/join_keys.R | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index b75f28e92..9124db7a7 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -54,10 +54,11 @@ join_keys <- function(...) { return(new_join_keys()) } x <- rlang::list2(...) - if (length(x) > 1) { - return(join_keys.default(...)) + if (length(x) == 1L) { + UseMethod("join_keys", x[[1]]) + } else { + join_keys.default(...) } - UseMethod("join_keys", x[[1]]) } #' @rdname join_keys From 1d40996f18197923a3359096df2a006bda27c32e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 10:55:13 +0100 Subject: [PATCH 078/152] pr: removes missing check and adds teal_data methods --- NAMESPACE | 2 ++ R/parents.R | 70 ++++++++++++++++++++++++++++++++++---------------- man/parent.Rd | 6 ++--- man/parents.Rd | 34 ++++++++++++++++++++---- 4 files changed, 82 insertions(+), 30 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 442f33751..10ca80d93 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ S3method("join_keys<-",join_keys) S3method("join_keys<-",teal_data) S3method("names<-",join_keys) S3method("parents<-",join_keys) +S3method("parents<-",teal_data) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(c,join_keys) @@ -57,6 +58,7 @@ S3method(mutate_dataset,TealDataAbstract) S3method(mutate_dataset,TealDataset) S3method(mutate_dataset,TealDatasetConnector) S3method(parents,join_keys) +S3method(parents,teal_data) S3method(print,join_keys) S3method(set_args,CallableCode) S3method(set_args,CallableFunction) diff --git a/R/parents.R b/R/parents.R index 9698b81ce..905fa07de 100644 --- a/R/parents.R +++ b/R/parents.R @@ -6,14 +6,11 @@ #' @export #' #' @examples -#' jk <- join_keys() -#' parent(jk, "ds1") -#' parents(jk) <- list("ds2" = "ds3") +#' jk <- join_keys(join_key("ds1", "ds2", "key")) +#' parent(jk, "ds2") +#' parents(jk) <- list("ds2" = "ds1") #' parent(jk, "ds2") parent <- function(join_keys_obj, dataset_name) { - if (missing(dataset_name)) { - return(NULL) - } checkmate::assert_string(dataset_name) # assert join_keys_obj is performed by parents() parents(join_keys_obj)[[dataset_name]] @@ -32,21 +29,30 @@ parents <- function(join_keys_obj) { #' @rdname parents #' @export #' @examples -#' jk <- join_keys() +#' jk <- default_cdisc_join_keys["ADEX"] #' parents(jk) parents.join_keys <- function(join_keys_obj) { attr(join_keys_obj, "__parents__") %||% list() } +#' @rdname parents +#' @export +#' @examples +#' +#' td <- cdisc_data( +#' ADSL = teal.data::rADSL, +#' ADTTE = teal.data::rADTTE +#' ) +#' parents(td) +parents.teal_data <- function(join_keys_obj) { + attr(join_keys_obj@join_keys, "__parents__") %||% list() +} + #' @rdname parents #' #' @param value (`list`) named list of character values #' #' @export -#' -#' @examples -#' jk <- join_keys() -#' parents(jk) <- list(ADSL = "ADTTE") `parents<-` <- function(join_keys_obj, value) { UseMethod("parents<-", join_keys_obj) } @@ -54,19 +60,23 @@ parents.join_keys <- function(join_keys_obj) { #' @rdname parents #' @export #' @examples -#' jk <- join_keys() -#' parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") +#' +#' jk <- join_keys( +#' join_key("ds1", "ds2", "id"), +#' join_key("ds5", "ds6", "id"), +#' join_key("ds7", "ds6", "id") +#' ) +#' parents(jk) <- list() +#' parents(jk) <- list(ds1 = "ds2") #' parents(jk)["ds5"] <- "ds6" #' parents(jk)["ds6"] <- "ds7" `parents<-.join_keys` <- function(join_keys_obj, value) { - if (missing(value)) { - return(join_keys_obj) - } - checkmate::assert_list(value, types = "character", names = "named", min.len = 1) - old_parents <- attr(join_keys_obj, "__parents__") + checkmate::assert_list(value, types = "character", names = "named") + + new_parents <- list() for (dataset in names(value)) { - parent <- old_parents[[dataset]] + parent <- new_parents[[dataset]] checkmate::assert( checkmate::check_null(parent), checkmate::check_true( @@ -77,20 +87,36 @@ parents.join_keys <- function(join_keys_obj) { "Please check the difference between provided datasets parents and provided join_keys parents." ) if (is.null(parent)) { - old_parents[[dataset]] <- value[[dataset]] + new_parents[[dataset]] <- value[[dataset]] } } - if (is_dag(old_parents)) { + if (is_dag(new_parents)) { stop("Cycle detected in a parent and child dataset graph.") } - attr(join_keys_obj, "__parents__") <- old_parents # nolint: object_name_linter + attr(join_keys_obj, "__parents__") <- new_parents # nolint: object_name_linter assert_parent_child(join_keys_obj) join_keys_obj } +#' @rdname parents +#' @export +#' @examples +#' +#' td <- cdisc_data( +#' ADSL = teal.data::rADSL, +#' ADTTE = teal.data::rADTTE, +#' ADRS = teal.data::rADRS +#' ) +#' parents(td) <- list("ADTTE" = "ADSL") # replace existing +#' parents(td)["ADRS"] <- "ADSL" # add new parent +`parents<-.teal_data` <- function(join_keys_obj, value) { + parents(join_keys_obj@join_keys) <- value + join_keys_obj +} + #' Updates the keys of the datasets based on the parents. #' #' @param join_keys_obj (`join_keys`) object to update the keys. diff --git a/man/parent.Rd b/man/parent.Rd index 106728cb5..23e48d295 100644 --- a/man/parent.Rd +++ b/man/parent.Rd @@ -15,8 +15,8 @@ parent(join_keys_obj, dataset_name) Getter and setter for specific parent } \examples{ -jk <- join_keys() -parent(jk, "ds1") -parents(jk) <- list("ds2" = "ds3") +jk <- join_keys(join_key("ds1", "ds2", "key")) +parent(jk, "ds2") +parents(jk) <- list("ds2" = "ds1") parent(jk, "ds2") } diff --git a/man/parents.Rd b/man/parents.Rd index 11c8af424..5335d8940 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -3,17 +3,23 @@ \name{parents} \alias{parents} \alias{parents.join_keys} +\alias{parents.teal_data} \alias{parents<-} \alias{parents<-.join_keys} +\alias{parents<-.teal_data} \title{Getter and setter functions for parents attribute of \code{join_keys}} \usage{ parents(join_keys_obj) \method{parents}{join_keys}(join_keys_obj) +\method{parents}{teal_data}(join_keys_obj) + parents(join_keys_obj) <- value \method{parents}{join_keys}(join_keys_obj) <- value + +\method{parents}{teal_data}(join_keys_obj) <- value } \arguments{ \item{join_keys_obj}{(\code{join_keys}) object to retrieve or manipulate.} @@ -27,12 +33,30 @@ a list of \code{character} representing the parents. Getter and setter functions for parents attribute of \code{join_keys} } \examples{ -jk <- join_keys() +jk <- default_cdisc_join_keys["ADEX"] parents(jk) -jk <- join_keys() -parents(jk) <- list(ADSL = "ADTTE") -jk <- join_keys() -parents(jk) <- list(ds1 = "ds2", "ds3" = "ds4") + +td <- cdisc_data( + ADSL = teal.data::rADSL, + ADTTE = teal.data::rADTTE +) +parents(td) + +jk <- join_keys( + join_key("ds1", "ds2", "id"), + join_key("ds5", "ds6", "id"), + join_key("ds7", "ds6", "id") +) +parents(jk) <- list() +parents(jk) <- list(ds1 = "ds2") parents(jk)["ds5"] <- "ds6" parents(jk)["ds6"] <- "ds7" + +td <- cdisc_data( + ADSL = teal.data::rADSL, + ADTTE = teal.data::rADTTE, + ADRS = teal.data::rADRS +) +parents(td) <- list("ADTTE" = "ADSL") # replace existing +parents(td)["ADRS"] <- "ADSL" # add new parent } From 39aec0a8da21b42b14f610d1ca4409d5a64b7e52 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Tue, 14 Nov 2023 09:58:38 +0000 Subject: [PATCH 079/152] [skip actions] Roxygen Man Pages Auto Update --- man/parents.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/parents.Rd b/man/parents.Rd index 5335d8940..73434a78d 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -58,5 +58,5 @@ td <- cdisc_data( ADRS = teal.data::rADRS ) parents(td) <- list("ADTTE" = "ADSL") # replace existing -parents(td)["ADRS"] <- "ADSL" # add new parent +parents(td)["ADRS"] <- "ADSL" # add new parent } From 918908d61ace5e161e636170f8b43feccc1b264c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 10:59:11 +0100 Subject: [PATCH 080/152] pr: method should never be called directly with empty arguments --- R/join_keys.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 9124db7a7..ede0b58b5 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -163,10 +163,6 @@ join_keys.default <- function(...) { #' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) c.join_keys <- function(...) { x <- rlang::list2(...) - - if (!length(x)) { - return(NULL) - } checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) merge_join_keys.join_keys(x[[1]], x[-1]) From 6ed79041e17abac137fda521c61d6d65d74d395a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 11:29:00 +0100 Subject: [PATCH 081/152] pr: remove unecessary condition --- R/join_keys.R | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index ede0b58b5..b002e6ac2 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -85,14 +85,10 @@ join_keys.TealData <- function(...) { #' @rdname join_keys #' @export join_keys.default <- function(...) { - x <- rlang::list2(...) - # Constructor - res <- new_join_keys() - if (length(x) > 0) { - join_keys(res) <- x - } - - res + # Constructor using join_keys<-.xxx setter + result <- new_join_keys() + join_keys(result) <- rlang::list2(...) + result } #' @rdname join_keys From 32a9b30c437c5d398add957682e2b4ad55f1d204 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 11:32:27 +0100 Subject: [PATCH 082/152] pr: remove unecessary condition --- R/join_keys.R | 4 ---- 1 file changed, 4 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index b002e6ac2..377cc66dc 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -118,10 +118,6 @@ join_keys.default <- function(...) { #' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk `join_keys<-.join_keys` <- function(join_keys_obj, value) { - if (missing(value)) { - return(join_keys_obj) - } - # Assume assignment of join keys as a merge operation # Needed to support join_keys(jk)[ds1, ds2] <- "key" if (checkmate::test_class(value, classes = c("join_keys", "list"))) { From 6746e5f9c748192080d3de6c5959c5caacfe5433 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 11:50:45 +0100 Subject: [PATCH 083/152] pr: joined all assertions on join_keys<- and moved c.join_keys in source code --- R/join_keys.R | 40 ++++++++++++++++++++-------------------- man/join_keys.Rd | 10 +++++----- 2 files changed, 25 insertions(+), 25 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 377cc66dc..c02f83637 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -102,6 +102,12 @@ join_keys.default <- function(...) { #' #' @export `join_keys<-` <- function(join_keys_obj, value) { + checkmate::assert( + combine = "or", + checkmate::check_class(value, classes = c("join_keys", "list")), + checkmate::check_class(value, classes = c("join_key_set")), + checkmate::check_list(value, types = "join_key_set") + ) UseMethod("join_keys<-", join_keys_obj) } @@ -119,15 +125,13 @@ join_keys.default <- function(...) { #' jk `join_keys<-.join_keys` <- function(join_keys_obj, value) { # Assume assignment of join keys as a merge operation - # Needed to support join_keys(jk)[ds1, ds2] <- "key" + # Needed to support join_keys(jk)[c("ds1", "ds2")] <- "key" if (checkmate::test_class(value, classes = c("join_keys", "list"))) { return(value) } if (inherits(value, "join_key_set")) value <- list(value) - checkmate::assert_list(value, types = "join_key_set", min.len = 1) - join_keys_obj <- new_join_keys() # check if any join_key_sets share the same datasets but different values @@ -147,19 +151,6 @@ join_keys.default <- function(...) { join_keys_obj } -#' @rdname join_keys -#' @export -#' -#' @examples -#' -#' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) -c.join_keys <- function(...) { - x <- rlang::list2(...) - checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) - - merge_join_keys.join_keys(x[[1]], x[-1]) -} - #' @rdname join_keys #' @export #' @examples @@ -172,14 +163,23 @@ c.join_keys <- function(...) { #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) #' join_keys(td) `join_keys<-.teal_data` <- function(join_keys_obj, value) { - if (missing(value)) { - return(join_keys_obj) - } - join_keys(join_keys_obj@join_keys) <- value join_keys_obj } +#' @rdname join_keys +#' @export +#' +#' @examples +#' +#' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) +c.join_keys <- function(...) { + x <- rlang::list2(...) + checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) + + merge_join_keys.join_keys(x[[1]], x[-1]) +} + #' The Names of an `join_keys` Object #' @inheritParams base::`names<-` #' @export diff --git a/man/join_keys.Rd b/man/join_keys.Rd index f00ea7c6a..5d3dda24c 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -9,8 +9,8 @@ \alias{join_keys.default} \alias{join_keys<-} \alias{join_keys<-.join_keys} -\alias{c.join_keys} \alias{join_keys<-.teal_data} +\alias{c.join_keys} \alias{[.join_keys} \alias{[<-.join_keys} \alias{[[<-.join_keys} @@ -32,10 +32,10 @@ join_keys(join_keys_obj) <- value \method{join_keys}{join_keys}(join_keys_obj) <- value -\method{c}{join_keys}(...) - \method{join_keys}{teal_data}(join_keys_obj) <- value +\method{c}{join_keys}(...) + \method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, keep_all_foreign_keys = FALSE) \method{[}{join_keys}(join_keys_obj, dataset_1) <- value @@ -125,8 +125,6 @@ join_keys(jk) <- c(join_keys(jk), join_key("ds3", "ds4", "some_col2")) join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" jk -c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) - # Setter for join_keys within teal_data ---- td <- teal_data() @@ -135,6 +133,8 @@ join_keys(td)[["ds2"]][["ds2"]] <- "key2" join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) +c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) + # Getter for join_keys ---- jk <- join_keys() From 75cddf18d0f227454be7d2161e6b36b6207cfd9a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 12:54:15 +0100 Subject: [PATCH 084/152] pr: standardize [-like method arguments and remove empty keys --- R/join_key.R | 2 + R/join_keys.R | 134 +++++++++++++++++++++++-------------------- man/get_join_keys.Rd | 2 - man/join_key.Rd | 2 - man/join_keys.Rd | 18 +++--- 5 files changed, 85 insertions(+), 73 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 687ef69dd..8f50df276 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -56,6 +56,8 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { stopifnot(!is.null(names(keys))) stopifnot(!anyDuplicated(keys)) stopifnot(!anyDuplicated(names(keys))) + } else { + keys <- NULL } if (dataset_1 == dataset_2 && any(names(keys) != keys)) { diff --git a/R/join_keys.R b/R/join_keys.R index c02f83637..ec4172acc 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -108,7 +108,10 @@ join_keys.default <- function(...) { checkmate::check_class(value, classes = c("join_key_set")), checkmate::check_list(value, types = "join_key_set") ) - UseMethod("join_keys<-", join_keys_obj) + logger::log_trace("join_keys setting join keys.") + result <- UseMethod("join_keys<-", join_keys_obj) + logger::log_trace("join_keys keys are set.") + result } #' @rdname join_keys @@ -146,8 +149,6 @@ join_keys.default <- function(...) { join_keys_obj[[dataset_1]][[dataset_2]] <- keys } - logger::log_trace("join_keys keys are set.") - join_keys_obj } @@ -206,8 +207,9 @@ c.join_keys <- function(...) { #' @details #' Getter for `join_keys` that returns the relationship between pairs of datasets. #' -#' @param join_keys_obj (`join_keys`) object to extract the join keys -#' @param dataset_1 (`character`) name of first dataset. +#' @inheritParams base::`[` +#' @param keep_all_foreign_keys (`logical`) flag that keeps foreign keys and other +#' datasets even if they are not a parent of the selected dataset. #' #' @export #' @@ -222,21 +224,23 @@ c.join_keys <- function(...) { #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -`[.join_keys` <- function(join_keys_obj, dataset_1 = NULL, keep_all_foreign_keys = FALSE) { - # Protection against missing being passed through functions - if (missing(dataset_1)) dataset_1 <- NULL - - if (is.null(dataset_1)) { - return(join_keys_obj) - } +`[.join_keys` <- function(x, i = NULL, keep_all_foreign_keys = FALSE) { + checkmate::assert( + combine = "or", + checkmate::check_integerish(i), + checkmate::check_logical(i), + checkmate::check_character(i) + ) + checkmate::assert_logical(keep_all_foreign_keys, len = 1) - if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { - dataset_1 <- names(join_keys_obj)[dataset_1] + # Convert integer/logical index to named index + if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { + i <- names(x)[i] } # When retrieving a relationship pair, it will also return the symmetric key new_jk <- new_join_keys() - queue <- dataset_1 + queue <- i bin <- character(0) # Need to iterate on a mutating queue if subset of a dataset will also @@ -251,29 +255,29 @@ c.join_keys <- function(...) { } bin <- c(bin, ix) - ix_parent <- parent(join_keys_obj, ix) + ix_parent <- parent(x, ix) if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) { queue <- c(queue, ix_parent) } - ix_valid_names <- names(join_keys_obj[[ix]]) %in% c(queue, bin) + ix_valid_names <- names(x[[ix]]) %in% c(queue, bin) if (keep_all_foreign_keys) { - ix_valid_names <- rep(TRUE, length(names(join_keys_obj[[ix]]))) + ix_valid_names <- rep(TRUE, length(names(x[[ix]]))) } - new_jk[[ix]] <- join_keys_obj[[ix]][ix_valid_names] + new_jk[[ix]] <- x[[ix]][ix_valid_names] # Add primary key of parent if (length(ix_parent) > 0) { - new_jk[[ix_parent]][[ix_parent]] <- join_keys_obj[[ix_parent]][[ix_parent]] + new_jk[[ix_parent]][[ix_parent]] <- x[[ix_parent]][[ix_parent]] } } - common_parents_ix <- names(parents(join_keys_obj)) %in% names(new_jk) & - parents(join_keys_obj) %in% names(new_jk) + common_parents_ix <- names(parents(x)) %in% names(new_jk) & + parents(x) %in% names(new_jk) - if (any(common_parents_ix)) parents(new_jk) <- parents(join_keys_obj)[common_parents_ix] + if (any(common_parents_ix)) parents(new_jk) <- parents(x)[common_parents_ix] new_jk } @@ -283,7 +287,7 @@ c.join_keys <- function(...) { #' Setter via index directly (bypassing the need to use `join_key()`). #' When `dataset_2` is omitted, it will create a primary key with `dataset_2 = dataset_1`. #' -#' @param value (`character` vector) value to assign. +#' @inheritParams base::`[<-` #' #' @export #' @@ -292,8 +296,8 @@ c.join_keys <- function(...) { #' # Setter via index ---- #' #' jk <- join_keys( -#' join_key("ds1", "ds2", "col12"), -#' join_key("ds3", "ds4", "col34") +#' join_key("ds1", "ds2", c("id_1" = "id_2")), +#' join_key("ds3", "ds4", c("id_3" = "id_4")) #' ) #' #' # overwrites previously defined key @@ -304,18 +308,19 @@ c.join_keys <- function(...) { #' jk[c("ds1", "ds2")] <- list(ds5 = "col*5") #' jk[c(1, 2)] <- list(ds5 = "col**5") #' -#' # Creates primary key by only defining `dataset_1` +#' # Creates primary key by only defining `i` #' jk["ds1"] <- "primary_key" #' jk -`[<-.join_keys` <- function(join_keys_obj, dataset_1, value) { +`[<-.join_keys` <- function(x, i, value) { checkmate::assert( combine = "or", - checkmate::check_character(dataset_1), - checkmate::check_integerish(dataset_1) + checkmate::check_character(i), + checkmate::check_integerish(i), + checkmate::check_logical(i) ) - if (checkmate::test_integerish(dataset_1)) { - dataset_1 <- names(join_keys_obj)[dataset_1] + if (checkmate::test_integerish(i)) { + i <- names(x)[i] } checkmate::assert( @@ -326,16 +331,16 @@ c.join_keys <- function(...) { # Assume characters as being primary keys if (checkmate::test_character(value)) { - value <- lapply(dataset_1, function(dataset_ix) { + value <- lapply(i, function(dataset_ix) { value }) - names(value) <- dataset_1 + names(value) <- i } original_value <- value - for (dataset_ix in dataset_1) { + for (dataset_ix in i) { if (is.null(value)) { - inner_items <- names(join_keys_obj[[dataset_ix]]) + inner_items <- names(x[[dataset_ix]]) value <- structure( vector(mode = "list", length = length(inner_items)), names = inner_items @@ -343,12 +348,12 @@ c.join_keys <- function(...) { } for (new_ix in names(value)) { - join_keys_obj[[dataset_ix]][[new_ix]] <- value[[new_ix]] + x[[dataset_ix]][[new_ix]] <- value[[new_ix]] } value <- original_value } - join_keys_obj + x } #' @rdname join_keys @@ -367,42 +372,49 @@ c.join_keys <- function(...) { #' jk <- join_keys() #' jk[["ds2"]][["ds3"]] <- "key" #' jk[["ds2"]][["ds3"]] <- NULL +#' #' jk -`[[<-.join_keys` <- function(join_keys_obj, dataset_1, value) { - if (checkmate::test_integerish(dataset_1) || checkmate::test_logical(dataset_1)) { - dataset_1 <- names(join_keys_obj)[[dataset_1]] - } - - checkmate::assert_string(dataset_1) - - # Accepting 1 subscript with valid `value` formal +`[[<-.join_keys` <- function(x, i, value) { + checkmate::assert( + combine = "or", + checkmate::check_string(i), + checkmate::check_integerish(i, len = 1), + checkmate::check_logical(i, len = 1) + ) checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) + if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { + i <- names(x)[[i]] + } + # Normalize values norm_value <- lapply(names(value), function(.x) { - get_keys(join_key(dataset_1, .x, value[[.x]])) + get_keys(join_key(i, .x, value[[.x]])) }) names(norm_value) <- names(value) value <- norm_value + # Remove elements with length == 0L + value <- value[!vapply(seq_along(value), function(.x) is.null(value[[.x]]) || length(value[[.x]]) == 0L, logical(1))] + # # Remove classes to use list-based get/assign operations - join_keys_obj <- unclass(join_keys_obj) + x <- unclass(x) # In case a pair is removed, also remove the symmetric pair - removed_names <- setdiff(names(join_keys_obj[[dataset_1]]), names(value)) + removed_names <- setdiff(names(x[[i]]), names(value)) if (length(removed_names) > 0) { - for (.x in removed_names) join_keys_obj[[.x]][[dataset_1]] <- NULL + for (.x in removed_names) x[[.x]][[i]] <- NULL } - join_keys_obj[[dataset_1]] <- value + x[[i]] <- value # Iterate on all new values to create symmetrical pair for (ds2 in names(value)) { - if (ds2 == dataset_1) next + if (ds2 == i) next - keep_value <- join_keys_obj[[ds2]] %||% list() + keep_value <- x[[ds2]] %||% list() new_value <- value[[ds2]] if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { @@ -414,26 +426,26 @@ c.join_keys <- function(...) { new_value <- setNames(names(new_value), new_value) } - keep_value[[dataset_1]] <- new_value + keep_value[[i]] <- new_value # Assign symmetrical - join_keys_obj[[ds2]] <- keep_value + x[[ds2]] <- keep_value } # Remove NULL or empty keys empty_ix <- vapply( - join_keys_obj, + x, function(.x) is.null(.x) || length(.x) == 0, logical(1) ) - preserve_attr <- attributes(join_keys_obj)[!names(attributes(join_keys_obj)) %in% "names"] - join_keys_obj <- join_keys_obj[!empty_ix] - attributes(join_keys_obj) <- modifyList(attributes(join_keys_obj), preserve_attr) + preserve_attr <- attributes(x)[!names(attributes(x)) %in% "names"] + x <- x[!empty_ix] + attributes(x) <- modifyList(attributes(x), preserve_attr) # # restore class - class(join_keys_obj) <- c("join_keys", "list") - join_keys_obj + class(x) <- c("join_keys", "list") + x } #' @rdname merge_join_keys diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 69d0e6aa2..03d913b55 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -12,8 +12,6 @@ get_join_keys(data, dataset_1, dataset_2 = NULL) <- value \arguments{ \item{data}{`` - object to extract the join keys} -\item{dataset_1}{(\code{character}) name of first dataset.} - \item{dataset_2}{(\code{character(1)}) name of a dataset.} \item{value}{value to assign} diff --git a/man/join_key.Rd b/man/join_key.Rd index 90ed7c3c9..379c39e6a 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -7,8 +7,6 @@ join_key(dataset_1, dataset_2 = dataset_1, keys) } \arguments{ -\item{dataset_1}{(\code{character}) name of first dataset.} - \item{dataset_2}{(optional \code{character}) other dataset name. In case it is omitted, then it will create a primary key for \code{dataset_1}.} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 5d3dda24c..5ae517bd5 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -36,9 +36,9 @@ join_keys(join_keys_obj) <- value \method{c}{join_keys}(...) -\method{[}{join_keys}(join_keys_obj, dataset_1 = NULL, keep_all_foreign_keys = FALSE) +\method{[}{join_keys}(x, i = NULL, keep_all_foreign_keys = FALSE) -\method{[}{join_keys}(join_keys_obj, dataset_1) <- value +\method{[}{join_keys}(x, i) <- value \method{[[}{join_keys}(join_keys_obj, dataset_1) <- value } @@ -49,11 +49,13 @@ it will return the \code{join_keys} of that object. When called with 1 or more \code{join_key_set} it will create a new \code{join_keys} with constructed from the arguments.} -\item{join_keys_obj}{(\code{join_keys}) object to extract the join keys} +\item{join_keys_obj}{(\code{join_keys}) empty object to set the new relationship pairs.} -\item{value}{(\code{character} vector) value to assign.} +\item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add +to \code{join_keys} list.} -\item{dataset_1}{(\code{character}) name of first dataset.} +\item{keep_all_foreign_keys}{(\code{logical}) flag that keeps foreign keys and other +datasets even if they are not a parent of the selected dataset.} } \value{ \code{join_keys} object. @@ -148,8 +150,8 @@ jk[c("ds1", "ds2")] # Setter via index ---- jk <- join_keys( - join_key("ds1", "ds2", "col12"), - join_key("ds3", "ds4", "col34") + join_key("ds1", "ds2", c("id_1"= "id_2")), + join_key("ds3", "ds4", c("id_3"= "id_4")) ) # overwrites previously defined key @@ -160,7 +162,7 @@ jk jk[c("ds1", "ds2")] <- list(ds5 = "col*5") jk[c(1, 2)] <- list(ds5 = "col**5") -# Creates primary key by only defining `dataset_1` +# Creates primary key by only defining `i` jk["ds1"] <- "primary_key" jk From d62b96558533ccaedb4142e6c54fd73072bfa636 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Tue, 14 Nov 2023 11:56:25 +0000 Subject: [PATCH 085/152] [skip actions] Roxygen Man Pages Auto Update --- man/join_keys.Rd | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 5ae517bd5..6f3d3270e 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -40,7 +40,7 @@ join_keys(join_keys_obj) <- value \method{[}{join_keys}(x, i) <- value -\method{[[}{join_keys}(join_keys_obj, dataset_1) <- value +\method{[[}{join_keys}(x, i) <- value } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. @@ -150,8 +150,8 @@ jk[c("ds1", "ds2")] # Setter via index ---- jk <- join_keys( - join_key("ds1", "ds2", c("id_1"= "id_2")), - join_key("ds3", "ds4", c("id_3"= "id_4")) + join_key("ds1", "ds2", c("id_1" = "id_2")), + join_key("ds3", "ds4", c("id_3" = "id_4")) ) # overwrites previously defined key @@ -178,5 +178,6 @@ jk[["ds4"]] <- list(ds5 = "new") jk <- join_keys() jk[["ds2"]][["ds3"]] <- "key" jk[["ds2"]][["ds3"]] <- NULL + jk } From 8f76eed3266b8c873ad6af28678627818e46f6e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 13:11:34 +0100 Subject: [PATCH 086/152] pr: remove logger from join_keys --- R/join_keys.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index ec4172acc..4c4750fe1 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -108,10 +108,7 @@ join_keys.default <- function(...) { checkmate::check_class(value, classes = c("join_key_set")), checkmate::check_list(value, types = "join_key_set") ) - logger::log_trace("join_keys setting join keys.") - result <- UseMethod("join_keys<-", join_keys_obj) - logger::log_trace("join_keys keys are set.") - result + UseMethod("join_keys<-", join_keys_obj) } #' @rdname join_keys @@ -492,7 +489,6 @@ merge_join_keys.join_keys <- function(join_keys_obj, new_join_keys) { join_keys_obj <- utils::modifyList(join_keys_obj, el) } - logger::log_trace("join_keys keys merged.") return(join_keys_obj) } From acc5454ac7e8d6e1c32ce3bfc4def2456b6caf3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 13:32:11 +0100 Subject: [PATCH 087/152] pr: remove support for [<- in favor of individual [[<- --- R/join_keys.R | 52 +++++++-------------------------------------- R/testhat-helpers.R | 20 ++++++++--------- man/join_keys.Rd | 2 +- 3 files changed, 19 insertions(+), 55 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 4c4750fe1..d6eb5fbd2 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -221,7 +221,11 @@ c.join_keys <- function(...) { #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -`[.join_keys` <- function(x, i = NULL, keep_all_foreign_keys = FALSE) { +`[.join_keys` <- function(x, i, keep_all_foreign_keys = FALSE) { + if (missing(i)) { + return(x) + } + checkmate::assert( combine = "or", checkmate::check_integerish(i), @@ -309,48 +313,7 @@ c.join_keys <- function(...) { #' jk["ds1"] <- "primary_key" #' jk `[<-.join_keys` <- function(x, i, value) { - checkmate::assert( - combine = "or", - checkmate::check_character(i), - checkmate::check_integerish(i), - checkmate::check_logical(i) - ) - - if (checkmate::test_integerish(i)) { - i <- names(x)[i] - } - - checkmate::assert( - combine = "or", - checkmate::check_character(value), - checkmate::check_list(value, names = "named", types = "character", null.ok = TRUE) - ) - - # Assume characters as being primary keys - if (checkmate::test_character(value)) { - value <- lapply(i, function(dataset_ix) { - value - }) - names(value) <- i - } - - original_value <- value - for (dataset_ix in i) { - if (is.null(value)) { - inner_items <- names(x[[dataset_ix]]) - value <- structure( - vector(mode = "list", length = length(inner_items)), - names = inner_items - ) - } - - for (new_ix in names(value)) { - x[[dataset_ix]][[new_ix]] <- value[[new_ix]] - } - value <- original_value - } - - x + stop("Can't use `[<-` for object `join_keys`. Use [[<- instead.") } #' @rdname join_keys @@ -575,11 +538,12 @@ check_join_keys_alike <- function(x) { vapply( x, function(el) { - checkmate::test_list(el, types = "character", names = "named") + checkmate::test_list(el, types = c("character", "null"), names = "named") }, logical(1) ) ) + if (isFALSE(all(result))) { return( paste( diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index 63c06b05b..ea1f850a4 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -66,7 +66,7 @@ test_join_keys_add <- function(obj, new_dataset_1 = "ds2", new_keys = c("id")) { obj <- test_join_keys_bare(obj, dataset_1) - join_keys(obj)[new_dataset_1] <- c(new_keys) # primary key + join_keys(obj)[[new_dataset_1]][[new_dataset_1]] <- c(new_keys) # primary key jk <- join_keys(obj) @@ -107,13 +107,9 @@ test_join_keys_combinatory <- function(obj) { } # Primary key (each adds 1) - join_keys(obj)[.ds()] <- .key() - expect_error(join_keys(obj)[.ds()] <- .key(3)) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(1))) join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(2))) join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(4))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), character(0))) expect_error(join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(3)))) # Relationship pair (each adds 2) @@ -121,23 +117,20 @@ test_join_keys_combinatory <- function(obj) { join_keys(obj)[[.ds()]][[.ds()]] <- .key(2) join_keys(obj)[[.ds()]][[.ds()]] <- .key(3) join_keys(obj)[[.ds()]][[.ds()]] <- .key(4) - join_keys(obj)[[.ds()]][[.ds()]] <- character(0) # Relationship pair alternative (each adds 2) join_keys(obj)[[.ds()]] <- setNames(list(.key(1)), .ds()) join_keys(obj)[[.ds()]] <- setNames(list(.key(2)), .ds()) join_keys(obj)[[.ds()]] <- setNames(list(.key(3)), .ds()) join_keys(obj)[[.ds()]] <- setNames(list(.key(4)), .ds()) - join_keys(obj)[[.ds()]] <- setNames(list(character(0)), .ds()) # Using join_key (each adds 2) join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(1))) join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(2))) join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(3))) join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(4))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), character(0))) - # (each join_key adds 2) + # (each join_key adds 2, except character(0)) join_keys(obj) <- c( join_keys(obj), join_key(.ds(), .ds(), .key(1)), @@ -147,6 +140,13 @@ test_join_keys_combinatory <- function(obj) { join_key(.ds(), .ds(), character(0)) ) + # Setting character(0) is the same as NUL (adds nothing) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), character(0))) + join_keys(obj)[[.ds()]][[.ds()]] <- character(0) + join_keys(obj)[[.ds()]] <- setNames(list(character(0)), .ds()) + join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), character(0))) + + # (each join_key adds 2) join_keys(obj) <- c( join_keys(obj), join_keys( @@ -160,7 +160,7 @@ test_join_keys_combinatory <- function(obj) { expect_s3_class(join_keys(obj), class = c("join_keys", "list")) - expected_length <- 55 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` + expected_length <- 43 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` expect_length(join_keys(obj), expected_length) join_keys(obj) <- c(join_keys(obj), join_key("ds-manual", .ds(), .key(1))) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 6f3d3270e..8f06beadb 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -36,7 +36,7 @@ join_keys(join_keys_obj) <- value \method{c}{join_keys}(...) -\method{[}{join_keys}(x, i = NULL, keep_all_foreign_keys = FALSE) +\method{[}{join_keys}(x, i, keep_all_foreign_keys = FALSE) \method{[}{join_keys}(x, i) <- value From 32bfbf2088099bbd322c6eac3acee6bdb15412d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 13:34:12 +0100 Subject: [PATCH 088/152] typo: remove hardcoded number --- R/testhat-helpers.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index ea1f850a4..d3713d5e7 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -160,7 +160,7 @@ test_join_keys_combinatory <- function(obj) { expect_s3_class(join_keys(obj), class = c("join_keys", "list")) - expected_length <- 43 + 1 # 68 from the operations + 1 from `helper_test_getter_join_keys` + expected_length <- 43 + 1 # Add + 1 from `helper_test_getter_join_keys` expect_length(join_keys(obj), expected_length) join_keys(obj) <- c(join_keys(obj), join_key("ds-manual", .ds(), .key(1))) From cde58f6f293b3480f9bfd3f8b8d9fd442ce8cbf1 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 14 Nov 2023 14:35:04 +0100 Subject: [PATCH 089/152] tidyup tests --- tests/testthat/test-join_keys.R | 975 ++++++++++---------------------- 1 file changed, 306 insertions(+), 669 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 983881d43..2e05374f6 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -1,815 +1,452 @@ -test_that("join_keys.teal_data will successfully obtain object from teal_data", { - obj <- local_teal_data() - - expect_identical(obj@join_keys, join_keys(obj)) - test_join_keys_bare(obj, "ds1") +# join_keys -------------------------------------------------------------------- +testthat::test_that("join_keys creates empty join_keys object by default", { + testthat::expect_s3_class(join_keys(), "join_keys") }) -test_that("join_keys.join_keys will return itself", { - obj <- local_join_keys() - - expect_identical(obj, join_keys(obj)) - test_join_keys_bare(obj, "ds1") +testthat::test_that("join_keys.join_key creates join_keys", { + testthat::expect_s3_class( + join_keys( + join_key("d1", keys = "test"), + join_key("d2", keys = "test") + ), + c("join_keys", "list") + ) }) -test_that("join_keys<-.teal_data shared test to setter (in mass)", { - obj <- local_teal_data() - test_join_keys_combinatory(obj) -}) +testthat::test_that("join_keys is a collection of join_key, ie named list with named list with named char vector", { + key1 <- join_key("d1", keys = "test") + key2 <- join_key("d2", keys = "test") + jk <- join_keys(key1, key2) -test_that("join_keys<-.join_keys shared test to setter (in mass)", { - obj <- local_join_keys() - test_join_keys_combinatory(obj) + testthat::expect_identical( + jk, + structure(c(key1, key2), class = c("join_keys", "list")) + ) + testthat::expect_identical( + jk, + structure( + list( + d1 = list(d1 = c(test = "test")), + d2 = list(d2 = c(test = "test")) + ), + class = c("join_keys", "list") + ) + ) }) -test_that("join_keys<-.teal_data shared test to getter and setter", { +testthat::test_that("join_keys.teal_data returns join_keys object from teal_data", { obj <- local_teal_data() - test_join_keys_add(obj, "ds1", "ds2") + testthat::expect_identical(obj@join_keys, join_keys(obj)) }) -test_that("join_keys<-.join_keys shared test to getter and setter", { +testthat::test_that("join_keys.join_keys returns itself", { obj <- local_join_keys() - test_join_keys_add(obj, "ds1", "ds2") + testthat::expect_identical(obj, join_keys(obj)) }) -test_that("join_keys<-.join_keys to set via a join_key_set object", { - obj <- join_keys() - join_keys(obj) <- c(obj, join_key("ds1", "ds2", "id")) - expect_equal(obj$ds1, list("ds2" = c("id" = "id"))) - expect_equal(obj$ds2, list("ds1" = c("id" = "id"))) +testthat::test_that("join_keys accepts duplicated join_key", { + testthat::expect_no_error( + join_keys(join_key("d1", "d2", "a"), join_key("d2", "d1", "a")) + ) }) -test_that("c.join_keys to set via multiple lists that progressively merge object", { - obj <- join_keys() - obj <- c(obj, join_key("ds1", "ds2", "id")) - obj <- c(obj, join_key("ds3", "ds4", "id_id"), join_key("ds5", "ds6", "id_id")) - obj <- c(obj, join_key("ds7", "ds8", "id_id_id")) - - expect_length(obj, 8) +testthat::test_that("join_keys doesn't accept other objects than teal_data, TealData and join_key", { + testthat::expect_error(join_keys("a")) # todo: add expected error message }) -test_that("join_keys<-.join_keys overwrites existing join_keys", { - jk <- join_keys( - join_key("d1", "d2", c("A" = "B", "C" = "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) - ) - - join_keys(jk) <- join_keys( - join_key("d1", "d1", "primary") - ) - - expect_length(jk, 1) - expect_identical(jk[["d1"]], list(d1 = c("primary" = "primary"))) +testthat::test_that("join_keys doesn't accept a list which is identical to output of join_key function", { + key <- join_key("a", "b", "test") + testthat::expect_error(join_keys(unclass(key))) }) -test_that("join_keys<-.teal_data overwrites existing join_keys", { - td <- teal_data( - iris = iris, - join_keys = join_keys( - join_key("d1", "d2", c("A" = "B", "C" = "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) - ) +testthat::test_that("join_keys fails when provided foreign key pairs have incompatible values", { + testthat::expect_error( + join_keys(join_key("d1", "d2", "a"), join_key("d2", "d1", "b")), + "cannot specify multiple different join keys between datasets" ) - - expect_length(join_keys(td), 6) - - join_keys(td) <- join_keys( - join_key("d1", "d1", "primary") + testthat::expect_error( + join_keys(join_key("d1", "d2", c(a = "b")), join_key("d2", "d1", c(a = "b"))), + "cannot specify multiple different join keys between datasets" ) - - expect_length(join_keys(td), 1) - expect_identical(join_keys(td)[["d1"]], list(d1 = c("primary" = "primary"))) }) -# ----------------------------------------------------------------------------- -# -# [, [<-, [[ and [[<- -# -test_that("[[<-.join_keys creates symmetric relationship", { - jk <- join_keys() - - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - - expect_identical( - jk, - structure( - list( - d1 = list(d2 = c("A" = "B", "C" = "C")), - d2 = list(d1 = c("B" = "A", "C" = "C")) - ), - class = c("join_keys", "list") - ) +testthat::test_that("join_keys constructor adds symmetric keys on given (unnamed) foreign key", { + my_keys <- join_keys(join_key("d1", "d2", "a")) + testthat::expect_identical( + my_keys, + join_keys(join_key("d1", "d2", "a"), join_key("d2", "d1", "a")) ) }) -test_that("[[<-.join_keys is equivalent to using the constructor (single subscript)", { - jk <- join_keys( - join_key("d1", "d2", c("A" = "B", "C" = "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) +testthat::test_that("join_keys constructor adds symmetric keys on given (named) foreign key", { + testthat::expect_identical( + join_keys( + join_key("d1", "d2", c(a = "b")) + ), + join_keys( + join_key("d1", "d2", c(a = "b")), + join_key("d2", "d1", c(b = "a")) + ) ) - - jk2 <- join_keys() - - jk2[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - jk2[["d3"]][["d4"]] <- c("D" = "D", "E" = "E") - jk2[["d5"]][["d6"]] <- c("F" = "F", "K" = "k") - - expect_identical(jk, jk2) }) -test_that("[<-.join_keys is equivalent to using the constructor", { - jk <- join_keys( - join_key("d1", "d2", c("A", "B")), - join_key("d3", "d4", c("C", "D")), - join_key("d5", "d6", c("E", "F")) +# [.join_keys ----------------------------------------------------------------- +testthat::test_that("[.join_keys returns join_keys object", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), ) - - jk2 <- join_keys() - - jk2["d1"] <- list(d2 = c("A", "B")) - jk2["d3"] <- list(d4 = c("C", "D")) - jk2["d5"] <- list(d6 = c("E", "F")) - - expect_identical(jk, jk2) + testthat::expect_identical(my_keys[], my_keys) }) -test_that("[.join_keys can subscript multiple values by index or name", { - jk <- join_keys( - join_key("d1", "d1", c("A")), - join_key("d1", "d2", c("A" = "B", "C")), - join_key("d3", "d4", c("D", "E")), - join_key("d5", "d6", c("F", "K" = "k")) +testthat::test_that("[.join_keys returns join_keys object with keys for given datasets", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), ) - - expect_length(jk[1:2], 2) - expect_identical(jk[1:2], jk[c("d1", "d2")]) - expect_identical(jk[c(1, 5)], jk[c("d1", "d5")]) - - expect_length(jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], 4) - expect_length(jk[c("d1", "d5")], 1) - expect_equal( - jk[c("d1", "d5")], - structure( - list(d1 = list(d1 = c("A" = "A"))), - class = c("join_keys", "list") - ) + testthat::expect_identical( + my_keys[c("d1", "d2")], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) +}) - expect_identical( - jk[c("d1", "d5"), keep_all_foreign_keys = TRUE], - structure( - list( - d1 = jk[["d1"]], - d2 = jk[["d2"]], - d5 = jk[["d5"]], - d6 = jk[["d6"]] - ), - class = c("join_keys", "list") - ) +testthat::test_that("[.join_keys returns join_keys object with keys for given index", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), ) - - expect_identical( - jk[1], - structure( - list(d1 = jk[["d1"]]["d1"]), - class = c("join_keys", "list") - ) + testthat::expect_identical( + my_keys[c(1, 2)], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) +}) - expect_identical( - jk[c(1, 3), keep_all_foreign_keys = TRUE], - structure( - list(d1 = jk[["d1"]], d2 = jk[["d2"]], d3 = jk[["d3"]], d4 = jk[["d4"]]), - class = c("join_keys", "list") - ) +testthat::test_that("[.join_keys returns join_keys for given dataset including those connected with foreign keys", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ab"), + join_key("d3", "d1", "ac") ) - - parents(jk) <- list("d2" = "d1") - expect_identical( - jk[2], - structure( - list( - d2 = jk[["d2"]], - d1 = list(d1 = jk[["d1"]][["d1"]], d2 = jk[["d1"]][["d2"]]) - ), - class = c("join_keys", "list"), - "__parents__" = parents(jk) + testthat::expect_identical( + my_keys["d2", keep_all_foreign_keys = TRUE], + join_keys( + join_key("d2", "d2", "b"), + join_key("d2", "d1", "ab"), + join_key("d1", "d2", "ab") ) ) }) -test_that("[.join_keys only keeps parents and common keys in index", { - jk <- join_keys( - join_key("d1", keys = "1"), - join_key("d2", keys = c("1", "2")), - join_key("d3", keys = c("2", "3")), - join_key("d4", keys = c("3", "4")), - join_key("d5", keys = c("4", "5")), - # - join_key("d1", "d2", c("1")), - join_key("d2", "d3", c("2")), - join_key("d3", "d4", c("3")), - join_key("d4", "d5", c("4")) +testthat::test_that("[.join_keys returns join_keys object for given dataset including its parent", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ab"), + join_key("d3", "d1", "ac") ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") - parents(jk) <- list( - "d2" = "d1", - "d3" = "d2", - "d4" = "d3", - "d5" = "d4" + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d2", "d1", "ab") ) + parents(expected) <- list("d2" = "d1") - # Include parent - expect_length(jk[c("d1")], 1) - expect_length(jk[c("d2")], 2) # d2 parent is d1, so it's added - expect_length(jk[c("d2", "d3")], 3) - expect_length(jk[c(2, 3, 4)], 4) - expect_length(jk[c(1, 3)], 3) # d3 parent is d2, so it's added - expect_length(jk[c("d1", "d4")], 4) # d4 parent is d3, d3 parent is d2, so both are added - - # Only keeps relevant parents - expect_length(parents(jk[c("d2", "d3")]), 2) - expect_equal(parents(jk[c("d2", "d3")]), list("d2" = "d1", "d3" = "d2")) - - # Checks names - expect_named(jk[c("d2", "d3")], c("d1", "d2", "d3"), ignore.order = TRUE) - # Deep check - sliced_jk <- jk[c("d2", "d3")] - - expect_identical( - sliced_jk[["d1"]], - list(d1 = jk[["d1"]][["d1"]], d2 = jk[["d1"]][["d2"]]) - ) - expect_identical( - sliced_jk[["d2"]], - list(d2 = jk[["d2"]][["d2"]], d1 = jk[["d2"]][["d1"]], d3 = jk[["d2"]][["d3"]]) - ) - expect_identical( - sliced_jk[["d3"]], - list(d3 = jk[["d3"]][["d3"]], d2 = jk[["d3"]][["d2"]]) - ) + testthat::expect_equal(my_keys["d2"], expected) }) -test_that("[<-.join_keys cannot subscript multiple values", { - jk <- join_keys( - join_key("d1", "d2", c("A" = "B", "C")), - join_key("d2", "d3", c("D", "E")), - join_key("d4", "d3", c("F", "K" = "k")), - join_key("d4", "d1", c("F", "K" = "k")) - ) - - jk[1:2] <- NULL - - expect_length(jk, 2) - expect_identical(jk[["d4"]][["d3"]], c("F" = "F", "K" = "k")) - expect_identical(jk[["d3"]][["d4"]], c("F" = "F", "k" = "K")) +testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset", { + my_keys <- join_keys(join_key("d1", "d1", "a")) + testthat::expect_length(my_keys["d2"], 0) }) -test_that("[[<- can mutate existing keys", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys[["d1"]][["d2"]] <- c("X" = "Y") - expect_equal(my_keys[["d1"]][["d2"]], c("X" = "Y")) - expect_equal(my_keys[["d2"]][["d1"]], c("Y" = "X")) +# join_keys.<- ---------------------------------------------------------------- +testthat::test_that("join_keys<-.join_keys overwrites existing join_keys", { + my_keys <- join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + join_keys(my_keys) <- join_keys(join_key("d1", "d1", "test")) + testthat::expect_identical(my_keys, join_keys(join_key("d1", "d1", "test"))) }) -test_that("[[<- mutating non-existing keys adds them", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys[["d2"]][["d3"]] <- c("X" = "Y") - expect_equal(my_keys[["d2"]][["d3"]], c("X" = "Y")) - expect_equal(my_keys[["d3"]][["d2"]], c("Y" = "X")) +testthat::test_that("join_keys<-.join_keys accepts join_key_set object to modify keys", { + obj <- join_keys() + join_keys(obj) <- join_key("ds1", "ds2", "id") + testthat::expect_identical(obj, join_keys(join_key("ds1", "ds2", "id"))) }) -test_that("[[<- can remove keys by setting them to character(0)", { - my_keys <- join_keys( - join_key("d1", "d2", "A"), - join_key("d3", "d4", c("A" = "B", "C" = "D")) +testthat::test_that("join_keys<-.teal_data overwrites existing join_keys", { + td <- teal_data( + d1 = data.frame(), d2 = data.frame(), + join_keys = join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) - my_keys[["d1"]][["d2"]] <- character(0) - expect_equal(my_keys[["d1"]][["d2"]], character(0)) -}) - -test_that("[[<-.join_keys removes keys with NULL", { - jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - jk[["d1"]][["d2"]] <- NULL + jk2 <- join_keys(join_key("d1", "d1", "test")) + join_keys(td) <- jk2 + testthat::expect_identical(join_keys(td), jk2) +}) - expect_identical( - jk, - structure( - list(), - names = character(0), - class = c("join_keys", "list") - ) +testthat::test_that("join_keys<-.teal_data overwrites existing join_keys", { + td <- teal_data( + d1 = data.frame(), d2 = data.frame(), + join_keys = join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) + + jk2 <- join_keys(join_key("d1", "d1", "test")) + join_keys(td) <- jk2 + testthat::expect_identical(join_keys(td), jk2) }) -test_that("[[<-.join_keys removes keys with NULL and keeps existing", { +testthat::test_that("join_keys()[]<-.join_keys with empty name is changed to the key value", { jk <- join_keys() - - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - jk[["d2"]][["d3"]] <- c("A" = "B", "C" = "C") - jk[["d1"]][["d4"]] <- c("A" = "B", "C" = "C") - jk[["d1"]][["d2"]] <- NULL - - expect_null(jk[["d1"]][["d2"]]) - expect_null(jk[["d2"]][["d1"]]) - - expect_failure(expect_null(jk[["d2"]][["d3"]])) - expect_failure(expect_null(jk[["d3"]][["d2"]])) - expect_failure(expect_null(jk[["d1"]][["d4"]])) - expect_failure(expect_null(jk[["d4"]][["d1"]])) - - expect_length(jk, 4) + join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(jk[["d1"]][["d2"]], c(A = "B", C = "C")) }) -# ----------------------------------------------------------------------------- -# -# names<-.join_keys -# - -test_that("names<-.join_keys will replace names at first and second levels", { - jk <- join_keys( - join_key("a", keys = "k4"), - join_key("a", "b", "k1"), - join_key("a", "c", "k3"), - join_key("d", "b", "k2"), - ) - - expect_named(jk, c("a", "b", "c", "d"), ignore.order = TRUE) - - names(jk)[1:2] <- c("aa", "bb") - - expect_named(jk, c("aa", "bb", "c", "d"), ignore.order = TRUE) - - expect_identical(jk[["aa"]][["c"]], c("k3" = "k3")) - expect_identical(jk[["aa"]][["bb"]], c("k1" = "k1")) - expect_identical(jk[["aa"]][["aa"]], c("k4" = "k4")) - - expect_length(names(jk), 4) +testthat::test_that("join_keys()[]<-.join_keys with named empty valued is changed to its name", { + jk <- join_keys() + join_keys(jk)[["d1"]][["d2"]] <- c(A = "B", C = "") + expect_equal(jk[["d1"]][["d2"]], c(A = "B", C = "C")) }) -# ----------------------------------------------------------------------------- -# -# mutate_join_keys (empty value name) -# - -test_that("[[<-.join_keys with empty name is changed to the key value", { - # set empty key name - jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) - # set key on non-empty variable name equal to "" +testthat::test_that("join_keys()[]<-.join_keys with empty value in a named vector are ignored ", { jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) + testthat::expect_message(join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) +}) - # set key on empty variable name equal to "" +# [<-.join_keys and [[<-.join_keys ------------------------------------------------ +testthat::test_that("[[<-.join_keys accepts named list where each containing character", { jk <- join_keys() - expect_message(jk[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B"), c("A"))) + testthat::expect_no_error( + jk[["d1"]] <- list(d1 = c("a", "b", "c"), d2 = c(b = "c", "d" = "d")) + ) }) -test_that("join_keys()[]<-.join_keys with empty name is changed to the key value", { - # set empty key name +testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { jk <- join_keys() - join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", "C") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) +}) - # set key on non-empty variable name equal to "" +testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { jk <- join_keys() - join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", "C" = "") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) + testthat::expect_error(jk[["d1"]] <- "test") +}) - # set key on empty variable name equal to "" +testthat::test_that("[[<-.join_keys adds join_keys specified as named list to the list of keys", { jk <- join_keys() - expect_message(join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B"), c("A"))) + jk[["d1"]] <- list(d1 = "a") + testthat::expect_identical(jk, join_keys(join_key("d1", "d1", "a"))) }) -test_that("join_keys()[]<-.teal_data with empty name is changed to the key value", { - # set empty key name - td <- teal_data() - join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", "C") - expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) - - # set key on non-empty variable name equal to "" - td <- teal_data() - join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", "C" = "") - expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) - - # set key on empty variable name equal to "" - td <- teal_data() - expect_message(join_keys(td)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") - expect_equal(join_keys(td)[["d1"]][["d2"]], setNames(c("B"), c("A"))) +testthat::test_that("[[<-.join_keys assigning NULL drops a key", { + jk <- join_keys(join_key("d1", "d1", "a")) + jk[["d1"]] <- NULL + testthat::expect_null(jk[["d1"]]) }) -# ----------------------------------------------------------------------------- - -test_that("join_keys constructor creates symmetric relationship", { - jk <- join_keys(join_key("d1", "d2", c("A" = "B", "C" = "C"))) +testthat::test_that("[[<-.join_keys adds symmetrical change to the foreign dataset", { + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - expect_identical( + testthat::expect_identical( jk, - structure( - list( - d1 = list(d2 = c("A" = "B", "C" = "C")), - d2 = list(d1 = c("B" = "A", "C" = "C")) - ), - class = c("join_keys", "list") + join_keys( + join_key("d1", "d2", c("A" = "B", "C" = "C")), + join_key("d2", "d1", c("B" = "A", "C" = "C")) ) ) }) +testthat::test_that("[<-.join_keys throws when assigning anything", { + jk_expected <- join_keys() + testthat::expect_error(jk_expected["a"] <- join_key("a", "b", "test"), "Can't use `\\[<-`") +}) -test_that("join_keys cannot set join_keys with incompatible keys", { - # different keys - expect_error( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D", "E" = "F")) - ) - ) +testthat::test_that("[[<- can mutate existing keys", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d1"]][["d2"]] <- "B" + testthat::expect_identical(my_keys, join_keys(join_key("d1", "d2", "B"))) +}) - expect_error( +testthat::test_that("[[<- mutating non-existing keys adds them", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d2"]][["d3"]] <- "B" + testthat::expect_identical( + my_keys, join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = character(0)) + join_key("d1", "d2", "A"), + join_key("d2", "d3", "B") ) ) +}) - expect_error( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d2", "d1", keys = character(0)) - ) +testthat::test_that("[[<- can key pair values can be set to character(0)", { + my_keys <- join_keys( + join_key("d1", "d2", "A"), + join_key("d2", "d3", "B") ) - expect_error( - join_keys( - join_key("d1", "d2", keys = character(0)), - join_key("d2", "d1", keys = c("A" = "B", "C" = "D")) - ) - ) + my_keys[["d1"]][["d2"]] <- character(0) - expect_error( + testthat::expect_identical( + my_keys, join_keys( - join_key("d1", "d2", keys = c("a" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) + join_key("d1", "d2", character(0)), + join_key("d2", "d3", "B") ) ) }) -test_that("join_keys can create join_keys with compatible information", { - # different datasets - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d3", keys = c("A" = "B", "C" = "D")) - ) - ) - - # same keys - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")) - ) - ) - - # reordering keys still matches - expect_silent( - join_keys( - join_key("d1", "d2", keys = c("A" = "B", "C" = "D")), - join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) - ) +testthat::test_that("[[<-.join_keys removes keys with NULL", { + my_keys <- join_keys( + join_key("d1", "d1", "A"), + join_key("d2", "d2", "B") ) + my_keys[["d2"]][["d2"]] <- NULL - # can match with empty - expect_silent( + testthat::expect_identical( + my_keys, join_keys( - join_key("d1", "d2", keys = character(0)), - join_key("d1", "d2", keys = character(0)) + join_key("d1", "d1", "A") ) ) +}) - expect_silent( - join_keys( - join_key("d2", "d1", keys = character(0)), - join_key("d2", "d1", keys = character(0)) - ) +testthat::test_that("[[<-.join_keys removes keys with NULL and applies summetrical changes", { + my_keys <- join_keys( + join_key("d1", "d2", "A"), + join_key("d2", "d1", "A"), + join_key("d2", "d3", "B"), + join_key("d3", "d2", "B") ) + my_keys[["d1"]][["d2"]] <- NULL - # swapping dataset order still matches - expect_silent( + testthat::expect_identical( + my_keys, join_keys( - join_key("d2", "d1", keys = c("B" = "A", "D" = "C")), - join_key("d1", "d2", keys = c("C" = "D", "A" = "B")) + join_key("d2", "d3", "B"), + join_key("d3", "d2", "B") ) ) }) -test_that("join_keys cannot create join_keys with invalid arguments", { - # not using join_key - expect_error(join_keys("d1", "d2", "A")) - # key sets with the same pair of datasets but different values - expect_error(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d1", "B"))) - expect_error(join_keys(join_key("d1", "d2", c("A" = "X")), join_key("d2", "d1", c("A" = "X")))) +testthat::test_that("[[<-.join_keys with empty name is changed to the key value", { + # set empty key name + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) }) -test_that("join_keys can create join_keys with valid arguments", { - # no keys - expect_silent(join_keys()) - # list of keys - expect_silent(join_keys(join_key("d1", "d2", "A"), join_key("d2", "d3", "B"))) - # single key out of list - expect_silent(join_keys(join_key("d1", "d2", "A"))) - # key sets with the same pair of datasets and the same values - expect_silent(join_keys(join_key("d1", "d2", c("A" = "C")), join_key("d2", "d1", c("C" = "A")))) - expect_silent(join_keys(join_key("d1", "d2", "X"), join_key("d2", "d1", "X"))) +testthat::test_that("[[<-.join_keys with empty value is set to its name", { + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) }) -test_that("join_keys creating join keys with d1 -> d2 also creates the key d2 - > d1", { - my_keys <- join_keys(join_key("d1", "d2", c("A" = "C"))) - expect_equal(my_keys[["d2"]][["d1"]], c("C" = "A")) +testthat::test_that("[[<-.join_keys passing key unnamed 'empty' value is ignored", { + # set key on empty variable name equal to "" + jk <- join_keys() + testthat::expect_message(jk[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) }) -test_that("join_keys[ can get all keys for a given dataset", { - my_keys <- join_keys( - join_key("d1", "d2", c("A" = "C")), - join_key("d1", "d3", c("A" = "B", "S" = "T")), - join_key("d2", "d3", c("C" = "U", "L" = "M")) - ) - parents(my_keys) <- list("d2" = "d1", "d3" = "d1") - - expect_length(my_keys[dataset_1 = "d1"], 0) - - expect_equal( - my_keys[dataset_1 = "d1", keep_all_foreign_keys = TRUE], - structure( - list( - "d1" = list(d2 = c("A" = "C"), d3 = c("A" = "B", "S" = "T")), - "d2" = list(d1 = c("C" = "A")), - "d3" = list(d1 = c("B" = "A", "T" = "S")) - ), - class = c("join_keys", "list"), - "__parents__" = list("d2" = "d1", "d3" = "d1") - ) - ) - - expect_equal( - my_keys[dataset_1 = "d3"], - structure( - list( - "d1" = list(d3 = c("A" = "B", "S" = "T")), - "d3" = list(d1 = c("B" = "A", "T" = "S")) - ), - class = c("join_keys", "list"), - "__parents__" = list("d3" = "d1") - ) +# ----------------------------------------------------------------------------- +# +# names<-.join_keys +# +testthat::test_that("names<-.join_keys will replace names at first and second level of the join_keys list", { + jk <- join_keys( + join_key("a", "a", "a"), + join_key("a", "b", "ab"), + join_key("a", "c", "ac"), + join_key("d", "b", "db"), ) -}) -test_that("join_keys can get all keys from join_keys", { - my_keys <- join_keys( - join_key("d1", "d2", c("A" = "C")), - join_key("d1", "d3", c("A" = "B", "S" = "T")), - join_key("d2", "d3", c("C" = "U", "L" = "M")) - ) + names(jk)[1:2] <- c("x", "y") - all_keys <- my_keys - expect_equal(names(all_keys), c("d1", "d2", "d3")) - expect_equal( - my_keys[c("d1", "d2", "d3")], - structure( - list( - "d1" = list(d2 = all_keys[["d1"]][["d2"]], d3 = all_keys[["d1"]][["d3"]]), - "d2" = list(d1 = all_keys[["d2"]][["d1"]], d3 = all_keys[["d2"]][["d3"]]), - "d3" = list(d1 = all_keys[["d3"]][["d1"]], d2 = all_keys[["d3"]][["d2"]]) - ), - class = c("join_keys", "list") + testthat::expect_identical( + jk, + join_keys( + join_key("x", "x", "a"), + join_key("x", "y", "ab"), + join_key("x", "c", "ac"), + join_key("d", "y", "db"), ) ) }) -test_that( - "join_keys join_key with unamed keys vector creates a join_keys with the same column names for both datasets ", - { - test_keys <- join_keys(join_key("d1", "d2", keys = c("A", "B"))) - expect_equal(unname(test_keys[["d1"]][["d2"]]), names(test_keys[["d1"]][["d2"]])) - } -) - -test_that("join_keys if no keys between pair of datasets then getting them returns NULL", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - expect_equal(my_keys[["d1"]][["d3"]], NULL) - expect_equal(my_keys[["d1"]][["d4"]], NULL) -}) - # ----------------------------------------------------------------------------- # -# merge_join_keys - -testthat::test_that("merge_join_keys can handle edge case: calling object is empty", { - x <- join_keys() - y <- join_keys() - - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - testthat::expect_silent(merge_join_keys(x, y)) - testthat::expect_identical(join_keys(x), join_keys(x)) -}) +# c.join_keys -testthat::test_that("c.join_keys can handle edge case: argument is an empty object", { - x <- join_keys() - y <- join_keys() - join_keys(y) <- list( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- join_keys(y) - testthat::expect_silent(merge_join_keys(y, x)) - testthat::expect_identical(previous_output, join_keys(y)) -}) - -testthat::test_that("c.join_keys can handle edge case: argument is a list of empty objects", { - x <- join_keys() - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - previous_output <- y - testthat::expect_silent(c(y, x, x)) - testthat::expect_identical(previous_output, y) - - testthat::expect_silent(c(y, x, x, x)) - testthat::expect_identical(previous_output, y) -}) - -testthat::test_that( - "merge_join_keys throws error when improper argument is passed in without modifying the caller", - { - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) +testthat::test_that("c.join_keys joins join_keys object with join_key objects", { + obj <- join_keys() + obj <- c(obj, join_key("a", "a", "aa"), join_key("b", "b", "bb")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") ) - - previous_output <- join_keys(y) - - testthat::expect_error(y <- merge_join_keys()) - testthat::expect_identical(previous_output, y) - - testthat::expect_error(y <- merge_join_keys(y, 1)) - testthat::expect_identical(previous_output, y) - - testthat::expect_error(y <- merge_join_keys(y, "A")) - testthat::expect_identical(previous_output, y) - - testthat::expect_error(y <- merge_join_keys(y, list())) - testthat::expect_identical(previous_output, y) - - testthat::expect_error(y <- merge_join_keys(list(1))) - testthat::expect_identical(previous_output, y) - - testthat::expect_error(y <- merge_join_keys(y, "A")) - testthat::expect_identical(previous_output, y) - } -) - -testthat::test_that("merge_join_keys does nothing when argument is a join_keys object with identical data", { - x <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) ) - previous_output <- y - testthat::expect_silent(merge_join_keys(y, x)) - testthat::expect_identical(previous_output, y) }) -testthat::test_that( - "merge_join_keys does nothing when argument is a list of one join_keys object with identical data", - { - x <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- y - testthat::expect_silent(c(y, x)) - testthat::expect_identical(previous_output, y) - - testthat::expect_silent(c(y, x, x)) - testthat::expect_identical(previous_output, y) - } -) - -testthat::test_that( - "merge_join_keys does nothing when argument is a list of many join_keys object with identical data", - { - x <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) - ) - - previous_output <- y - testthat::expect_silent(c(y, x, x, x, x, x, x, x, x)) - testthat::expect_identical(previous_output, y) - } -) - -testthat::test_that("merge_join_keys clones data when argument is a list of one join_keys object that is a superset", { - x <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) +testthat::test_that("c.join_keys joins join_keys object with join_keys objects", { + obj <- join_keys() + obj <- c( + obj, + join_keys(join_key("a", "a", "aa")), + join_keys(join_key("b", "b", "bb")) ) - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) ) - - previous_output <- y - testthat::expect_silent(y <- c(y, x)) - testthat::expect_false(identical(previous_output, y)) - testthat::expect_identical(x, y) }) -testthat::test_that("merge_join_keys does nothing when argument is a list of one join_keys object that is a subset", { - x <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")), - join_key("ZZ", "YY", c("zz" = "yy")) +testthat::test_that("c.join_keys joins join_keys object with join_keys and join_key objects", { + obj <- join_keys() + obj <- c( + obj, + join_keys(join_key("a", "a", "aa")), + join_key("b", "b", "bb") ) - y <- join_keys( - join_key("A", "B", c("a" = "b")), - join_key("A", "C", c("a" = "c", "aa" = "cc")), - join_key("Z", "Y", c("z" = "y")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) ) - previous_output <- join_keys(x) - testthat::expect_silent(x <- c(x, y)) - testthat::expect_identical(previous_output, join_keys(x)) }) -testthat::test_that("merge_join_keys merges mutually exclusive data", { - x <- join_keys( - join_key("A", "B", c("a" = "b")) - ) - y <- join_keys( - join_key("Z", "Y", c("z" = "y")) - ) - - z <- join_keys() - z <- c(z, x, y) - manual_join <- c(x, y) - class(manual_join) <- class(new_join_keys()) - testthat::expect_identical(manual_join, z) - - x <- c(x, y) - y <- c(y, x) - - testthat::expect_equal(x, z) - testthat::expect_equal(y, z) - testthat::expect_true(all(y %in% z) && all(z %in% y)) - testthat::expect_true(all(y %in% x) && all(x %in% y)) +testthat::test_that("c.join_keys throws when joining with a list", { + obj <- join_keys() + testthat::expect_error(c( + obj, + list(c = list(c = "cc")) + )) +}) - testthat::expect_identical(sort(names(z)), c("A", "B", "Y", "Z")) - testthat::expect_equal(length(z), 4) - testthat::expect_identical(z$A$B, c("a" = "b")) - testthat::expect_identical(z$B$A, c("b" = "a")) - testthat::expect_identical(z$Z$Y, c("z" = "y")) - testthat::expect_identical(z$Y$Z, c("y" = "z")) +testthat::test_that("c.join_keys doesn't throw when second object is empty join_keys", { + x <- join_keys(join_key("a", "a", "aa")) + y <- join_keys() + testthat::expect_no_error(c(x, y)) }) # ----------------------------------------------------------------------------- From 80cb5eb8f269056eaf1c293870ed577ad75f57f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 14:58:54 +0100 Subject: [PATCH 090/152] pr: removes merge_join_keys --- R/join_keys.R | 80 ++++++++++++----------------------- man/assert_join_keys_alike.Rd | 4 +- man/merge_join_keys.Rd | 26 ------------ 3 files changed, 31 insertions(+), 79 deletions(-) delete mode 100644 man/merge_join_keys.Rd diff --git a/R/join_keys.R b/R/join_keys.R index d6eb5fbd2..bcfb8b660 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -173,9 +173,31 @@ join_keys.default <- function(...) { #' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) c.join_keys <- function(...) { x <- rlang::list2(...) + checkmate::assert_class(x[[1]], c("join_keys", "list")) checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) - merge_join_keys.join_keys(x[[1]], x[-1]) + join_keys_obj <- x[[1]] + x <- x[-1] + if ( + checkmate::test_class(x, "join_key_set") || + checkmate::test_class(x, c("join_keys", "list")) + ) { + x <- list(x) + } + + lapply(x, assert_join_keys_alike) + + if (checkmate::test_list(x, types = "join_key_set")) { + jk_temp <- new_join_keys() + join_keys(jk_temp) <- x + x <- list(jk_temp) + } + + for (el in x) { + join_keys_obj <- utils::modifyList(join_keys_obj, el) + } + + join_keys_obj } #' The Names of an `join_keys` Object @@ -408,57 +430,6 @@ c.join_keys <- function(...) { x } -#' @rdname merge_join_keys -#' @keywords internal -merge_join_keys <- function(join_keys_obj, new_join_keys) { - UseMethod("merge_join_keys", join_keys_obj) -} - -#' @rdname merge_join_keys -#' @keywords internal -merge_join_keys.default <- function(join_keys_obj, new_join_keys) { - merge_join_keys(join_keys(join_keys_obj), new_join_keys) -} - -#' Merging a list (or one) of `join_keys` objects into the current `join_keys` object -#' -#' @rdname merge_join_keys -#' -#' @param join_keys_obj (`join_keys`) object to merge the new_join_keys. -#' @param new_join_keys `list` of `join_keys` objects or single `join_keys` object -#' -#' @return a new `join_keys` object with the resulting merge. -#' -#' @keywords internal -merge_join_keys.join_keys <- function(join_keys_obj, new_join_keys) { - if ( - checkmate::test_class(new_join_keys, "join_key_set") || - checkmate::test_class(new_join_keys, "join_keys") - ) { - new_join_keys <- list(new_join_keys) - } - - lapply(new_join_keys, assert_join_keys_alike) - - if (checkmate::test_list(new_join_keys, types = "join_key_set")) { - jk_temp <- new_join_keys() - join_keys(jk_temp) <- new_join_keys - new_join_keys <- list(jk_temp) - } - - checkmate::assert_list(new_join_keys, types = c("join_keys"), min.len = 1) - - for (el in new_join_keys) { - join_keys_obj <- utils::modifyList(join_keys_obj, el) - } - - return(join_keys_obj) -} - -# S3 methods have to be exported, otherwise `.S3method` needs to be used -.S3method("merge_join_keys", "teal_data", merge_join_keys.default) -.S3method("merge_join_keys", "join_keys", merge_join_keys.join_keys) - #' Length of `join_keys` object. #' @inheritParams base::length #' @export @@ -514,6 +485,11 @@ new_join_keys <- function() { } #' Assert the `join_keys` class membership of an argument +#' +#' Relaxed validation of a `join_keys` object. It accepts `join_keys`, a list +#' of `join_key_set` (not symmetrical) or even a named list of character vectors +#' without looking at the class name. +#' #' @inheritParams checkmate::assert_class #' #' @return `x` invisibly diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd index 86c8535cb..b0e685817 100644 --- a/man/assert_join_keys_alike.Rd +++ b/man/assert_join_keys_alike.Rd @@ -24,6 +24,8 @@ Collection to store assertion messages. See \code{\link[checkmate]{AssertCollect \code{x} invisibly } \description{ -Assert the \code{join_keys} class membership of an argument +Relaxed validation of a \code{join_keys} object. It accepts \code{join_keys}, a list +of \code{join_key_set} (not symmetrical) or even a named list of character vectors +without looking at the class name. } \keyword{internal} diff --git a/man/merge_join_keys.Rd b/man/merge_join_keys.Rd deleted file mode 100644 index aa920b11f..000000000 --- a/man/merge_join_keys.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{merge_join_keys} -\alias{merge_join_keys} -\alias{merge_join_keys.default} -\alias{merge_join_keys.join_keys} -\title{Merging a list (or one) of \code{join_keys} objects into the current \code{join_keys} object} -\usage{ -merge_join_keys(join_keys_obj, new_join_keys) - -\method{merge_join_keys}{default}(join_keys_obj, new_join_keys) - -\method{merge_join_keys}{join_keys}(join_keys_obj, new_join_keys) -} -\arguments{ -\item{join_keys_obj}{(\code{join_keys}) object to merge the new_join_keys.} - -\item{new_join_keys}{\code{list} of \code{join_keys} objects or single \code{join_keys} object} -} -\value{ -a new \code{join_keys} object with the resulting merge. -} -\description{ -Merging a list (or one) of \code{join_keys} objects into the current \code{join_keys} object -} -\keyword{internal} From 994e6aa695c3d429e73ece53fbf54c0b53888e9b Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 14 Nov 2023 15:47:06 +0100 Subject: [PATCH 091/152] tidyup tests parent tests --- tests/testthat/test-join_keys.R | 30 +++-- tests/testthat/test-parents.R | 212 ++++++++------------------------ 2 files changed, 69 insertions(+), 173 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 2e05374f6..da402d2be 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -162,6 +162,26 @@ testthat::test_that("[.join_keys returns join_keys object for given dataset incl testthat::expect_equal(my_keys["d2"], expected) }) +testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its childs", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ab"), + join_key("d3", "d1", "ac") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d2", "d1", "ab") + ) + parents(expected) <- list("d2" = "d1") + + testthat::expect_equal(my_keys["d2"], expected) +}) + testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset", { my_keys <- join_keys(join_key("d1", "d1", "a")) testthat::expect_length(my_keys["d2"], 0) @@ -469,13 +489,3 @@ testthat::test_that("print.join_keys for a non-empty set", { "A join_keys object containing foreign keys between 2 datasets:" ) }) - -testthat::test_that("parents<- sets the parents of datasets when they are empty", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "fk"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_identical( - ss <- parents(jk), - list(df1 = character(0), df2 = "df1") - ) -}) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 1bc1e1363..879e9ef22 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -2,206 +2,92 @@ # # parents() # - -test_that("parents will return empty list when empty/not set", { - jk <- join_keys() - expect_identical(parents(jk), list()) -}) - -test_that("parents will return empty NULL when there is no parent", { +testthat::test_that("parents will return empty list when empty/not set", { jk <- join_keys() - expect_null(parents(jk)[["d1"]]) -}) - -testthat::test_that("parents returns a list of all parents", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_identical(parents(jk), list(df1 = character(0), df2 = "df1")) -}) - -testthat::test_that("parents returns an empty list when no parents are present", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) testthat::expect_identical(parents(jk), list()) }) -testthat::test_that("parents throws error when dataname input is provided", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_error(parents(jk, "df1"), "unused argument \\(\"df1\"\\)") +testthat::test_that("parents returns the same list as used in parents<-", { + jk <- join_keys(join_key("a", "b", "ab")) + parents <- list(b = "a") + parents(jk) <- parents + testthat::expect_identical(parents(jk), parents) }) # ----------------------------------------------------------------------------- # # parents<- # - -test_that("parents<- does nothing with empty value", { - jk <- join_keys() - jk2 <- `parents<-`(jk) - - expect_length(parents(jk2), 0) - expect_equal(jk, jk2) -}) - -test_that("parents<- will fail if datasets don't exist", { - jk <- join_keys() - expect_error(parents(jk)["d1"] <- "d2") - expect_error(parents(jk)["d3"] <- "d4") +testthat::test_that("parents<- accepts a named list containing (non-empty, non-missing) character", { + jk <- join_keys(join_key("a", "b", "test")) + testthat::expect_no_error(parents(jk) <- list(b = "a")) }) -test_that("parents<- will add to parents attribute using `[` notation", { +testthat::test_that("parents<- single parent can be changed utilizing list functionality with [[<-", { jk <- join_keys( - join_key("d1", "d2", "k"), - join_key("d3", "d4", "q") + join_key("a", "b", "ab"), + join_key("c", "d", "cd") ) - parents(jk)["d1"] <- "d2" - parents(jk)["d3"] <- "d4" - - expect_length(parents(jk), 2) - expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) + parents(jk)[["a"]] <- "b" + parents(jk)[["c"]] <- "d" + testthat::expect_identical(parents(jk), list(a = "b", c = "d")) }) -test_that("parents<- will add to parents attribute using `[[` notation", { +testthat::test_that("parents<- dataset can't be own parent", { jk <- join_keys( - join_key("d1", "d2", "k"), - join_key("d3", "d4", "q") + join_key("a", "b", "ab"), + join_key("c", "d", "cd") ) - parents(jk)[["d1"]] <- "d2" - parents(jk)[["d3"]] <- "d4" - - expect_length(parents(jk), 2) - expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) + testthat::expect_error(parents(jk) <- list(a = "a")) }) -test_that("parents<- will add to parents attribute using list", { - jk <- join_keys( - join_key("d1", "d2", "k"), - join_key("d3", "d4", "q") - ) - parents(jk) <- list(d1 = "d2", "d3" = "d4") - - expect_length(parents(jk), 2) - expect_identical(parents(jk), list(d1 = "d2", d3 = "d4")) -}) - -test_that("parents<- ensures it is a directed acyclical graph (DAG)", { +testthat::test_that("parents<- ensures it is a directed acyclical graph (DAG)", { cyclic_jk <- join_keys( join_key("a", "b", "id"), join_key("b", "c", "id"), join_key("c", "a", "id") ) - expect_error( - parents(cyclic_jk) <- list( - a = "b", - b = "c", - c = "a" - ), + testthat::expect_error( + parents(cyclic_jk) <- list(a = "b", b = "c", c = "a"), "Cycle detected" ) }) -testthat::test_that("parents<- throws error when overwriting the parent value with a different value", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_error(parents(jk) <- list(df1 = character(0), df2 = "df5")) -}) - -testthat::test_that("parents<- works when overwriting the parent value with the same value", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) -}) - -# ----------------------------------------------------------------------------- -# -# parent() -# - -testthat::test_that("parent returns the parent name of the dataset", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_identical(parent(jk, "df1"), character(0)) - testthat::expect_identical(parent(jk, "df2"), "df1") -}) +testthat::test_that("parents<- single parent can be changed utilizing list functionality with [[<-", { + jk <- join_keys( + join_key("a", "b", "ab"), + join_key("c", "d", "cd") + ) + parents(jk)[["a"]] <- "b" + parents(jk)[["c"]] <- "d" -testthat::test_that("parent returns NULL when dataset is not found or not passed", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df2", c("id" = "id"))) - testthat::expect_silent(parents(jk) <- list(df1 = character(0), df2 = "df1")) - testthat::expect_null(parent(jk)) - testthat::expect_null(parent(jk, "df3")) + testthat::expect_identical(parents(jk), list(a = "b", c = "d")) }) -# ----------------------------------------------------------------------------- -# -# assert_parent_child errors - -test_that("parents<-.join_keys (assert_parent_child) will detect empty keys", { - jk <- join_keys() - jk[["d1"]][["d2"]] <- character(0) - expect_error( - parents(jk) <- list(d1 = "d2"), - "No join keys from .* to its parent .* and vice versa" - ) +testthat::test_that("parents<- fails when value isn't a list (non-empty, non-missing) character", { + jk <- join_keys(join_key("a", "b", "test")) + # testthat::expect_error(parents(jk) <- list(b = character(0))) # todo: make an assert + testthat::expect_error(parents(jk) <- list(b = 1)) + testthat::expect_error(parents(jk) <- list(b = NA_character_)) + testthat::expect_error(parents(jk) <- list(b = NULL)) + testthat::expect_error(parents(jk) <- NULL) }) -test_that("parents<-.join_keys (assert_parent_child) will detect invalid key pairs", { - jk <- join_keys() - jk[["d1"]][["d2"]] <- "key1" - jk[["d2"]][["d1"]] <- character(0) - expect_error( - parents(jk) <- list(d1 = "d2"), - "No join keys from .* to its parent .* and vice versa" - ) - - jk2 <- join_keys() - jk2[["d2"]][["d1"]] <- "key1" - jk2[["d1"]][["d2"]] <- character(0) - expect_error( - parents(jk2) <- list(d1 = "d2"), - "No join keys from .* to its parent .* and vice versa" - ) +testthat::test_that("parents<- setting parents again overwrites previous state", { + jk <- join_keys(join_key("a", "b", "test"), join_key("c", "d", "test")) + parents(jk) <- list(a = "b") + parents(jk) <- list(b = "a") + testthat::expect_identical(parents(jk), list(b = "a")) }) -testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { - jk <- join_keys() - join_keys(jk) <- list(join_key("df1", "df1", c("id" = "id"))) - testthat::expect_error( - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), - "No join keys from df2 to its parent \\(df1\\) and vice versa" - ) -}) -testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { - jk <- join_keys() - join_keys(jk) <- list( - join_key("df1", "df1", c("id" = "id")) - ) - # Change class as trick to allow for corrupt join_keys - class(jk) <- "list" - jk[["df2"]][["df1"]] <- "id" - class(jk) <- class(new_join_keys()) - testthat::expect_error( - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), - "No join keys from df2 parent name \\(df1\\) to df2" - ) -}) -testthat::test_that("parents<-.join_keys (assert_parent_child) throws error if no join_keys exist for child-parent", { - jk <- join_keys() - join_keys(jk) <- list( - join_key("df1", "df1", c("id" = "id")) - ) - class(jk) <- "list" - jk[["df1"]][["df2"]] <- "id" - class(jk) <- class(new_join_keys()) - expect_error( - parents(jk) <- list(df1 = character(0), df2 = "df1", df3 = "df1"), - "No join keys from df2 to its parent \\(df1\\)" +testthat::test_that("parents<- sets parent datasets to join_keys kept in teal_data", { + td <- teal_data( + a = data.frame(), + b = data.frame(), + join_keys = join_keys(join_key("a", "b", "test")) ) + parents(td) <- list(b = "a") + testthat::expect_identical(parents(td), list(b = "a")) }) From 6853a270c3f7f2343d638cc9f609ed987cb706ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 16:53:37 +0100 Subject: [PATCH 092/152] pr: remove cdisc_join_keys in favor of using default_cdisc_join_keys --- NAMESPACE | 1 - R/cdisc_data.R | 5 +- R/cdisc_join_keys.R | 70 +++++--------- R/join_keys.R | 4 + R/testhat-helpers.R | 2 +- R/zzz.R | 4 +- man/build_cdisc_join_keys.Rd | 16 ++++ man/cdisc_data.Rd | 2 +- man/join_keys.Rd | 15 +-- man/local_cdisc_data_mixed_call.Rd | 2 +- tests/testthat/helper-compare.R | 2 +- tests/testthat/test-cdisc_data.R | 2 +- tests/testthat/test-cdisc_join_keys.R | 129 +++----------------------- 13 files changed, 67 insertions(+), 187 deletions(-) create mode 100644 man/build_cdisc_join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index 10ca80d93..df434b7bf 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,7 +87,6 @@ export(cdisc_dataset) export(cdisc_dataset_connector) export(cdisc_dataset_connector_file) export(cdisc_dataset_file) -export(cdisc_join_keys) export(code_cdisc_dataset_connector) export(code_dataset_connector) export(col_labels) diff --git a/R/cdisc_data.R b/R/cdisc_data.R index 7381cac0e..cb307c9d9 100644 --- a/R/cdisc_data.R +++ b/R/cdisc_data.R @@ -31,7 +31,7 @@ #' }) #' cdisc_data <- function(..., - join_keys = teal.data::cdisc_join_keys(...), + join_keys = teal.data::default_cdisc_join_keys[names(rlang::list2(...))], code = character(0), check = FALSE) { teal_data(..., join_keys = join_keys, code = code, check = check) @@ -91,8 +91,7 @@ deprecated_join_keys_extract <- function(data_objects, join_keys) { } # Keep non-check setting of parents (this will be removed in refactor) - attr(join_keys, "__parents__") <- new_parents - # parents(join_keys) <- new_parents + attr(join_keys, "__parents__") <- new_parents # nolint: object_name_linter join_keys <- update_keys_given_parents(join_keys) join_keys diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index 2047207d0..30ad35457 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -1,60 +1,36 @@ -#' @rdname join_keys +#' List containing the default `CDISC` join keys #' #' @details -#' `cdisc_join_keys` is a wrapper around `join_keys` that sets the default -#' join keys for CDISC datasets. It is used internally by `cdisc_data` to -#' set the default join keys for CDISC datasets. +#' This data object is created at loading time from `cdisc_datasets/cdisc_datasets.yaml`. #' +#' @name default_cdisc_join_keys +#' @docType data #' @export +NULL + +#' Helper method to build `default_cdisc_join_keys` +#' @param default_cdisc_keys (`list`) default definition of primary and foreign +#' keys for `CDISC` datasets #' -#' @examples -#' -#' # Default CDISC join keys -#' -#' cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") -cdisc_join_keys <- function(...) { - data_objects <- rlang::list2(...) +#' @keywords internal +build_cdisc_join_keys <- function(default_cdisc_keys) { + checkmate::assert_list(default_cdisc_keys, types = "list") - jk <- join_keys() - for (ix in seq_along(data_objects)) { - item <- data_objects[[ix]] - name <- names(data_objects)[ix] + jk <- new_join_keys() + for (name in names(default_cdisc_keys)) { + # Set default primary keys + keys_list <- default_cdisc_keys[[name]] - if (checkmate::test_class(item, "join_key_set")) { - jk[[get_dataset_1(item)]][[get_dataset_2(item)]] <- get_keys(item) - } else if ( - checkmate::test_multi_class(item, c("TealDataConnector", "TealDataset", "TealDatasetConnector")) - ) { - # Do nothing. This is handled by `teal_data()` - } else { - if ((is.null(name) || identical(trimws(name), "")) && is.character(item)) { - name <- item - } - - if (name %in% names(default_cdisc_keys)) { - # Set default primary keys - keys_list <- default_cdisc_keys[[name]] - jk[[name]][[name]] <- keys_list$primary + if (!is.null(keys_list[["primary"]])) { + jk[[name]][[name]] <- keys_list[["primary"]] + } - if (!is.null(keys_list$parent)) { - if (!is.null(keys_list$foreign)) { - jk[[name]][[keys_list$parent]] <- keys_list$foreign - } - parents(jk)[[name]] <- keys_list$parent - } + if (!is.null(keys_list[["parent"]])) { + if (!is.null(keys_list[["foreign"]])) { + jk[[name]][[keys_list[["parent"]]]] <- keys_list[["foreign"]] } + parents(jk)[[name]] <- keys_list[["parent"]] } } - jk } - -#' List containing the default `CDISC` join keys -#' -#' @details -#' This data object is created at loading time from `cdisc_datasets/cdisc_datasets.yaml`. -#' -#' @name default_cdisc_join_keys -#' @docType data -#' @export -NULL diff --git a/R/join_keys.R b/R/join_keys.R index bcfb8b660..a568b5609 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -248,6 +248,10 @@ c.join_keys <- function(...) { return(x) } + if (is.null(i)) { + return(new_join_keys()) # replicate base R + } + checkmate::assert( combine = "or", checkmate::check_integerish(i), diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index d3713d5e7..55dc43995 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -180,7 +180,7 @@ test_join_keys_combinatory <- function(obj) { #' @return a `CDISC` data set with the following tables: `ADSL`, `ADTTE` and `ADAE` #' #' @keywords internal -local_cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = cdisc_join_keys()) { +local_cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = join_keys()) { adsl_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADSL")))) adtte_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADTTE")))) adae_raw <- as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) diff --git a/R/zzz.R b/R/zzz.R index 620002b83..45ffa8762 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -3,13 +3,13 @@ # copy from excel file default_cdisc_keys <- yaml::yaml.load_file( get_package_file("teal.data", "cdisc_datasets/cdisc_datasets.yaml") - ) # nolint + ) assign("default_cdisc_keys", default_cdisc_keys, envir = parent.env(environment())) # update default_cdisc_join_keys assign( "default_cdisc_join_keys", - do.call(cdisc_join_keys, as.list(names(default_cdisc_keys))), + build_cdisc_join_keys(default_cdisc_keys), envir = parent.env(environment()) ) diff --git a/man/build_cdisc_join_keys.Rd b/man/build_cdisc_join_keys.Rd new file mode 100644 index 000000000..46f59cba1 --- /dev/null +++ b/man/build_cdisc_join_keys.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cdisc_join_keys.R +\name{build_cdisc_join_keys} +\alias{build_cdisc_join_keys} +\title{Helper method to build \code{default_cdisc_join_keys}} +\usage{ +build_cdisc_join_keys(default_cdisc_keys) +} +\arguments{ +\item{default_cdisc_keys}{(\code{list}) default definition of primary and foreign +keys for \code{CDISC} datasets} +} +\description{ +Helper method to build \code{default_cdisc_join_keys} +} +\keyword{internal} diff --git a/man/cdisc_data.Rd b/man/cdisc_data.Rd index 061f737c3..15d5afcf2 100644 --- a/man/cdisc_data.Rd +++ b/man/cdisc_data.Rd @@ -6,7 +6,7 @@ \usage{ cdisc_data( ..., - join_keys = teal.data::cdisc_join_keys(...), + join_keys = teal.data::default_cdisc_join_keys[names(rlang::list2(...))], code = character(0), check = FALSE ) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 8f06beadb..940f3125f 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -1,7 +1,6 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/cdisc_join_keys.R, R/join_keys.R -\name{cdisc_join_keys} -\alias{cdisc_join_keys} +% Please edit documentation in R/join_keys.R +\name{join_keys} \alias{join_keys} \alias{join_keys.join_keys} \alias{join_keys.teal_data} @@ -16,8 +15,6 @@ \alias{[[<-.join_keys} \title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} \usage{ -cdisc_join_keys(...) - join_keys(...) \method{join_keys}{join_keys}(...) @@ -64,10 +61,6 @@ datasets even if they are not a parent of the selected dataset.} \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} } \details{ -\code{cdisc_join_keys} is a wrapper around \code{join_keys} that sets the default -join keys for CDISC datasets. It is used internally by \code{cdisc_data} to -set the default join keys for CDISC datasets. - \itemize{ \item \code{join_keys()}: When called without arguments it will return an empty constructor. @@ -90,10 +83,6 @@ Setter via index directly (bypassing the need to use \code{join_key()}). When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. } \examples{ - -# Default CDISC join keys - -cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") # Setting join keys ---- jk <- join_keys( diff --git a/man/local_cdisc_data_mixed_call.Rd b/man/local_cdisc_data_mixed_call.Rd index ac0a1e17d..266dc82e5 100644 --- a/man/local_cdisc_data_mixed_call.Rd +++ b/man/local_cdisc_data_mixed_call.Rd @@ -4,7 +4,7 @@ \alias{local_cdisc_data_mixed_call} \title{(test helper) Create test data for \code{CDISC} data} \usage{ -local_cdisc_data_mixed_call(check = TRUE, join_keys1 = cdisc_join_keys()) +local_cdisc_data_mixed_call(check = TRUE, join_keys1 = join_keys()) } \arguments{ \item{check}{(\code{logical}) reproducibility check - whether to perform a check that the pre-processing diff --git a/tests/testthat/helper-compare.R b/tests/testthat/helper-compare.R index ead2439e8..4062875f4 100644 --- a/tests/testthat/helper-compare.R +++ b/tests/testthat/helper-compare.R @@ -11,7 +11,7 @@ #' @inheritParams testthat::compare #' #' @keywords internal -compare.join_keys <- function(x, y, ...) { +compare.join_keys <- function(x, y, ...) { # nolint: object_name_linter as_map <- function(x) { attr(x, "extra_class") <- class(x) attr(x, "class") <- "list" diff --git a/tests/testthat/test-cdisc_data.R b/tests/testthat/test-cdisc_data.R index fdbd7a0ba..e117a1a32 100644 --- a/tests/testthat/test-cdisc_data.R +++ b/tests/testthat/test-cdisc_data.R @@ -55,7 +55,7 @@ testthat::test_that("cdisc_data sets primary keys as join_keys when no join_keys df1 <- dataset("df1", df1, keys = "id") df2 <- dataset("df2", df2, keys = "df2_id") - data <- cdisc_data(df1, df2, check = FALSE) + data <- cdisc_data(df1 = df1, df2 = df2, check = FALSE) jks <- join_keys( join_key("df1", "df1", "id"), diff --git a/tests/testthat/test-cdisc_join_keys.R b/tests/testthat/test-cdisc_join_keys.R index 388a1e7ae..7596381ee 100644 --- a/tests/testthat/test-cdisc_join_keys.R +++ b/tests/testthat/test-cdisc_join_keys.R @@ -1,123 +1,20 @@ -test_that("cdisc_join_keys merges joins keys with CDISC default join_keys", { - result <- cdisc_join_keys(join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), "ADTTE") - - expect_named(result, c("ADSL", "ADTTE", "dataset_A", "dataset_B"), ignore.order = TRUE) - expect_identical(result[["dataset_B"]][["dataset_A"]], c("col_a" = "col_1")) -}) - -test_that("cdisc_join_keys will generate join_keys for named list with non-named elements", { - new_dataset <- cdisc_join_keys("ADSL", ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate join_keys for character list", { - new_dataset <- cdisc_join_keys("ADSL", "ADTTE") - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will generate join_keys for named list", { - new_dataset <- cdisc_join_keys(ADSL = rADSL, ADTTE = rADTTE) - jk <- join_keys(new_dataset) - - expect_identical(unname(jk[["ADSL"]][["ADSL"]]), default_cdisc_keys[["ADSL"]]$primary) - expect_identical(unname(jk[["ADTTE"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$primary) - - expect_identical(unname(jk[["ADSL"]][["ADTTE"]]), default_cdisc_keys[["ADTTE"]]$foreign) - expect_identical(unname(jk[["ADTTE"]][["ADSL"]]), default_cdisc_keys[["ADTTE"]]$foreign) -}) - -test_that("cdisc_join_keys will retrieve ADTTE primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - internal_keys <- default_cdisc_keys[["ADTTE"]] - jk <- cdisc_join_keys("ADTTE") - primary_keys <- unname(jk[["ADTTE"]][["ADTTE"]]) - - expect_equal(primary_keys, internal_keys$primary) - - foreign_keys <- unname(jk[["ADTTE"]][[internal_keys$parent]]) - expect_equal(foreign_keys, internal_keys$foreign) -}) - -test_that("cdisc_join_keys will retrieve known primary and foreign keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - internal_keys <- default_cdisc_keys[[.x]] - jk <- cdisc_join_keys(.x) - primary_keys <- unname(jk[[.x]][[.x]]) - expect_equal(primary_keys, internal_keys$primary) - if (!is.null(internal_keys$foreign)) { - foreign_keys <- unname(jk[[.x]][[internal_keys$parent]]) - expect_equal(foreign_keys, internal_keys$foreign) - } - character(0) - }, - character(0) - ) +test_that("default_cdisc_join_keys is assigned in package environment", { + expect_true(exists("default_cdisc_join_keys")) + expect_gt(length(default_cdisc_join_keys), 0) }) -test_that("cdisc_join_keys will set parents of datasets", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - jk <- cdisc_join_keys(.x) - parent_name <- default_cdisc_keys[[.x]][["parent"]] - if (!is.null(parent_name)) { - expect_identical(parent(jk, .x), parent_name) - } - character(0) - }, - character(0) - ) -}) - -test_that("cdisc_join_keys will retrieve known primary keys", { - datasets <- names(default_cdisc_keys) - - vapply( - datasets, - function(.x) { - jk <- cdisc_join_keys(.x) - expect_equal(unname(jk[[.x]][[.x]]), get_cdisc_keys(.x)) - character(0) - }, - character(0) - ) +test_that("default_cdisc_join_keys subsetting of datasets with parent is valid", { + # indirect test to build_cdisc_join_keys + ds <- c("ADTTE", "ADSL") + result <- default_cdisc_join_keys[ds] + expect_length(result, 2) + expect_length(parents(result), 1) }) -test_that("cdisc_join_keys does nothing with TealDataset", { - adae_cf <- callable_function( - function() as.data.frame(as.list(setNames(nm = get_cdisc_keys("ADAE")))) - ) - adae_cdc <- cdisc_dataset_connector("ADAE", adae_cf, keys = get_cdisc_keys("ADAE")) - expect_length(join_keys(cdisc_join_keys(adae_cdc)), 0) -}) - -test_that("default_cdisc_join_keys can get a valid `join_keys` object", { - ds1 <- c("ADTTE", "ADEX", "ADRS") - result <- default_cdisc_join_keys[ds1] +test_that("default_cdisc_join_keys subsetting of dataset without parent contains parent", { + # indirect test to build_cdisc_join_keys + ds <- c("ADTTE", "ADEX", "ADRS") + result <- default_cdisc_join_keys[ds] expect_length(result, 4) expect_length(parents(result), 3) - - ds2 <- c("ADTTE", "ADSL") - result2 <- default_cdisc_join_keys[ds2] - expect_length(result2, 2) - expect_length(parents(result2), 1) }) From bcb0637f418eaed37b0842f27aa8e6d7c9e632bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Tue, 14 Nov 2023 18:23:07 +0100 Subject: [PATCH 093/152] pr: prevent incompatible keys on [[<- edge case --- R/join_keys.R | 22 +++++++++++++++------- tests/testthat/test-join_keys.R | 9 +++++++++ 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index a568b5609..bd12bca1a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -136,16 +136,16 @@ join_keys.default <- function(...) { # check if any join_key_sets share the same datasets but different values for (idx_1 in seq_along(value)) { - for (idx_2 in seq_along(value[idx_1])) { + for (idx_2 in seq_along(value)[-seq(1, idx_1)]) { assert_compatible_keys(value[[idx_1]], value[[idx_2]]) } + dataset_1 <- get_dataset_1(value[[idx_1]]) dataset_2 <- get_dataset_2(value[[idx_1]]) keys <- get_keys(value[[idx_1]]) join_keys_obj[[dataset_1]][[dataset_2]] <- keys } - join_keys_obj } @@ -374,10 +374,18 @@ c.join_keys <- function(...) { } # Normalize values - norm_value <- lapply(names(value), function(.x) { - get_keys(join_key(i, .x, value[[.x]])) + norm_value <- lapply(seq_along(value), function(.x) { + join_key(i, names(value)[.x], value[[.x]]) }) + # Check if multiple modifications don't have a conflict + for (idx_1 in seq_along(norm_value)) { + for (idx_2 in seq_along(norm_value)[-seq(1, idx_1)]) { + assert_compatible_keys(norm_value[[idx_1]], norm_value[[idx_2]]) + } + } + + norm_value <- lapply(norm_value, get_keys) names(norm_value) <- names(value) value <- norm_value @@ -540,7 +548,7 @@ check_join_keys_alike <- function(x) { #' return TRUE if compatible, throw error otherwise #' @keywords internal assert_compatible_keys <- function(join_key_1, join_key_2) { - error_message <- function(dataset_1, dataset_2) { + stop_message <- function(dataset_1, dataset_2) { stop( paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2) ) @@ -559,7 +567,7 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { # must contain the same named elements if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) { if (!identical(sort(keys_one), sort(keys_two))) { - error_message(dataset_1_one, dataset_2_one) + stop_message(dataset_1_one, dataset_2_one) } } @@ -576,7 +584,7 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { xor(length(keys_one) == 0, length(keys_two) == 0) || !identical(sort(keys_one), sort(setNames(names(keys_two), keys_two))) ) { - error_message(dataset_1_one, dataset_2_one) + stop_message(dataset_1_one, dataset_2_one) } } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index da402d2be..8c044d34b 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -382,6 +382,15 @@ testthat::test_that("[[<-.join_keys passing key unnamed 'empty' value is ignored testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) }) +testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for same datasets, but different keys", { + jk <- join_keys() + + testthat::expect_error( + jk[["ds1"]] <- list(ds2 = "new", ds2 = "new_but_different"), + "cannot specify multiple different join keys between datasets" + ) +}) + # ----------------------------------------------------------------------------- # # names<-.join_keys From 923b2519ec6ea3d484a9710b60325818b2e9a2f5 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 14 Nov 2023 21:56:11 +0100 Subject: [PATCH 094/152] removing redundant methods - they were checking for x in method c, which is protected anyway by asserts in c. --- R/join_keys.R | 49 ------------------------------------------------- 1 file changed, 49 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index bd12bca1a..fd5c8deff 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -185,8 +185,6 @@ c.join_keys <- function(...) { x <- list(x) } - lapply(x, assert_join_keys_alike) - if (checkmate::test_list(x, types = "join_key_set")) { jk_temp <- new_join_keys() join_keys(jk_temp) <- x @@ -496,53 +494,6 @@ new_join_keys <- function() { ) } -#' Assert the `join_keys` class membership of an argument -#' -#' Relaxed validation of a `join_keys` object. It accepts `join_keys`, a list -#' of `join_key_set` (not symmetrical) or even a named list of character vectors -#' without looking at the class name. -#' -#' @inheritParams checkmate::assert_class -#' -#' @return `x` invisibly -#' -#' @keywords internal -assert_join_keys_alike <- function(x, .var.name = checkmate::vname(x), add = NULL) { # nolint: object_name_linter - if (missing(x)) { - stop(sprintf("argument \"%s\" is missing, with no default", .var.name)) - } - res <- check_join_keys_alike(x) - - checkmate::makeAssertion(x, res, var.name = .var.name, add) -} - -#' @rdname assert_join_keys_alike -check_join_keys_alike <- function(x) { - result <- checkmate::check_list(x, names = "named", types = "list") - if (checkmate::test_string(result)) { - return(result) - } - result <- all( - vapply( - x, - function(el) { - checkmate::test_list(el, types = c("character", "null"), names = "named") - }, - logical(1) - ) - ) - - if (isFALSE(all(result))) { - return( - paste( - "Elements of list may only be named lists with a vector of type `character`", - "(that may be named or partially named)" - ) - ) - } - result -} - #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise From 5d4d1a6aedbe2b51674d35f2565a14ac18a46403 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 14 Nov 2023 21:58:08 +0100 Subject: [PATCH 095/152] various --- R/get_join_keys.R | 3 +- R/join_key.R | 4 +- R/join_keys.R | 49 +++----- R/parents.R | 50 ++++----- R/teal_data.R | 12 +- R/testhat-helpers.R | 175 ----------------------------- man/assert_join_keys_alike.Rd | 31 ----- man/assert_parent_child.Rd | 6 +- man/get_join_keys.Rd | 5 +- man/join_key.Rd | 4 +- man/join_keys.Rd | 27 +---- man/local_cdisc_data_mixed_call.Rd | 4 - man/local_join_keys.Rd | 20 ---- man/local_teal_data.Rd | 15 --- man/parent.Rd | 4 +- man/parents.Rd | 14 +-- man/test_join_keys_add.Rd | 30 ----- man/test_join_keys_bare.Rd | 21 ---- man/test_join_keys_combinatory.Rd | 20 ---- man/update_join_keys_to_primary.Rd | 4 +- man/update_keys_given_parents.Rd | 4 +- tests/testthat/test-join_keys.R | 4 +- 22 files changed, 77 insertions(+), 429 deletions(-) delete mode 100644 man/assert_join_keys_alike.Rd delete mode 100644 man/local_join_keys.Rd delete mode 100644 man/local_teal_data.Rd delete mode 100644 man/test_join_keys_add.Rd delete mode 100644 man/test_join_keys_bare.Rd delete mode 100644 man/test_join_keys_combinatory.Rd diff --git a/R/get_join_keys.R b/R/get_join_keys.R index 978cc9f8e..56edc4378 100644 --- a/R/get_join_keys.R +++ b/R/get_join_keys.R @@ -11,8 +11,7 @@ get_join_keys <- function(data) { } #' @rdname get_join_keys -#' @inheritParams join_keys -#' @param dataset_2 (`character(1)`) name of a dataset. +#' @inheritParams join_key #' @param value value to assign #' @export `get_join_keys<-` <- function(data, dataset_1, dataset_2 = NULL, value) { diff --git a/R/join_key.R b/R/join_key.R index 8f50df276..ba0872d83 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -5,8 +5,8 @@ #' @details `join_key()` will create a relationship for the variables on a pair #' of datasets. #' -#' @inheritParams join_keys -#' @param dataset_2 (optional `character`) other dataset name. In case it is omitted, then it +#' @param dataset_1 (`character(1)`) dataset name. +#' @param dataset_2 (optional `character(1)`) other dataset name. In case it is omitted, then it #' will create a primary key for `dataset_1`. #' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` #' with relationship to columns of `dataset_2` given by the elements in `keys`. diff --git a/R/join_keys.R b/R/join_keys.R index fd5c8deff..8e7ef2b65 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -96,19 +96,19 @@ join_keys.default <- function(...) { #' The setter assignment `join_keys(obj) <- ...` will merge obj and `...` if obj #' is not empty. #' -#' @param join_keys_obj (`join_keys`) empty object to set the new relationship pairs. +#' @param x (`join_keys`) empty object to set the new relationship pairs. #' @param value (`join_key_set` or list of `join_key_set`) relationship pairs to add #' to `join_keys` list. #' #' @export -`join_keys<-` <- function(join_keys_obj, value) { +`join_keys<-` <- function(x, value) { checkmate::assert( combine = "or", checkmate::check_class(value, classes = c("join_keys", "list")), checkmate::check_class(value, classes = c("join_key_set")), checkmate::check_list(value, types = "join_key_set") ) - UseMethod("join_keys<-", join_keys_obj) + UseMethod("join_keys<-", x) } #' @rdname join_keys @@ -123,7 +123,7 @@ join_keys.default <- function(...) { #' #' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk -`join_keys<-.join_keys` <- function(join_keys_obj, value) { +`join_keys<-.join_keys` <- function(x, value) { # Assume assignment of join keys as a merge operation # Needed to support join_keys(jk)[c("ds1", "ds2")] <- "key" if (checkmate::test_class(value, classes = c("join_keys", "list"))) { @@ -160,9 +160,9 @@ join_keys.default <- function(...) { #' join_keys(td)[["ds2"]][["ds2"]] <- "key2" #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) #' join_keys(td) -`join_keys<-.teal_data` <- function(join_keys_obj, value) { - join_keys(join_keys_obj@join_keys) <- value - join_keys_obj +`join_keys<-.teal_data` <- function(x, value) { + join_keys(x@join_keys) <- value + x } #' @rdname join_keys @@ -224,7 +224,7 @@ c.join_keys <- function(...) { #' @details #' Getter for `join_keys` that returns the relationship between pairs of datasets. #' -#' @inheritParams base::`[` +#' @inheritParams base::`[[` #' @param keep_all_foreign_keys (`logical`) flag that keeps foreign keys and other #' datasets even if they are not a parent of the selected dataset. #' @@ -315,27 +315,6 @@ c.join_keys <- function(...) { #' @inheritParams base::`[<-` #' #' @export -#' -#' @examples -#' -#' # Setter via index ---- -#' -#' jk <- join_keys( -#' join_key("ds1", "ds2", c("id_1" = "id_2")), -#' join_key("ds3", "ds4", c("id_3" = "id_4")) -#' ) -#' -#' # overwrites previously defined key -#' jk["ds1"] <- list(ds2 = "(new)co12") -#' jk["ds1"] <- list(ds3 = "col13", ds4 = "col14") -#' jk -#' -#' jk[c("ds1", "ds2")] <- list(ds5 = "col*5") -#' jk[c(1, 2)] <- list(ds5 = "col**5") -#' -#' # Creates primary key by only defining `i` -#' jk["ds1"] <- "primary_key" -#' jk `[<-.join_keys` <- function(x, i, value) { stop("Can't use `[<-` for object `join_keys`. Use [[<- instead.") } @@ -432,7 +411,7 @@ c.join_keys <- function(...) { ) preserve_attr <- attributes(x)[!names(attributes(x)) %in% "names"] x <- x[!empty_ix] - attributes(x) <- modifyList(attributes(x), preserve_attr) + attributes(x) <- utils::modifyList(attributes(x), preserve_attr) # # restore class @@ -545,13 +524,13 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { #' Helper function checks the parent-child relations are valid #' -#' @param join_keys_obj (`join_keys`) object to assert validity of relations +#' @param x (`join_keys`) object to assert validity of relations #' -#' @return `join_keys_obj` invisibly +#' @return `join_keys` invisibly #' #' @keywords internal -assert_parent_child <- function(join_keys_obj) { - jk <- join_keys(join_keys_obj) +assert_parent_child <- function(x) { + jk <- join_keys(x) jk_parents <- parents(jk) checkmate::assert_class(jk, c("join_keys", "list")) @@ -575,5 +554,5 @@ assert_parent_child <- function(join_keys_obj) { } } } - invisible(join_keys_obj) + invisible(x) } diff --git a/R/parents.R b/R/parents.R index 905fa07de..b68b3a02e 100644 --- a/R/parents.R +++ b/R/parents.R @@ -1,6 +1,6 @@ #' Getter and setter for specific parent #' -#' @param join_keys_obj (`join_keys`) object to retrieve. +#' @param x (`join_keys`) object to retrieve. #' @param dataset_name (`character(1)`) #' #' @export @@ -10,20 +10,20 @@ #' parent(jk, "ds2") #' parents(jk) <- list("ds2" = "ds1") #' parent(jk, "ds2") -parent <- function(join_keys_obj, dataset_name) { +parent <- function(x, dataset_name) { checkmate::assert_string(dataset_name) - # assert join_keys_obj is performed by parents() - parents(join_keys_obj)[[dataset_name]] + # assert x is performed by parents() + parents(x)[[dataset_name]] } #' Getter and setter functions for parents attribute of `join_keys` #' -#' @param join_keys_obj (`join_keys`) object to retrieve or manipulate. +#' @param x (`join_keys`) object to retrieve or manipulate. #' @return a list of `character` representing the parents. #' #' @export -parents <- function(join_keys_obj) { - UseMethod("parents", join_keys_obj) +parents <- function(x) { + UseMethod("parents", x) } #' @rdname parents @@ -31,8 +31,8 @@ parents <- function(join_keys_obj) { #' @examples #' jk <- default_cdisc_join_keys["ADEX"] #' parents(jk) -parents.join_keys <- function(join_keys_obj) { - attr(join_keys_obj, "__parents__") %||% list() +parents.join_keys <- function(x) { + attr(x, "__parents__") %||% list() } #' @rdname parents @@ -44,8 +44,8 @@ parents.join_keys <- function(join_keys_obj) { #' ADTTE = teal.data::rADTTE #' ) #' parents(td) -parents.teal_data <- function(join_keys_obj) { - attr(join_keys_obj@join_keys, "__parents__") %||% list() +parents.teal_data <- function(x) { + attr(x@join_keys, "__parents__") %||% list() } #' @rdname parents @@ -53,8 +53,8 @@ parents.teal_data <- function(join_keys_obj) { #' @param value (`list`) named list of character values #' #' @export -`parents<-` <- function(join_keys_obj, value) { - UseMethod("parents<-", join_keys_obj) +`parents<-` <- function(x, value) { + UseMethod("parents<-", x) } #' @rdname parents @@ -70,7 +70,7 @@ parents.teal_data <- function(join_keys_obj) { #' parents(jk) <- list(ds1 = "ds2") #' parents(jk)["ds5"] <- "ds6" #' parents(jk)["ds6"] <- "ds7" -`parents<-.join_keys` <- function(join_keys_obj, value) { +`parents<-.join_keys` <- function(x, value) { checkmate::assert_list(value, types = "character", names = "named") new_parents <- list() @@ -95,10 +95,10 @@ parents.teal_data <- function(join_keys_obj) { stop("Cycle detected in a parent and child dataset graph.") } - attr(join_keys_obj, "__parents__") <- new_parents # nolint: object_name_linter + attr(x, "__parents__") <- new_parents # nolint: object_name_linter - assert_parent_child(join_keys_obj) - join_keys_obj + assert_parent_child(x) + x } #' @rdname parents @@ -112,22 +112,22 @@ parents.teal_data <- function(join_keys_obj) { #' ) #' parents(td) <- list("ADTTE" = "ADSL") # replace existing #' parents(td)["ADRS"] <- "ADSL" # add new parent -`parents<-.teal_data` <- function(join_keys_obj, value) { - parents(join_keys_obj@join_keys) <- value - join_keys_obj +`parents<-.teal_data` <- function(x, value) { + parents(x@join_keys) <- value + x } #' Updates the keys of the datasets based on the parents. #' -#' @param join_keys_obj (`join_keys`) object to update the keys. +#' @param x (`join_keys`) object to update the keys. #' #' @return (`self`) invisibly for chaining #' #' @keywords internal -update_keys_given_parents <- function(join_keys_obj) { - jk <- join_keys(join_keys_obj) +update_keys_given_parents <- function(x) { + jk <- join_keys(x) - checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(join_keys_obj)) + checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(x)) datanames <- names(jk) duplicate_pairs <- list() @@ -161,7 +161,7 @@ update_keys_given_parents <- function(join_keys_obj) { } } # check parent child relation - assert_parent_child(join_keys_obj = jk) + assert_parent_child(x = jk) jk } diff --git a/R/teal_data.R b/R/teal_data.R index 0a7519393..61dee21a2 100644 --- a/R/teal_data.R +++ b/R/teal_data.R @@ -110,19 +110,19 @@ teal_data_file <- function(path, code = get_code(path)) { #' Add primary keys as join_keys to a dataset self #' #' @param data_objects (`list`) of `TealDataset`, `TealDatasetConnector` or `TealDataConnector` objects -#' @param join_keys_obj (`join_keys`) object +#' @param x (`join_keys`) object #' #' @keywords internal -update_join_keys_to_primary <- function(data_objects, join_keys_obj) { +update_join_keys_to_primary <- function(data_objects, x) { for (obj in data_objects) { if (inherits(obj, "TealDataConnector")) { - join_keys_obj <- update_join_keys_to_primary(obj$get_items(), join_keys_obj) + x <- update_join_keys_to_primary(obj$get_items(), x) } else { dataname <- obj$get_dataname() - if (length(join_keys_obj[[dataname]][[dataname]]) == 0) { - join_keys_obj[[dataname]][[dataname]] <- obj$get_keys() + if (length(x[[dataname]][[dataname]]) == 0) { + x[[dataname]][[dataname]] <- obj$get_keys() } } } - join_keys_obj + x } diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index 55dc43995..701f295d1 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -1,181 +1,6 @@ -#' (test helper) Generate a teal_data dataset with sample data and join_keys -#' -#' @return `teal_data` -#' -#' @keywords internal -local_teal_data <- function() { - iris2 <- iris - iris2$id <- rnorm(NROW(iris2)) - iris2$id <- apply(iris2, 1, rlang::hash) - new_teal_data( - list( - ds1 = iris2, - ds2 = iris2 - ), - code = "ds1 <- iris2; ds2 <- iris2", - join_keys = local_join_keys("ds1", keys = c("id")) - ) -} - -#' (test helper) Generate a join_keys -#' -#' @param dataset_1 `character(1)` name of dataset to add. -#' @param keys `character(1)` primary key for `dataset_1` (optionally named). -#' -#' @return `join_keys` object with a primary key -#' -#' @keywords internal -local_join_keys <- function(dataset_1 = "ds1", keys = c("id")) { # nolint - join_keys( - join_key(dataset_1, keys = keys) - ) -} - -#' (test helper) Test suite for default join_keys generated by helper -#' -#' @param obj Object with `join_keys` to perform operations (can be `join_keys` -#' or `teal_data`). It should only contain a primary key. -#' @param dataset_1 `character(1)` name of existing dataset to test. -#' -#' @return `obj` itself without any modifications -#' -#' @keywords internal -test_join_keys_bare <- function(obj, dataset_1 = "ds1") { - jk <- join_keys(obj) - - expect_s3_class(jk, class = c("join_keys", "list")) - expect_length(jk, 1) - expect_length(jk[[dataset_1]][[dataset_1]], 1) - - obj -} - -#' (test helper) Test suite for join_keys after manual adding a primary key -#' -#' @param obj Object with `join_keys` to perform operations (can be `join_keys` -#' or `teal_data`) -#' @param dataset_1 `character(1)` name of existing dataset. -#' @param new_dataset_1 `character(1)` name of new dataset to add. -#' @param new_keys -#' -#' @return `obj` itself modified with a new foreign key. -#' -#' @keywords internal -test_join_keys_add <- function(obj, - dataset_1 = "ds1", - new_dataset_1 = "ds2", - new_keys = c("id")) { - obj <- test_join_keys_bare(obj, dataset_1) - join_keys(obj)[[new_dataset_1]][[new_dataset_1]] <- c(new_keys) # primary key - - jk <- join_keys(obj) - - expect_s3_class(jk, class = c("join_keys", "list")) - expect_length(jk, 2) - expect_length(jk[[dataset_1]][[dataset_1]], 1) - expect_length(jk[[new_dataset_1]][[new_dataset_1]], 1) -} - -#' (test helper) Test suite for join_keys that performs a mass modification -#' -#' The goal of this helper is to modify the `join_keys` with all variants of a -#' valid foreign key. -#' -#' @param obj Object with `join_keys` to perform operations (can be `join_keys` -#' or `teal_data`) -#' -#' @return `obj` itself modified with a new foreign key. -#' -#' @keywords internal -test_join_keys_combinatory <- function(obj) { - obj <- test_join_keys_bare(obj, "ds1") - - counter <- 2 - .ds <- function(add = 1, prefix = "ds") { - counter <<- counter + add - paste0(prefix, "-", counter - add) - } - - .key <- function(type = 1, prefix = "col") { - col_name <- .ds(add = 1, prefix = prefix) - switch(type, - "1" = col_name, - "2" = setNames(col_name, col_name), - "3" = setNames(col_name, paste0(col_name, "-diff")), - "4" = setNames("", paste0(col_name)) - ) - } - - # Primary key (each adds 1) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(1))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(2))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(4))) - expect_error(join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), .key(3)))) - - # Relationship pair (each adds 2) - join_keys(obj)[[.ds()]][[.ds()]] <- .key(1) - join_keys(obj)[[.ds()]][[.ds()]] <- .key(2) - join_keys(obj)[[.ds()]][[.ds()]] <- .key(3) - join_keys(obj)[[.ds()]][[.ds()]] <- .key(4) - - # Relationship pair alternative (each adds 2) - join_keys(obj)[[.ds()]] <- setNames(list(.key(1)), .ds()) - join_keys(obj)[[.ds()]] <- setNames(list(.key(2)), .ds()) - join_keys(obj)[[.ds()]] <- setNames(list(.key(3)), .ds()) - join_keys(obj)[[.ds()]] <- setNames(list(.key(4)), .ds()) - - # Using join_key (each adds 2) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(1))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(2))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(3))) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), .key(4))) - - # (each join_key adds 2, except character(0)) - join_keys(obj) <- c( - join_keys(obj), - join_key(.ds(), .ds(), .key(1)), - join_key(.ds(), .ds(), .key(2)), - join_key(.ds(), .ds(), .key(3)), - join_key(.ds(), .ds(), .key(4)), - join_key(.ds(), .ds(), character(0)) - ) - - # Setting character(0) is the same as NUL (adds nothing) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(add = 0), .ds(), character(0))) - join_keys(obj)[[.ds()]][[.ds()]] <- character(0) - join_keys(obj)[[.ds()]] <- setNames(list(character(0)), .ds()) - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), .ds(), character(0))) - - - # (each join_key adds 2) - join_keys(obj) <- c( - join_keys(obj), join_keys( - join_key(.ds(), .ds(), .key(1)), - join_key(.ds(), .ds(), .key(2)), - join_key(.ds(), .ds(), .key(3)), - join_key(.ds(), .ds(), .key(4)), - join_key(.ds(), .ds(), character(0)) - ) - ) - - expect_s3_class(join_keys(obj), class = c("join_keys", "list")) - - expected_length <- 43 + 1 # Add + 1 from `helper_test_getter_join_keys` - expect_length(join_keys(obj), expected_length) - - join_keys(obj) <- c(join_keys(obj), join_key("ds-manual", .ds(), .key(1))) - expect_length(join_keys(obj), expected_length + 2) # adds 2 new datasets - - join_keys(obj) <- c(join_keys(obj), join_key(.ds(), "ds-manual", .key(1))) - expect_length(join_keys(obj), expected_length + 2 + 1) # adds 1 new dataset as ds-manual already exists -} - #' (test helper) Create test data for `CDISC` data #' #' @inheritParams cdisc_data -#' @param join_keys (`join_keys`) or a single (`join_key_set`)\cr -#' (optional) object with dataset column relationships used for joining. -#' If empty then no joins between pairs of objects. #' #' @return a `CDISC` data set with the following tables: `ADSL`, `ADTTE` and `ADAE` #' diff --git a/man/assert_join_keys_alike.Rd b/man/assert_join_keys_alike.Rd deleted file mode 100644 index b0e685817..000000000 --- a/man/assert_join_keys_alike.Rd +++ /dev/null @@ -1,31 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{assert_join_keys_alike} -\alias{assert_join_keys_alike} -\alias{check_join_keys_alike} -\title{Assert the \code{join_keys} class membership of an argument} -\usage{ -assert_join_keys_alike(x, .var.name = checkmate::vname(x), add = NULL) - -check_join_keys_alike(x) -} -\arguments{ -\item{x}{[any]\cr -Object to check.} - -\item{.var.name}{[\code{character(1)}]\cr -Name of the checked object to print in assertions. Defaults to -the heuristic implemented in \code{\link[checkmate]{vname}}.} - -\item{add}{[\code{AssertCollection}]\cr -Collection to store assertion messages. See \code{\link[checkmate]{AssertCollection}}.} -} -\value{ -\code{x} invisibly -} -\description{ -Relaxed validation of a \code{join_keys} object. It accepts \code{join_keys}, a list -of \code{join_key_set} (not symmetrical) or even a named list of character vectors -without looking at the class name. -} -\keyword{internal} diff --git a/man/assert_parent_child.Rd b/man/assert_parent_child.Rd index f4c103ee6..9b64598a0 100644 --- a/man/assert_parent_child.Rd +++ b/man/assert_parent_child.Rd @@ -4,13 +4,13 @@ \alias{assert_parent_child} \title{Helper function checks the parent-child relations are valid} \usage{ -assert_parent_child(join_keys_obj) +assert_parent_child(x) } \arguments{ -\item{join_keys_obj}{(\code{join_keys}) object to assert validity of relations} +\item{x}{(\code{join_keys}) object to assert validity of relations} } \value{ -\code{join_keys_obj} invisibly +\code{join_keys} invisibly } \description{ Helper function checks the parent-child relations are valid diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index 03d913b55..b724114c6 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -12,7 +12,10 @@ get_join_keys(data, dataset_1, dataset_2 = NULL) <- value \arguments{ \item{data}{`` - object to extract the join keys} -\item{dataset_2}{(\code{character(1)}) name of a dataset.} +\item{dataset_1}{(\code{character(1)}) dataset name.} + +\item{dataset_2}{(optional \code{character(1)}) other dataset name. In case it is omitted, then it +will create a primary key for \code{dataset_1}.} \item{value}{value to assign} } diff --git a/man/join_key.Rd b/man/join_key.Rd index 379c39e6a..0e4f3d004 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -7,7 +7,9 @@ join_key(dataset_1, dataset_2 = dataset_1, keys) } \arguments{ -\item{dataset_2}{(optional \code{character}) other dataset name. In case it is omitted, then it +\item{dataset_1}{(\code{character(1)}) dataset name.} + +\item{dataset_2}{(optional \code{character(1)}) other dataset name. In case it is omitted, then it will create a primary key for \code{dataset_1}.} \item{keys}{(optionally named \code{character}) where \code{names(keys)} are columns in \code{dataset_1} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 940f3125f..c617c70f9 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -25,11 +25,11 @@ join_keys(...) \method{join_keys}{default}(...) -join_keys(join_keys_obj) <- value +join_keys(x) <- value -\method{join_keys}{join_keys}(join_keys_obj) <- value +\method{join_keys}{join_keys}(x) <- value -\method{join_keys}{teal_data}(join_keys_obj) <- value +\method{join_keys}{teal_data}(x) <- value \method{c}{join_keys}(...) @@ -46,7 +46,7 @@ it will return the \code{join_keys} of that object. When called with 1 or more \code{join_key_set} it will create a new \code{join_keys} with constructed from the arguments.} -\item{join_keys_obj}{(\code{join_keys}) empty object to set the new relationship pairs.} +\item{x}{(\code{join_keys}) empty object to set the new relationship pairs.} \item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add to \code{join_keys} list.} @@ -136,25 +136,6 @@ jk["ds1"] jk[1:2] jk[c("ds1", "ds2")] -# Setter via index ---- - -jk <- join_keys( - join_key("ds1", "ds2", c("id_1" = "id_2")), - join_key("ds3", "ds4", c("id_3" = "id_4")) -) - -# overwrites previously defined key -jk["ds1"] <- list(ds2 = "(new)co12") -jk["ds1"] <- list(ds3 = "col13", ds4 = "col14") -jk - -jk[c("ds1", "ds2")] <- list(ds5 = "col*5") -jk[c(1, 2)] <- list(ds5 = "col**5") - -# Creates primary key by only defining `i` -jk["ds1"] <- "primary_key" -jk - jk <- join_keys() jk[["ds1"]] <- list() jk[["ds2"]][["ds3"]] <- "key" diff --git a/man/local_cdisc_data_mixed_call.Rd b/man/local_cdisc_data_mixed_call.Rd index 266dc82e5..e97c8692f 100644 --- a/man/local_cdisc_data_mixed_call.Rd +++ b/man/local_cdisc_data_mixed_call.Rd @@ -10,10 +10,6 @@ local_cdisc_data_mixed_call(check = TRUE, join_keys1 = join_keys()) \item{check}{(\code{logical}) reproducibility check - whether to perform a check that the pre-processing code included in the object definitions actually produces those objects. If \code{check} is true and preprocessing code is empty an error will be thrown.} - -\item{join_keys}{(\code{join_keys}) or a single (\code{join_key_set})\cr -(optional) object with dataset column relationships used for joining. -If empty then no joins between pairs of objects.} } \value{ a \code{CDISC} data set with the following tables: \code{ADSL}, \code{ADTTE} and \code{ADAE} diff --git a/man/local_join_keys.Rd b/man/local_join_keys.Rd deleted file mode 100644 index 9f9b01442..000000000 --- a/man/local_join_keys.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testhat-helpers.R -\name{local_join_keys} -\alias{local_join_keys} -\title{(test helper) Generate a join_keys} -\usage{ -local_join_keys(dataset_1 = "ds1", keys = c("id")) -} -\arguments{ -\item{dataset_1}{\code{character(1)} name of dataset to add.} - -\item{keys}{\code{character(1)} primary key for \code{dataset_1} (optionally named).} -} -\value{ -\code{join_keys} object with a primary key -} -\description{ -(test helper) Generate a join_keys -} -\keyword{internal} diff --git a/man/local_teal_data.Rd b/man/local_teal_data.Rd deleted file mode 100644 index c0fc05fca..000000000 --- a/man/local_teal_data.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testhat-helpers.R -\name{local_teal_data} -\alias{local_teal_data} -\title{(test helper) Generate a teal_data dataset with sample data and join_keys} -\usage{ -local_teal_data() -} -\value{ -\code{teal_data} -} -\description{ -(test helper) Generate a teal_data dataset with sample data and join_keys -} -\keyword{internal} diff --git a/man/parent.Rd b/man/parent.Rd index 23e48d295..a86e3a23f 100644 --- a/man/parent.Rd +++ b/man/parent.Rd @@ -4,10 +4,10 @@ \alias{parent} \title{Getter and setter for specific parent} \usage{ -parent(join_keys_obj, dataset_name) +parent(x, dataset_name) } \arguments{ -\item{join_keys_obj}{(\code{join_keys}) object to retrieve.} +\item{x}{(\code{join_keys}) object to retrieve.} \item{dataset_name}{(\code{character(1)})} } diff --git a/man/parents.Rd b/man/parents.Rd index 73434a78d..54f75cf23 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -9,20 +9,20 @@ \alias{parents<-.teal_data} \title{Getter and setter functions for parents attribute of \code{join_keys}} \usage{ -parents(join_keys_obj) +parents(x) -\method{parents}{join_keys}(join_keys_obj) +\method{parents}{join_keys}(x) -\method{parents}{teal_data}(join_keys_obj) +\method{parents}{teal_data}(x) -parents(join_keys_obj) <- value +parents(x) <- value -\method{parents}{join_keys}(join_keys_obj) <- value +\method{parents}{join_keys}(x) <- value -\method{parents}{teal_data}(join_keys_obj) <- value +\method{parents}{teal_data}(x) <- value } \arguments{ -\item{join_keys_obj}{(\code{join_keys}) object to retrieve or manipulate.} +\item{x}{(\code{join_keys}) object to retrieve or manipulate.} \item{value}{(\code{list}) named list of character values} } diff --git a/man/test_join_keys_add.Rd b/man/test_join_keys_add.Rd deleted file mode 100644 index 7e0a6f167..000000000 --- a/man/test_join_keys_add.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testhat-helpers.R -\name{test_join_keys_add} -\alias{test_join_keys_add} -\title{(test helper) Test suite for join_keys after manual adding a primary key} -\usage{ -test_join_keys_add( - obj, - dataset_1 = "ds1", - new_dataset_1 = "ds2", - new_keys = c("id") -) -} -\arguments{ -\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} -or \code{teal_data})} - -\item{dataset_1}{\code{character(1)} name of existing dataset.} - -\item{new_dataset_1}{\code{character(1)} name of new dataset to add.} - -\item{new_keys}{} -} -\value{ -\code{obj} itself modified with a new foreign key. -} -\description{ -(test helper) Test suite for join_keys after manual adding a primary key -} -\keyword{internal} diff --git a/man/test_join_keys_bare.Rd b/man/test_join_keys_bare.Rd deleted file mode 100644 index f6282776c..000000000 --- a/man/test_join_keys_bare.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testhat-helpers.R -\name{test_join_keys_bare} -\alias{test_join_keys_bare} -\title{(test helper) Test suite for default join_keys generated by helper} -\usage{ -test_join_keys_bare(obj, dataset_1 = "ds1") -} -\arguments{ -\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} -or \code{teal_data}). It should only contain a primary key.} - -\item{dataset_1}{\code{character(1)} name of existing dataset to test.} -} -\value{ -\code{obj} itself without any modifications -} -\description{ -(test helper) Test suite for default join_keys generated by helper -} -\keyword{internal} diff --git a/man/test_join_keys_combinatory.Rd b/man/test_join_keys_combinatory.Rd deleted file mode 100644 index ad29fe4a0..000000000 --- a/man/test_join_keys_combinatory.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/testhat-helpers.R -\name{test_join_keys_combinatory} -\alias{test_join_keys_combinatory} -\title{(test helper) Test suite for join_keys that performs a mass modification} -\usage{ -test_join_keys_combinatory(obj) -} -\arguments{ -\item{obj}{Object with \code{join_keys} to perform operations (can be \code{join_keys} -or \code{teal_data})} -} -\value{ -\code{obj} itself modified with a new foreign key. -} -\description{ -The goal of this helper is to modify the \code{join_keys} with all variants of a -valid foreign key. -} -\keyword{internal} diff --git a/man/update_join_keys_to_primary.Rd b/man/update_join_keys_to_primary.Rd index 7302fcf6e..690cd6c23 100644 --- a/man/update_join_keys_to_primary.Rd +++ b/man/update_join_keys_to_primary.Rd @@ -4,12 +4,12 @@ \alias{update_join_keys_to_primary} \title{Add primary keys as join_keys to a dataset self} \usage{ -update_join_keys_to_primary(data_objects, join_keys_obj) +update_join_keys_to_primary(data_objects, x) } \arguments{ \item{data_objects}{(\code{list}) of \code{TealDataset}, \code{TealDatasetConnector} or \code{TealDataConnector} objects} -\item{join_keys_obj}{(\code{join_keys}) object} +\item{x}{(\code{join_keys}) object} } \description{ Add primary keys as join_keys to a dataset self diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 169cf8d13..9c592c2d2 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -4,10 +4,10 @@ \alias{update_keys_given_parents} \title{Updates the keys of the datasets based on the parents.} \usage{ -update_keys_given_parents(join_keys_obj) +update_keys_given_parents(x) } \arguments{ -\item{join_keys_obj}{(\code{join_keys}) object to update the keys.} +\item{x}{(\code{join_keys}) object to update the keys.} } \value{ (\code{self}) invisibly for chaining diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 8c044d34b..96ecb057a 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -35,12 +35,12 @@ testthat::test_that("join_keys is a collection of join_key, ie named list with n }) testthat::test_that("join_keys.teal_data returns join_keys object from teal_data", { - obj <- local_teal_data() + obj <- teal_data(join_keys = join_keys(join_key("d1", "d1", "a"))) testthat::expect_identical(obj@join_keys, join_keys(obj)) }) testthat::test_that("join_keys.join_keys returns itself", { - obj <- local_join_keys() + obj <- join_keys(join_key("d1", "d1", "a")) testthat::expect_identical(obj, join_keys(obj)) }) From ac63f64e8aaff9415df5d612bb6d9505835758ce Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 14 Nov 2023 22:49:30 +0100 Subject: [PATCH 096/152] WIP simplify methods --- R/join_keys.R | 38 +++------------------------------ tests/testthat/test-join_keys.R | 19 +++++++++++++---- 2 files changed, 18 insertions(+), 39 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 8e7ef2b65..f5eea9324 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -85,10 +85,7 @@ join_keys.TealData <- function(...) { #' @rdname join_keys #' @export join_keys.default <- function(...) { - # Constructor using join_keys<-.xxx setter - result <- new_join_keys() - join_keys(result) <- rlang::list2(...) - result + c(new_join_keys(), ...) } #' @rdname join_keys @@ -129,24 +126,8 @@ join_keys.default <- function(...) { if (checkmate::test_class(value, classes = c("join_keys", "list"))) { return(value) } - - if (inherits(value, "join_key_set")) value <- list(value) - join_keys_obj <- new_join_keys() - - # check if any join_key_sets share the same datasets but different values - for (idx_1 in seq_along(value)) { - for (idx_2 in seq_along(value)[-seq(1, idx_1)]) { - assert_compatible_keys(value[[idx_1]], value[[idx_2]]) - } - - dataset_1 <- get_dataset_1(value[[idx_1]]) - dataset_2 <- get_dataset_2(value[[idx_1]]) - keys <- get_keys(value[[idx_1]]) - - join_keys_obj[[dataset_1]][[dataset_2]] <- keys - } - join_keys_obj + c(join_keys_obj, value) } #' @rdname join_keys @@ -175,26 +156,13 @@ c.join_keys <- function(...) { x <- rlang::list2(...) checkmate::assert_class(x[[1]], c("join_keys", "list")) checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) + # todo: assert if ... contains incompatible keys join_keys_obj <- x[[1]] x <- x[-1] - if ( - checkmate::test_class(x, "join_key_set") || - checkmate::test_class(x, c("join_keys", "list")) - ) { - x <- list(x) - } - - if (checkmate::test_list(x, types = "join_key_set")) { - jk_temp <- new_join_keys() - join_keys(jk_temp) <- x - x <- list(jk_temp) - } - for (el in x) { join_keys_obj <- utils::modifyList(join_keys_obj, el) } - join_keys_obj } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 96ecb057a..0d6e6ff8f 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -104,7 +104,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given da my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), + join_key("d3", "d3", "c") ) testthat::expect_identical( my_keys[c("d1", "d2")], @@ -116,7 +116,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given in my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), + join_key("d3", "d3", "c") ) testthat::expect_identical( my_keys[c(1, 2)], @@ -400,7 +400,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("a", "a", "a"), join_key("a", "b", "ab"), join_key("a", "c", "ac"), - join_key("d", "b", "db"), + join_key("d", "b", "db") ) names(jk)[1:2] <- c("x", "y") @@ -411,7 +411,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("x", "x", "a"), join_key("x", "y", "ab"), join_key("x", "c", "ac"), - join_key("d", "y", "db"), + join_key("d", "y", "db") ) ) }) @@ -478,6 +478,17 @@ testthat::test_that("c.join_keys doesn't throw when second object is empty join_ testthat::expect_no_error(c(x, y)) }) +testthat::test_that("c.join_keys doesn't allow to specify the keys which are incompatible", { + obj <- join_keys() + testthat::expect_error( + c( + obj, + join_keys(join_key("a", "b", "aa")), + join_keys(join_key("b", "a", "bb")) + ) + ) +}) + # ----------------------------------------------------------------------------- # # print.join_keys From 9f0fdc2726e602647e2ef7a7a5642eb704045e81 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 15 Nov 2023 08:20:32 +0100 Subject: [PATCH 097/152] Revert "WIP" This reverts commit ac63f64e8aaff9415df5d612bb6d9505835758ce. --- R/join_keys.R | 38 ++++++++++++++++++++++++++++++--- tests/testthat/test-join_keys.R | 19 ++++------------- 2 files changed, 39 insertions(+), 18 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index f5eea9324..8e7ef2b65 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -85,7 +85,10 @@ join_keys.TealData <- function(...) { #' @rdname join_keys #' @export join_keys.default <- function(...) { - c(new_join_keys(), ...) + # Constructor using join_keys<-.xxx setter + result <- new_join_keys() + join_keys(result) <- rlang::list2(...) + result } #' @rdname join_keys @@ -126,8 +129,24 @@ join_keys.default <- function(...) { if (checkmate::test_class(value, classes = c("join_keys", "list"))) { return(value) } + + if (inherits(value, "join_key_set")) value <- list(value) + join_keys_obj <- new_join_keys() - c(join_keys_obj, value) + + # check if any join_key_sets share the same datasets but different values + for (idx_1 in seq_along(value)) { + for (idx_2 in seq_along(value)[-seq(1, idx_1)]) { + assert_compatible_keys(value[[idx_1]], value[[idx_2]]) + } + + dataset_1 <- get_dataset_1(value[[idx_1]]) + dataset_2 <- get_dataset_2(value[[idx_1]]) + keys <- get_keys(value[[idx_1]]) + + join_keys_obj[[dataset_1]][[dataset_2]] <- keys + } + join_keys_obj } #' @rdname join_keys @@ -156,13 +175,26 @@ c.join_keys <- function(...) { x <- rlang::list2(...) checkmate::assert_class(x[[1]], c("join_keys", "list")) checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) - # todo: assert if ... contains incompatible keys join_keys_obj <- x[[1]] x <- x[-1] + if ( + checkmate::test_class(x, "join_key_set") || + checkmate::test_class(x, c("join_keys", "list")) + ) { + x <- list(x) + } + + if (checkmate::test_list(x, types = "join_key_set")) { + jk_temp <- new_join_keys() + join_keys(jk_temp) <- x + x <- list(jk_temp) + } + for (el in x) { join_keys_obj <- utils::modifyList(join_keys_obj, el) } + join_keys_obj } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 0d6e6ff8f..96ecb057a 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -104,7 +104,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given da my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c") + join_key("d3", "d3", "c"), ) testthat::expect_identical( my_keys[c("d1", "d2")], @@ -116,7 +116,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given in my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c") + join_key("d3", "d3", "c"), ) testthat::expect_identical( my_keys[c(1, 2)], @@ -400,7 +400,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("a", "a", "a"), join_key("a", "b", "ab"), join_key("a", "c", "ac"), - join_key("d", "b", "db") + join_key("d", "b", "db"), ) names(jk)[1:2] <- c("x", "y") @@ -411,7 +411,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("x", "x", "a"), join_key("x", "y", "ab"), join_key("x", "c", "ac"), - join_key("d", "y", "db") + join_key("d", "y", "db"), ) ) }) @@ -478,17 +478,6 @@ testthat::test_that("c.join_keys doesn't throw when second object is empty join_ testthat::expect_no_error(c(x, y)) }) -testthat::test_that("c.join_keys doesn't allow to specify the keys which are incompatible", { - obj <- join_keys() - testthat::expect_error( - c( - obj, - join_keys(join_key("a", "b", "aa")), - join_keys(join_key("b", "a", "bb")) - ) - ) -}) - # ----------------------------------------------------------------------------- # # print.join_keys From 95ebd6f0d7f9f127528b3fe5e5ab3e9c9c2fab19 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 15 Nov 2023 08:22:24 +0100 Subject: [PATCH 098/152] WIP --- R/join_keys.R | 104 +++++++++++++------------------- tests/testthat/test-join_keys.R | 36 ++++++++--- 2 files changed, 72 insertions(+), 68 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 8e7ef2b65..c27365f95 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -85,10 +85,7 @@ join_keys.TealData <- function(...) { #' @rdname join_keys #' @export join_keys.default <- function(...) { - # Constructor using join_keys<-.xxx setter - result <- new_join_keys() - join_keys(result) <- rlang::list2(...) - result + c(new_join_keys(), ...) } #' @rdname join_keys @@ -129,24 +126,8 @@ join_keys.default <- function(...) { if (checkmate::test_class(value, classes = c("join_keys", "list"))) { return(value) } - - if (inherits(value, "join_key_set")) value <- list(value) - join_keys_obj <- new_join_keys() - - # check if any join_key_sets share the same datasets but different values - for (idx_1 in seq_along(value)) { - for (idx_2 in seq_along(value)[-seq(1, idx_1)]) { - assert_compatible_keys(value[[idx_1]], value[[idx_2]]) - } - - dataset_1 <- get_dataset_1(value[[idx_1]]) - dataset_2 <- get_dataset_2(value[[idx_1]]) - keys <- get_keys(value[[idx_1]]) - - join_keys_obj[[dataset_1]][[dataset_2]] <- keys - } - join_keys_obj + c(join_keys_obj, value) } #' @rdname join_keys @@ -172,30 +153,19 @@ join_keys.default <- function(...) { #' #' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) c.join_keys <- function(...) { - x <- rlang::list2(...) - checkmate::assert_class(x[[1]], c("join_keys", "list")) - checkmate::assert_list(x[-1], types = c("join_keys", "join_key_set")) - - join_keys_obj <- x[[1]] - x <- x[-1] - if ( - checkmate::test_class(x, "join_key_set") || - checkmate::test_class(x, c("join_keys", "list")) - ) { - x <- list(x) - } - - if (checkmate::test_list(x, types = "join_key_set")) { - jk_temp <- new_join_keys() - join_keys(jk_temp) <- x - x <- list(jk_temp) - } + join_keys_obj <- rlang::list2(...)[[1]] + x <- rlang::list2(...)[-1] + checkmate::assert_class(join_keys_obj, c("join_keys", "list")) + checkmate::assert_list(x, types = c("join_keys", "join_key_set")) - for (el in x) { - join_keys_obj <- utils::modifyList(join_keys_obj, el) - } - - join_keys_obj + x_merged <- Reduce( + x, + f = function(.x, .y) { + assert_compatible_keys2(.x, .y) + modifyList(.x, .y) + } + ) + utils::modifyList(join_keys_obj, x_merged) } #' The Names of an `join_keys` Object @@ -345,7 +315,6 @@ c.join_keys <- function(...) { checkmate::check_logical(i, len = 1) ) checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) - if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { i <- names(x)[[i]] } @@ -355,21 +324,13 @@ c.join_keys <- function(...) { join_key(i, names(value)[.x], value[[.x]]) }) - # Check if multiple modifications don't have a conflict - for (idx_1 in seq_along(norm_value)) { - for (idx_2 in seq_along(norm_value)[-seq(1, idx_1)]) { - assert_compatible_keys(norm_value[[idx_1]], norm_value[[idx_2]]) - } - } - norm_value <- lapply(norm_value, get_keys) names(norm_value) <- names(value) value <- norm_value # Remove elements with length == 0L - value <- value[!vapply(seq_along(value), function(.x) is.null(value[[.x]]) || length(value[[.x]]) == 0L, logical(1))] + value <- Filter(function(x) length(x) > 0, value) - # # Remove classes to use list-based get/assign operations x <- unclass(x) @@ -473,6 +434,28 @@ new_join_keys <- function() { ) } +assert_compatible_keys2 <- function(.x, .y) { + if (length(.x) == 1 && length(.y) == 1) { + # both are join_key_set + assert_compatible_keys(.x, .y) + } else if (length(.x) > 1 && length(.y) > 1) { + # both are join_keys - need to compare all x with single y + for (idx_1 in seq_along(.x)) { + for (idx_2 in seq_along(.y)) { + assert_compatible_keys(.x[idx_1], .y[idx_2]) + } + } + } else if (length(.x) > 1 && length(.y) == 1) { + for (idx_1 in seq_along(.x)) { + assert_compatible_keys(.x[idx_1], .y) + } + } else if (length(.x) == 1 && length(.y) > 1) { + for (idx_2 in seq_along(.y)) { + assert_compatible_keys(.x, .y[idx_2]) + } + } +} + #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise @@ -484,14 +467,13 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { ) } - dataset_1_one <- get_dataset_1(join_key_1) - dataset_2_one <- get_dataset_2(join_key_1) - keys_one <- get_keys(join_key_1) - - dataset_1_two <- get_dataset_1(join_key_2) - dataset_2_two <- get_dataset_2(join_key_2) - keys_two <- get_keys(join_key_2) + dataset_1_one <- names(join_key_1) + dataset_2_one <- names(join_key_1[[1]]) + keys_one <- join_key_1[[1]][[1]] + dataset_1_two <- names(join_key_2) + dataset_2_two <- names(join_key_2[[1]]) + keys_two <- join_key_2[[1]][[1]] # if first datasets and the second datasets match and keys # must contain the same named elements diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 96ecb057a..49907194a 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -95,7 +95,7 @@ testthat::test_that("[.join_keys returns join_keys object", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), + join_key("d3", "d3", "c") ) testthat::expect_identical(my_keys[], my_keys) }) @@ -104,7 +104,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given da my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), + join_key("d3", "d3", "c") ) testthat::expect_identical( my_keys[c("d1", "d2")], @@ -116,7 +116,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given in my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), + join_key("d3", "d3", "c") ) testthat::expect_identical( my_keys[c(1, 2)], @@ -136,8 +136,7 @@ testthat::test_that("[.join_keys returns join_keys for given dataset including t my_keys["d2", keep_all_foreign_keys = TRUE], join_keys( join_key("d2", "d2", "b"), - join_key("d2", "d1", "ab"), - join_key("d1", "d2", "ab") + join_key("d2", "d1", "ab") ) ) }) @@ -400,7 +399,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("a", "a", "a"), join_key("a", "b", "ab"), join_key("a", "c", "ac"), - join_key("d", "b", "db"), + join_key("d", "b", "db") ) names(jk)[1:2] <- c("x", "y") @@ -411,7 +410,7 @@ testthat::test_that("names<-.join_keys will replace names at first and second le join_key("x", "x", "a"), join_key("x", "y", "ab"), join_key("x", "c", "ac"), - join_key("d", "y", "db"), + join_key("d", "y", "db") ) ) }) @@ -432,6 +431,18 @@ testthat::test_that("c.join_keys joins join_keys object with join_key objects", ) }) +testthat::test_that("c.join_keys duplicated keys are ignored", { + obj <- join_keys() + obj <- c(obj, join_key("a", "a", "aa"), join_key("a", "a", "aa")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) + ) +}) + testthat::test_that("c.join_keys joins join_keys object with join_keys objects", { obj <- join_keys() obj <- c( @@ -478,6 +489,17 @@ testthat::test_that("c.join_keys doesn't throw when second object is empty join_ testthat::expect_no_error(c(x, y)) }) +testthat::test_that("c.join_keys doesn't allow to specify the keys which are incompatible", { + obj <- join_keys() + testthat::expect_error( + c( + obj, + join_keys(join_key("a", "b", "aa")), + join_keys(join_key("b", "a", "bb")) + ) + ) +}) + # ----------------------------------------------------------------------------- # # print.join_keys From 27d5ff338a94c1f784c4e0e22360d63433aa7856 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 09:55:05 +0100 Subject: [PATCH 099/152] pr: improve style MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- R/join_keys.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 8e7ef2b65..9a428c2ac 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -390,9 +390,7 @@ c.join_keys <- function(...) { if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { new_value <- setNames(new_value, new_value) - } else if ( - checkmate::test_character(new_value, min.len = 1) - ) { + } else if (checkmate::test_character(new_value, min.len = 1)) { # Invert key new_value <- setNames(names(new_value), new_value) } From 9e2eb305a7e17736e933b805b39cbf4079535730 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 10:04:18 +0100 Subject: [PATCH 100/152] pr: remove redundant condition --- R/join_keys.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/join_keys.R b/R/join_keys.R index 9a428c2ac..85870bbb3 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -424,7 +424,7 @@ length.join_keys <- function(x) { if (NextMethod("length", x) == 0) { return(0) } - sum(vapply(x, function(.x) !is.null(.x) && length(.x) > 0, logical(1))) + sum(vapply(x, function(.x) length(.x) > 0, logical(1))) } #' Prints `join_keys`. From c71129604c22bb98f76a5a2fd32ad0611a943365 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 10:13:44 +0100 Subject: [PATCH 101/152] pr: remove unecessary roxygen tag --- R/join_keys.R | 1 - man/print.join_keys.Rd | 3 --- 2 files changed, 4 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 85870bbb3..602f8a414 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -430,7 +430,6 @@ length.join_keys <- function(x) { #' Prints `join_keys`. #' #' @inheritParams base::print -#' @return the `x` parameter #' #' @export print.join_keys <- function(x, ...) { diff --git a/man/print.join_keys.Rd b/man/print.join_keys.Rd index 0c30b5850..5b8a5565b 100644 --- a/man/print.join_keys.Rd +++ b/man/print.join_keys.Rd @@ -11,9 +11,6 @@ \item{...}{further arguments passed to or from other methods.} } -\value{ -the \code{x} parameter -} \description{ Prints \code{join_keys}. } From c5128760075109d9f2f197095a707ee9835ceade Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 11:42:28 +0100 Subject: [PATCH 102/152] stop overwriting x and value on [[<- --- R/join_keys.R | 35 +++++++++++++++++------------------ 1 file changed, 17 insertions(+), 18 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 149dee1c2..d8b7dd0cd 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -162,10 +162,10 @@ c.join_keys <- function(...) { x, f = function(.x, .y) { assert_compatible_keys2(.x, .y) - modifyList(.x, .y) + utils::modifyList(.x, .y, keep.null = FALSE) } ) - utils::modifyList(join_keys_obj, x_merged) + utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) } #' The Names of an `join_keys` Object @@ -326,28 +326,27 @@ c.join_keys <- function(...) { norm_value <- lapply(norm_value, get_keys) names(norm_value) <- names(value) - value <- norm_value # Remove elements with length == 0L - value <- Filter(function(x) length(x) > 0, value) + norm_value <- Filter(function(.x) length(.x) > 0, norm_value) # Remove classes to use list-based get/assign operations - x <- unclass(x) + new_x <- unclass(x) # In case a pair is removed, also remove the symmetric pair - removed_names <- setdiff(names(x[[i]]), names(value)) + removed_names <- setdiff(names(new_x[[i]]), names(norm_value)) if (length(removed_names) > 0) { - for (.x in removed_names) x[[.x]][[i]] <- NULL + for (.x in removed_names) new_x[[.x]][[i]] <- NULL } - x[[i]] <- value + new_x[[i]] <- norm_value # Iterate on all new values to create symmetrical pair - for (ds2 in names(value)) { + for (ds2 in names(norm_value)) { if (ds2 == i) next - keep_value <- x[[ds2]] %||% list() - new_value <- value[[ds2]] + keep_value <- new_x[[ds2]] %||% list() + new_value <- norm_value[[ds2]] if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { new_value <- setNames(new_value, new_value) @@ -359,23 +358,23 @@ c.join_keys <- function(...) { keep_value[[i]] <- new_value # Assign symmetrical - x[[ds2]] <- keep_value + new_x[[ds2]] <- keep_value } # Remove NULL or empty keys empty_ix <- vapply( - x, + new_x, function(.x) is.null(.x) || length(.x) == 0, logical(1) ) - preserve_attr <- attributes(x)[!names(attributes(x)) %in% "names"] - x <- x[!empty_ix] - attributes(x) <- utils::modifyList(attributes(x), preserve_attr) + preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"] + new_x <- new_x[!empty_ix] + attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr) # # restore class - class(x) <- c("join_keys", "list") - x + class(new_x) <- class(x) + new_x } #' Length of `join_keys` object. From 2cd7e6aaeade32dba1389216dd727c9450e8a9e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 13:22:34 +0100 Subject: [PATCH 103/152] fixes c.join_keys --- R/join_keys.R | 18 +++++++++--------- man/join_keys.Rd | 3 +-- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index d8b7dd0cd..51d055ef5 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -99,12 +99,7 @@ join_keys.default <- function(...) { #' #' @export `join_keys<-` <- function(x, value) { - checkmate::assert( - combine = "or", - checkmate::check_class(value, classes = c("join_keys", "list")), - checkmate::check_class(value, classes = c("join_key_set")), - checkmate::check_list(value, types = "join_key_set") - ) + checkmate::assert_class(value, classes = c("join_keys", "list")) UseMethod("join_keys<-", x) } @@ -115,8 +110,7 @@ join_keys.default <- function(...) { #' # Using the setter (assignment) ---- #' #' jk <- join_keys() -#' join_keys(jk) <- join_key("ds1", "ds2", "some_col") -#' join_keys(jk) <- c(join_keys(jk), join_key("ds3", "ds4", "some_col2")) +#' join_keys(jk) <- join_keys(join_keys(jk), join_key("ds3", "ds4", "some_col2")) #' #' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk @@ -159,12 +153,14 @@ c.join_keys <- function(...) { checkmate::assert_list(x, types = c("join_keys", "join_key_set")) x_merged <- Reduce( - x, + init = join_keys(), + x = x, f = function(.x, .y) { assert_compatible_keys2(.x, .y) utils::modifyList(.x, .y, keep.null = FALSE) } ) + utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) } @@ -463,6 +459,10 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { ) } + if (!length(join_key_1) || !length(join_key_2)) { + return(TRUE) + } + dataset_1_one <- names(join_key_1) dataset_2_one <- names(join_key_1[[1]]) keys_one <- join_key_1[[1]][[1]] diff --git a/man/join_keys.Rd b/man/join_keys.Rd index c617c70f9..0dd1ce937 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -110,8 +110,7 @@ jk <- c(jk, join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c"))) # Using the setter (assignment) ---- jk <- join_keys() -join_keys(jk) <- join_key("ds1", "ds2", "some_col") -join_keys(jk) <- c(join_keys(jk), join_key("ds3", "ds4", "some_col2")) +join_keys(jk) <- join_keys(join_keys(jk), join_key("ds3", "ds4", "some_col2")) join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" jk From 0c3e87687b1eea70caeb902b0712c450595f5307 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 15 Nov 2023 15:19:41 +0100 Subject: [PATCH 104/152] print --- NAMESPACE | 1 + R/join_keys.R | 62 +++++++++++++++++++++--------- man/assert_compatible_keys.Rd | 12 ------ man/assert_non_conflicting_keys.Rd | 16 ++++++++ man/join_keys.Rd | 6 +++ man/print.join_keys.Rd | 16 -------- tests/testthat/test-join_keys.R | 58 +++++++++++++++++++++++----- 7 files changed, 115 insertions(+), 56 deletions(-) delete mode 100644 man/assert_compatible_keys.Rd create mode 100644 man/assert_non_conflicting_keys.Rd delete mode 100644 man/print.join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index df434b7bf..8a5907a05 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ S3method(as_cdisc,TealDatasetConnector) S3method(c,join_keys) S3method(dataset,MultiAssayExperiment) S3method(dataset,data.frame) +S3method(format,join_keys) S3method(get_attrs,TealDataset) S3method(get_code,TealDataAbstract) S3method(get_code,TealDataset) diff --git a/R/join_keys.R b/R/join_keys.R index 51d055ef5..c584d22d7 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -383,28 +383,54 @@ length.join_keys <- function(x) { sum(vapply(x, function(.x) length(.x) > 0, logical(1))) } -#' Prints `join_keys`. -#' -#' @inheritParams base::print -#' + +#' @rdname join_keys #' @export -print.join_keys <- function(x, ...) { +format.join_keys <- function(x, ...) { check_ellipsis(...) - keys_list <- x - my_parents <- parents(keys_list) - class(keys_list) <- "list" - if (length(keys_list) > 0) { - cat(sprintf( - "A join_keys object containing foreign keys between %s datasets:\n", - length(x) - )) - # Hide parents - attr(keys_list, "__parents__") <- NULL # nolint: object_name_linter - non_empty_ix <- vapply(keys_list, function(.x) !is.null(.x) && length(.x) > 0, logical(1)) - print.default(keys_list[sort(names(keys_list))][non_empty_ix]) + if (length(x) > 0) { + my_parents <- parents(x) + names_sorted <- topological_sort(my_parents) + names <- union(names_sorted, names(x)) + + out <- lapply(names, function(i) { + this_parent <- my_parents[[i]] + out_i <- lapply(union(i, names(x[[i]])), function(j) { + direction <- if (identical(my_parents[[j]], i)) { + " <-- " + } else if (identical(my_parents[[i]], j)) { + " --> " + } else if (!identical(i, j)) { + " <-> " + } else { + "" + } + + keys <- x[[i]][[j]] + sprintf( + "%s%s: [%s]", + direction, j, + if (length(keys) == 0) "no primary keys" else toString(keys) + ) + }) + paste(out_i, collapse = "\n") + }) + paste( + c( + sprintf("A join_keys object containing foreign keys between %s datasets:", length(x)), + out + ), + collapse = "\n" + ) } else { - cat("An empty join_keys object.") + "An empty join_keys object." } +} + +#' @rdname join_keys +#' @export +print.join_keys <- function(x, ...) { + cat(format(x, ...), "\n") invisible(x) } diff --git a/man/assert_compatible_keys.Rd b/man/assert_compatible_keys.Rd deleted file mode 100644 index 2502996d2..000000000 --- a/man/assert_compatible_keys.Rd +++ /dev/null @@ -1,12 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{assert_compatible_keys} -\alias{assert_compatible_keys} -\title{Helper function to assert if two key sets contain incompatible keys} -\usage{ -assert_compatible_keys(join_key_1, join_key_2) -} -\description{ -return TRUE if compatible, throw error otherwise -} -\keyword{internal} diff --git a/man/assert_non_conflicting_keys.Rd b/man/assert_non_conflicting_keys.Rd new file mode 100644 index 000000000..488f05725 --- /dev/null +++ b/man/assert_non_conflicting_keys.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{assert_non_conflicting_keys} +\alias{assert_non_conflicting_keys} +\title{Helper function to assert non-conflicting keys} +\usage{ +assert_non_conflicting_keys(.x, .y) +} +\value{ +TRUE if compatible, throw error otherwise +} +\description{ +Function asserts that there are no key sets which refer to the same pair of +datasets. +} +\keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 0dd1ce937..9532efd47 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -13,6 +13,8 @@ \alias{[.join_keys} \alias{[<-.join_keys} \alias{[[<-.join_keys} +\alias{format.join_keys} +\alias{print.join_keys} \title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} \usage{ join_keys(...) @@ -38,6 +40,10 @@ join_keys(x) <- value \method{[}{join_keys}(x, i) <- value \method{[[}{join_keys}(x, i) <- value + +\method{format}{join_keys}(x, ...) + +\method{print}{join_keys}(x, ...) } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. diff --git a/man/print.join_keys.Rd b/man/print.join_keys.Rd deleted file mode 100644 index 5b8a5565b..000000000 --- a/man/print.join_keys.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{print.join_keys} -\alias{print.join_keys} -\title{Prints \code{join_keys}.} -\usage{ -\method{print}{join_keys}(x, ...) -} -\arguments{ -\item{x}{an object used to select a method.} - -\item{...}{further arguments passed to or from other methods.} -} -\description{ -Prints \code{join_keys}. -} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 49907194a..ee03b4db6 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -504,19 +504,57 @@ testthat::test_that("c.join_keys doesn't allow to specify the keys which are inc # # print.join_keys -testthat::test_that("print.join_keys for empty set", { +testthat::test_that("format.join_keys for empty set", { jk <- join_keys() - testthat::expect_output( - print(jk), - "An empty join_keys object." + testthat::expect_identical(format(jk), "An empty join_keys object.") +}) + +testthat::test_that("format.join_keys with empty parents", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") + ) + testthat::expect_identical( + format(my_keys), + paste( + "A join_keys object containing foreign keys between 3 datasets:", + "d1: [a]", " <-> d2: [ba]", "d2: [b]", " <-> d1: [ba]", " <-> d3: [ca]", + "d3: [c]", " <-> d2: [ca]", + sep = "\n" + ) ) }) -testthat::test_that("print.join_keys for a non-empty set", { - jk <- join_keys() - join_keys(jk) <- list(join_key("DF1", "DF2", c("id" = "fk"))) - testthat::expect_output( - print(jk), - "A join_keys object containing foreign keys between 2 datasets:" +testthat::test_that("format.join_keys for parents", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d2") + testthat::expect_identical( + format(my_keys), + paste( + "A join_keys object containing foreign keys between 3 datasets:", + "d1: [a]", " <-- d2: [ba]", "d2: [b]", " --> d1: [ba]", " <-- d3: [ca]", + "d3: [c]", " --> d2: [ca]", + sep = "\n" + ) + ) +}) + +testthat::test_that("print.join_keys produces output same as format", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") ) + testthat::expect_output(print(my_keys), format(my_keys), fixed = TRUE) }) From 807073968374db2a23248ae45ecbfb59be9ea2cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 15:37:27 +0100 Subject: [PATCH 105/152] fix: flattens objects when checking for compatible keys --- R/join_keys.R | 40 ++++++++++++++++++++++------------------ 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index c584d22d7..cb5881e79 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -452,24 +452,28 @@ new_join_keys <- function() { ) } -assert_compatible_keys2 <- function(.x, .y) { - if (length(.x) == 1 && length(.y) == 1) { - # both are join_key_set - assert_compatible_keys(.x, .y) - } else if (length(.x) > 1 && length(.y) > 1) { - # both are join_keys - need to compare all x with single y - for (idx_1 in seq_along(.x)) { - for (idx_2 in seq_along(.y)) { - assert_compatible_keys(.x[idx_1], .y[idx_2]) - } - } - } else if (length(.x) > 1 && length(.y) == 1) { - for (idx_1 in seq_along(.x)) { - assert_compatible_keys(.x[idx_1], .y) - } - } else if (length(.x) == 1 && length(.y) > 1) { - for (idx_2 in seq_along(.y)) { - assert_compatible_keys(.x, .y[idx_2]) +assert_compatible_keys2 <- function(x, y) { + # Helper to flatten join_keys / join_key_set + flatten_join_key_sets <- function(value) { + value <- unclass(value) + Reduce( + init = list(), + f = function(u, v, ...) { + el <- value[v][[1]] + res <- lapply(seq_along(el), function(ix) el[ix]) + names(res) <- rep(v, length(res)) + append(u, res) + }, + x = names(value) + ) + } + + x <- flatten_join_key_sets(x) + y <- flatten_join_key_sets(y) + + for (idx_1 in seq_along(x)) { + for (idx_2 in seq_along(y)) { + assert_compatible_keys(x[idx_1], y[idx_2]) } } } From c0c07d051c0a853488f3d379f67d66c034d402ee Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Wed, 15 Nov 2023 14:41:59 +0000 Subject: [PATCH 106/152] [skip actions] Roxygen Man Pages Auto Update --- man/assert_compatible_keys.Rd | 12 ++++++++++++ 1 file changed, 12 insertions(+) create mode 100644 man/assert_compatible_keys.Rd diff --git a/man/assert_compatible_keys.Rd b/man/assert_compatible_keys.Rd new file mode 100644 index 000000000..2502996d2 --- /dev/null +++ b/man/assert_compatible_keys.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys.R +\name{assert_compatible_keys} +\alias{assert_compatible_keys} +\title{Helper function to assert if two key sets contain incompatible keys} +\usage{ +assert_compatible_keys(join_key_1, join_key_2) +} +\description{ +return TRUE if compatible, throw error otherwise +} +\keyword{internal} From 0df4984f653b65530e11fce828d9347680b67e9d Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 15 Nov 2023 15:51:55 +0100 Subject: [PATCH 107/152] tests update --- tests/testthat/test-join_keys.R | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index ee03b4db6..34feb28f9 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -193,11 +193,6 @@ testthat::test_that("join_keys<-.join_keys overwrites existing join_keys", { testthat::expect_identical(my_keys, join_keys(join_key("d1", "d1", "test"))) }) -testthat::test_that("join_keys<-.join_keys accepts join_key_set object to modify keys", { - obj <- join_keys() - join_keys(obj) <- join_key("ds1", "ds2", "id") - testthat::expect_identical(obj, join_keys(join_key("ds1", "ds2", "id"))) -}) testthat::test_that("join_keys<-.teal_data overwrites existing join_keys", { td <- teal_data( @@ -311,7 +306,7 @@ testthat::test_that("[[<- mutating non-existing keys adds them", { ) }) -testthat::test_that("[[<- can key pair values can be set to character(0)", { +testthat::test_that("[[<- setting a key to character(0) drops the key", { my_keys <- join_keys( join_key("d1", "d2", "A"), join_key("d2", "d3", "B") @@ -321,10 +316,7 @@ testthat::test_that("[[<- can key pair values can be set to character(0)", { testthat::expect_identical( my_keys, - join_keys( - join_key("d1", "d2", character(0)), - join_key("d2", "d3", "B") - ) + join_keys(join_key("d2", "d3", "B")) ) }) @@ -436,10 +428,7 @@ testthat::test_that("c.join_keys duplicated keys are ignored", { obj <- c(obj, join_key("a", "a", "aa"), join_key("a", "a", "aa")) testthat::expect_identical( obj, - join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb") - ) + join_keys(join_key("a", "a", "aa")) ) }) @@ -489,7 +478,7 @@ testthat::test_that("c.join_keys doesn't throw when second object is empty join_ testthat::expect_no_error(c(x, y)) }) -testthat::test_that("c.join_keys doesn't allow to specify the keys which are incompatible", { +testthat::test_that("c.join_keys throws on conflicting join_keys_set objects", { obj <- join_keys() testthat::expect_error( c( From 5f7509ac7cefb4de2ad1431fa4c9e742e3714808 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 16:16:07 +0100 Subject: [PATCH 108/152] feat: support c.join_key_set that behaves just like c.join_keys --- NAMESPACE | 1 + R/join_keys.R | 12 +++++++++- man/assert_non_conflicting_keys.Rd | 16 -------------- man/join_keys.Rd | 5 +++++ tests/testthat/test-join_keys.R | 35 +++++++++++++++++++++++++++++- 5 files changed, 51 insertions(+), 18 deletions(-) delete mode 100644 man/assert_non_conflicting_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index 8a5907a05..1ee9b0b06 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,7 @@ S3method("parents<-",join_keys) S3method("parents<-",teal_data) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) +S3method(c,join_key_set) S3method(c,join_keys) S3method(dataset,MultiAssayExperiment) S3method(dataset,data.frame) diff --git a/R/join_keys.R b/R/join_keys.R index cb5881e79..2b49a40f9 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -149,7 +149,7 @@ join_keys.default <- function(...) { c.join_keys <- function(...) { join_keys_obj <- rlang::list2(...)[[1]] x <- rlang::list2(...)[-1] - checkmate::assert_class(join_keys_obj, c("join_keys", "list")) + checkmate::assert_multi_class(join_keys_obj, classes = c("join_keys", "join_key_set")) checkmate::assert_list(x, types = c("join_keys", "join_key_set")) x_merged <- Reduce( @@ -164,6 +164,16 @@ c.join_keys <- function(...) { utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) } +#' @rdname join_keys +#' @export +#' +#' @examples +#' +#' c(join_key("a", "b", "c"), join_keys(join_key("a", "d2", "c"))) +c.join_key_set <- function(...) { + c.join_keys(...) +} + #' The Names of an `join_keys` Object #' @inheritParams base::`names<-` #' @export diff --git a/man/assert_non_conflicting_keys.Rd b/man/assert_non_conflicting_keys.Rd deleted file mode 100644 index 488f05725..000000000 --- a/man/assert_non_conflicting_keys.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R -\name{assert_non_conflicting_keys} -\alias{assert_non_conflicting_keys} -\title{Helper function to assert non-conflicting keys} -\usage{ -assert_non_conflicting_keys(.x, .y) -} -\value{ -TRUE if compatible, throw error otherwise -} -\description{ -Function asserts that there are no key sets which refer to the same pair of -datasets. -} -\keyword{internal} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 9532efd47..0948eaabf 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -10,6 +10,7 @@ \alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} \alias{c.join_keys} +\alias{c.join_key_set} \alias{[.join_keys} \alias{[<-.join_keys} \alias{[[<-.join_keys} @@ -35,6 +36,8 @@ join_keys(x) <- value \method{c}{join_keys}(...) +\method{c}{join_key_set}(...) + \method{[}{join_keys}(x, i, keep_all_foreign_keys = FALSE) \method{[}{join_keys}(x, i) <- value @@ -131,6 +134,8 @@ join_keys(td) c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) +c(join_key("a", "b", "c"), join_keys(join_key("a", "d2", "c"))) + # Getter for join_keys ---- jk <- join_keys() diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 34feb28f9..f4a3a9381 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -68,6 +68,18 @@ testthat::test_that("join_keys fails when provided foreign key pairs have incomp join_keys(join_key("d1", "d2", c(a = "b")), join_key("d2", "d1", c(a = "b"))), "cannot specify multiple different join keys between datasets" ) + + testthat::expect_error( + join_keys( + join_keys( + join_key("q", "b", "d"), + join_key("a", "b", "c") + ), + join_key("a", "q", "e"), + join_key("a", "b", "f") + ), + "cannot specify multiple different join keys between datasets" + ) }) testthat::test_that("join_keys constructor adds symmetric keys on given (unnamed) foreign key", { @@ -485,7 +497,28 @@ testthat::test_that("c.join_keys throws on conflicting join_keys_set objects", { obj, join_keys(join_key("a", "b", "aa")), join_keys(join_key("b", "a", "bb")) - ) + ), + "cannot specify multiple different join keys between datasets" + ) + + testthat::expect_error( + c( + obj, + join_key("a", "b", "aa"), + join_key("b", "a", "bb") + ), + "cannot specify multiple different join keys between datasets" + ) +}) + +testthat::test_that("c.join_key_set throws on conflicting join_keys_set objects", { + testthat::expect_error( + c( + join_key("a", "b", "aa"), + join_key("a", "b", "ca"), + join_key("a", "b", "cc") + ), + "cannot specify multiple different join keys between datasets" ) }) From 236c5f7c3ca8c0a109f71aa9d0c7771e2fc8855c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 18:09:17 +0100 Subject: [PATCH 109/152] fix: checks for compatible keys on [[<- --- R/join_keys.R | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/R/join_keys.R b/R/join_keys.R index 2b49a40f9..d8b7f8e0c 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -329,6 +329,18 @@ c.join_key_set <- function(...) { norm_value <- lapply(seq_along(value), function(.x) { join_key(i, names(value)[.x], value[[.x]]) }) + names(norm_value) <- names(value) + + # Check if multiple modifications don't have a conflict + repeated_value_ix <- names(value) %in% names(value)[duplicated(names(value))] + repeated <- norm_value[repeated_value_ix] + vapply( + seq_along(repeated), + function(.ix, .x_value = repeated[[.ix]], .x_name = get_dataset_2(.x_value)) { + assert_compatible_keys(.x_value, repeated[-.ix][names(repeated[-.ix]) == .x_name]) + }, + logical(1) + ) norm_value <- lapply(norm_value, get_keys) names(norm_value) <- names(value) @@ -486,6 +498,7 @@ assert_compatible_keys2 <- function(x, y) { assert_compatible_keys(x[idx_1], y[idx_2]) } } + TRUE } #' Helper function to assert if two key sets contain incompatible keys From db5a5780a52751100d30f33f6f6398b70755a43e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Wed, 15 Nov 2023 18:29:34 +0100 Subject: [PATCH 110/152] removes duplicate keys during assignment --- R/join_keys.R | 10 +++++++++- tests/testthat/test-join_keys.R | 14 ++++++++++++++ 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/R/join_keys.R b/R/join_keys.R index d8b7f8e0c..e6d6bb5bc 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -337,7 +337,12 @@ c.join_key_set <- function(...) { vapply( seq_along(repeated), function(.ix, .x_value = repeated[[.ix]], .x_name = get_dataset_2(.x_value)) { - assert_compatible_keys(.x_value, repeated[-.ix][names(repeated[-.ix]) == .x_name]) + assert_compatible_keys2( + .x_value, + unlist(unname( + repeated[-.ix][names(repeated[-.ix]) == .x_name] + ), recursive = FALSE) + ) }, logical(1) ) @@ -345,6 +350,9 @@ c.join_key_set <- function(...) { norm_value <- lapply(norm_value, get_keys) names(norm_value) <- names(value) + # 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) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index f4a3a9381..5b821d9e3 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -394,6 +394,20 @@ testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for sa ) }) +testthat::test_that("[[<-.join_keys succeeds when provided foreign key pairs for same datasets and same keys", { + jk <- join_keys() + + testthat::expect_silent( + jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new")) + ) + + testthat::expect_silent( + jk[["ds1"]] <- list(ds2 = "new", ds2 = "new") + ) + + testthat::expect_length(jk[["ds1"]], 1) +}) + # ----------------------------------------------------------------------------- # # names<-.join_keys From 26eff1be60579c5c8542e75e2ed8c2f146abe73a Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 16 Nov 2023 07:26:54 +0100 Subject: [PATCH 111/152] more test coverage --- R/join_key.R | 18 ------------------ R/join_keys.R | 10 ++-------- tests/testthat/test-join_keys.R | 30 +++++++++++++++++------------- tests/testthat/test-parents.R | 10 ++++++++-- 4 files changed, 27 insertions(+), 41 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index ba0872d83..110f534f9 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -76,24 +76,6 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { ) } -#' Getter for attributes in `join_key_set` object -#' -#' Internal methods for `join_key_set` operations -#' -#' @param join_key_set_object (`join_key_set`) object to retrieve attribute from. -#' @return `dataset_1`, `dataset_2` or `key` as `character(1)` -#' -#' @keywords internal -get_dataset_1 <- function(join_key_set_object) { - names(join_key_set_object) -} - -#' @rdname get_dataset_1 -#' @keywords internal -get_dataset_2 <- function(join_key_set_object) { - names(join_key_set_object[[1]]) -} - #' @rdname get_dataset_1 #' @keywords internal get_keys.join_key_set <- function(join_key_set_object) { diff --git a/R/join_keys.R b/R/join_keys.R index e6d6bb5bc..c7a7c9bda 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -336,7 +336,7 @@ c.join_key_set <- function(...) { repeated <- norm_value[repeated_value_ix] vapply( seq_along(repeated), - function(.ix, .x_value = repeated[[.ix]], .x_name = get_dataset_2(.x_value)) { + function(.ix, .x_value = repeated[[.ix]], .x_name = names(.x_value[[1]])) { assert_compatible_keys2( .x_value, unlist(unname( @@ -347,7 +347,7 @@ c.join_key_set <- function(...) { logical(1) ) - norm_value <- lapply(norm_value, get_keys) + norm_value <- lapply(norm_value, function(x) x[[1]][[1]]) names(norm_value) <- names(value) # Safe to do as duplicated are the same @@ -584,12 +584,6 @@ assert_parent_child <- function(x) { if (length(keys_from) == 0 && length(keys_to) == 0) { stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) } - if (length(keys_from) == 0) { - stop(sprintf("No join keys from %s to its parent (%s)", name_from, name_to)) - } - if (length(keys_to) == 0) { - stop(sprintf("No join keys from %s parent name (%s) to %s", name_from, name_to, name_from)) - } } } } diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 5b821d9e3..20d7fde68 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -205,7 +205,6 @@ testthat::test_that("join_keys<-.join_keys overwrites existing join_keys", { testthat::expect_identical(my_keys, join_keys(join_key("d1", "d1", "test"))) }) - testthat::test_that("join_keys<-.teal_data overwrites existing join_keys", { td <- teal_data( d1 = data.frame(), d2 = data.frame(), @@ -255,6 +254,20 @@ testthat::test_that("[[<-.join_keys accepts named list where each containing cha ) }) +testthat::test_that("[[<-.join_keys accepts integerish as index", { + jk <- join_keys(join_key("a", "a", "aa")) + testthat::expect_no_error( + jk[[1]][[1]] <- "bb" + ) +}) + +testthat::test_that("[[<-.join_keys accepts unnamed vector", { + jk <- join_keys() + testthat::expect_no_error( + jk[["d1"]] <- list(d1 = c("a", "b", "c")) + ) +}) + testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { jk <- join_keys() testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) @@ -387,25 +400,16 @@ testthat::test_that("[[<-.join_keys passing key unnamed 'empty' value is ignored testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for same datasets, but different keys", { jk <- join_keys() - testthat::expect_error( jk[["ds1"]] <- list(ds2 = "new", ds2 = "new_but_different"), "cannot specify multiple different join keys between datasets" ) }) -testthat::test_that("[[<-.join_keys succeeds when provided foreign key pairs for same datasets and same keys", { +testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for same datasets and same keys", { jk <- join_keys() - - testthat::expect_silent( - jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new")) - ) - - testthat::expect_silent( - jk[["ds1"]] <- list(ds2 = "new", ds2 = "new") - ) - - testthat::expect_length(jk[["ds1"]], 1) + testthat::expect_silent(jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new"))) + testthat::expect_identical(jk, join_keys(join_key("ds1", "ds2", "new"))) }) # ----------------------------------------------------------------------------- diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-parents.R index 879e9ef22..d06281734 100644 --- a/tests/testthat/test-parents.R +++ b/tests/testthat/test-parents.R @@ -41,6 +41,14 @@ testthat::test_that("parents<- dataset can't be own parent", { testthat::expect_error(parents(jk) <- list(a = "a")) }) +testthat::test_that("parents<- setting parent-child relationship fails when no foreign keys between datasets", { + jk <- join_keys( + join_key("a", "1", "aa"), + join_key("b", "b", "bb") + ) + testthat::expect_error(parents(jk) <- list(a = "b")) +}) + testthat::test_that("parents<- ensures it is a directed acyclical graph (DAG)", { cyclic_jk <- join_keys( join_key("a", "b", "id"), @@ -80,8 +88,6 @@ testthat::test_that("parents<- setting parents again overwrites previous state", testthat::expect_identical(parents(jk), list(b = "a")) }) - - testthat::test_that("parents<- sets parent datasets to join_keys kept in teal_data", { td <- teal_data( a = data.frame(), From dc6df6a687cb346dc38577dc049787b5caf9f7c7 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 16 Nov 2023 08:27:07 +0100 Subject: [PATCH 112/152] fix parents on names<- --- R/join_key.R | 1 - R/join_keys.R | 48 ++++++++++++++++----------------- man/get_dataset_1.Rd | 24 ----------------- man/join_key.Rd | 1 - tests/testthat/test-join_keys.R | 23 +++++++++++++++- 5 files changed, 46 insertions(+), 51 deletions(-) delete mode 100644 man/get_dataset_1.Rd diff --git a/R/join_key.R b/R/join_key.R index 110f534f9..f268170bc 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -23,7 +23,6 @@ #' join_key("d1", "d2", c("A")) #' join_key("d1", "d2", c("A" = "B")) #' join_key("d1", "d2", c("A" = "B", "C")) -#' join_key("d1", "d2", c("A" = "B", "C" = "")) join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { checkmate::assert_string(dataset_1) checkmate::assert_string(dataset_2) diff --git a/R/join_keys.R b/R/join_keys.R index c7a7c9bda..d1401b976 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -115,13 +115,7 @@ join_keys.default <- function(...) { #' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk `join_keys<-.join_keys` <- function(x, value) { - # Assume assignment of join keys as a merge operation - # Needed to support join_keys(jk)[c("ds1", "ds2")] <- "key" - if (checkmate::test_class(value, classes = c("join_keys", "list"))) { - return(value) - } - join_keys_obj <- new_join_keys() - c(join_keys_obj, value) + value } #' @rdname join_keys @@ -178,22 +172,37 @@ c.join_key_set <- function(...) { #' @inheritParams base::`names<-` #' @export `names<-.join_keys` <- function(x, value) { - x <- unclass(x) + new_x <- unclass(x) + parent_list <- parents(x) # Update inner keys - for (old_name in setdiff(names(x), value)) { - old_entry <- x[[old_name]] - new_name <- value[names(x) == old_name] + for (old_name in setdiff(names(new_x), value)) { + old_entry <- new_x[[old_name]] + new_name <- value[names(new_x) == old_name] # Change 2nd-tier first for (sub_name in names(old_entry)) { - names(x[[sub_name]])[names(x[[sub_name]]) == old_name] <- new_name + names(new_x[[sub_name]])[names(new_x[[sub_name]]) == old_name] <- new_name } # Change in first tier - names(x)[names(x) == old_name] <- new_name + names(new_x)[names(new_x) == old_name] <- new_name + + # 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 + } + }) + attr(new_x, "__parents__") <- parent_list + } } - class(x) <- c("join_keys", "list") - x + + class(new_x) <- c("join_keys", "list") + new_x } #' @rdname join_keys @@ -520,10 +529,6 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { ) } - if (!length(join_key_1) || !length(join_key_2)) { - return(TRUE) - } - dataset_1_one <- names(join_key_1) dataset_2_one <- names(join_key_1[[1]]) keys_one <- join_key_1[[1]][[1]] @@ -544,11 +549,6 @@ assert_compatible_keys <- function(join_key_1, join_key_2) { # and the first dataset of join_key_2 must match second dataset of join_key_1 # and keys must contain the same elements but with names and values swapped if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) { - # have to handle empty case differently as names(character(0)) is NULL - if (length(keys_one) == 0 && length(keys_two) == 0) { - return(TRUE) - } - if ( xor(length(keys_one) == 0, length(keys_two) == 0) || !identical(sort(keys_one), sort(setNames(names(keys_two), keys_two))) diff --git a/man/get_dataset_1.Rd b/man/get_dataset_1.Rd deleted file mode 100644 index aa7d87d6a..000000000 --- a/man/get_dataset_1.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_key.R -\name{get_dataset_1} -\alias{get_dataset_1} -\alias{get_dataset_2} -\alias{get_keys.join_key_set} -\title{Getter for attributes in \code{join_key_set} object} -\usage{ -get_dataset_1(join_key_set_object) - -get_dataset_2(join_key_set_object) - -\method{get_keys}{join_key_set}(join_key_set_object) -} -\arguments{ -\item{join_key_set_object}{(\code{join_key_set}) object to retrieve attribute from.} -} -\value{ -\code{dataset_1}, \code{dataset_2} or \code{key} as \code{character(1)} -} -\description{ -Internal methods for \code{join_key_set} operations -} -\keyword{internal} diff --git a/man/join_key.Rd b/man/join_key.Rd index 0e4f3d004..7fda787ab 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -31,7 +31,6 @@ of datasets. join_key("d1", "d2", c("A")) join_key("d1", "d2", c("A" = "B")) join_key("d1", "d2", c("A" = "B", "C")) -join_key("d1", "d2", c("A" = "B", "C" = "")) } \seealso{ \code{\link[=join_keys]{join_keys()}} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 20d7fde68..1cb083e5e 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -416,7 +416,7 @@ testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for s # # names<-.join_keys # -testthat::test_that("names<-.join_keys will replace names at first and second level of the join_keys list", { +testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list", { jk <- join_keys( join_key("a", "a", "a"), join_key("a", "b", "ab"), @@ -437,6 +437,27 @@ testthat::test_that("names<-.join_keys will replace names at first and second le ) }) +testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list when parents set", { + jk <- join_keys( + join_key("a", "a", "a"), + join_key("b", "a", "ba"), + join_key("c", "a", "ca"), + join_key("d", "b", "db") + ) + parents(jk) <- list(b = "a", c = "a", d = "b") + + expected <- join_keys( + join_key("a", "a", "a"), + join_key("B", "a", "ba"), + join_key("c", "a", "ca"), + join_key("d", "B", "db") + ) + parents(expected) <- list(B = "a", c = "a", d = "B") + + names(jk)[2] <- "B" + testthat::expect_identical(jk, expected) +}) + # ----------------------------------------------------------------------------- # # c.join_keys From ef6832b95040b722bcd793446f93c3c10645b1f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 10:21:28 +0100 Subject: [PATCH 113/152] fix: R CMD check --- R/join_keys.R | 10 +++++----- man/join_keys.Rd | 6 ++++-- tests/testthat/test-MAETealDataset.R | 5 ++++- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index d1401b976..38033b8cf 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -209,7 +209,9 @@ c.join_key_set <- function(...) { #' @details #' Getter for `join_keys` that returns the relationship between pairs of datasets. #' -#' @inheritParams base::`[[` +#' @param i index specifying elements to extract or replace. Index should be a +#' a character vector, but it can also take numeric, logical, `NULL` or missing. +#' #' @param keep_all_foreign_keys (`logical`) flag that keeps foreign keys and other #' datasets even if they are not a parent of the selected dataset. #' @@ -293,11 +295,9 @@ c.join_key_set <- function(...) { } #' @rdname join_keys -#' @details -#' Setter via index directly (bypassing the need to use `join_key()`). -#' When `dataset_2` is omitted, it will create a primary key with `dataset_2 = dataset_1`. #' -#' @inheritParams base::`[<-` +#' @details +#' `[<-` is not a supported operation for `join_keys`. #' #' @export `[<-.join_keys` <- function(x, i, value) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 0948eaabf..988cf7ea5 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -60,6 +60,9 @@ constructed from the arguments.} \item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add to \code{join_keys} list.} +\item{i}{index specifying elements to extract or replace. Index should be a +a character vector, but it can also take numeric, logical, \code{NULL} or missing.} + \item{keep_all_foreign_keys}{(\code{logical}) flag that keeps foreign keys and other datasets even if they are not a parent of the selected dataset.} } @@ -88,8 +91,7 @@ is not empty. Getter for \code{join_keys} that returns the relationship between pairs of datasets. -Setter via index directly (bypassing the need to use \code{join_key()}). -When \code{dataset_2} is omitted, it will create a primary key with \code{dataset_2 = dataset_1}. +\verb{[<-} is not a supported operation for \code{join_keys}. } \examples{ # Setting join keys ---- diff --git a/tests/testthat/test-MAETealDataset.R b/tests/testthat/test-MAETealDataset.R index 360ef5c04..e5298829b 100644 --- a/tests/testthat/test-MAETealDataset.R +++ b/tests/testthat/test-MAETealDataset.R @@ -159,7 +159,10 @@ testthat::test_that("MAETealDataset$check_keys doesn't throw if constructed with utils::data(miniACC, package = "MultiAssayExperiment") mae <- MAETealDataset$new(dataname = "miniACC", x = miniACC, keys = "patientID") testthat::skip_on_ci() - testthat::expect_silent(mae$check_keys()) + withr::with_envvar( + new = c("_R_CHECK_AS_DATA_FRAME_EXPLICIT_METHOD_" = ""), + testthat::expect_silent(mae$check_keys()) + ) }) testthat::test_that("MAETealDataset$check_keys throws if constructed with keys not present in colData", { From d72b9b0f1c54a28c9a06574c930830cc7151d0a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 10:58:44 +0100 Subject: [PATCH 114/152] docs: improve on some examples --- R/join_key.R | 1 - R/join_keys.R | 86 ++++++++++++++++++++++++++----------------- man/join_keys.Rd | 96 ++++++++++++++++++++++++++++-------------------- 3 files changed, 108 insertions(+), 75 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index f268170bc..1ce3dcaf9 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -75,7 +75,6 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { ) } -#' @rdname get_dataset_1 #' @keywords internal get_keys.join_key_set <- function(join_key_set_object) { join_key_set_object[[1]][[1]] diff --git a/R/join_keys.R b/R/join_keys.R index 38033b8cf..c0504f6b1 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -4,16 +4,23 @@ #' #' @description `r lifecycle::badge("stable")` #' -#' @details - `join_keys()`: When called without arguments it will return an +#' Note that join keys are created symmetrically, that is, if `dat1` and `dat2` +#' have a join key of `col1`, then 2 join keys are created, `dat1 → dat2` and +#' `dat2 → dat1`. The only exception is for a primary key. +#' +#' @details +#' +#' - `join_keys()`: When called without arguments it will return an #' empty constructor. #' - `join_keys(x)`: When called with a single argument it will return the `join_keys` #' object contained in `x` (if it contains a `join_keys` object). #' - `join_keys(...)`: When called with a single or more `join_key_set` parameters it will #' create a new object. +#' - `[[.join_keys` is the preferred getter for `join_keys` that returns the +#' relationship between pairs of datasets. It returns `NULL` if there is nor +#' relationship. #' -#' Note that join keys are created symmetrically, that is, if `dat1` and `dat2` -#' have a join key of `col1`, then 2 join keys are created, `dat1 → dat2` and -#' `dat2 → dat1`. The only exception is for a primary key. +#' @order 1 #' #' @param ... (optional), when no argument is given the empty constructor is called. #' Otherwise, when called with only one argument of type: `join_keys` or `teal_data` @@ -40,15 +47,14 @@ #' jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") #' jk #' -#' td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) -#' join_keys(td) +#' # Retrieving a key for relationship pair #' -#' jk <- join_keys() -#' join_keys(jk) +#' jk[["dataset_A"]][["dataset_B"]] #' -#' jk <- join_keys() -#' jk <- c(jk, join_keys(join_key("a", "b", "c"))) -#' jk <- c(jk, join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c"))) +#' # Using a teal_data (which contains a join_keys object) +#' +#' td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) +#' join_keys(td) join_keys <- function(...) { if (missing(...)) { return(new_join_keys()) @@ -89,9 +95,10 @@ join_keys.default <- function(...) { } #' @rdname join_keys +#' #' @details -#' The setter assignment `join_keys(obj) <- ...` will merge obj and `...` if obj -#' is not empty. +#' - "`join_keys(obj) <- value`" will set the `join_keys` in object with `value`. +#' `value` needs to be an object of class `join_keys` or `join_key_set`. #' #' @param x (`join_keys`) empty object to set the new relationship pairs. #' @param value (`join_key_set` or list of `join_key_set`) relationship pairs to add @@ -109,9 +116,6 @@ join_keys.default <- function(...) { #' #' # Using the setter (assignment) ---- #' -#' jk <- join_keys() -#' join_keys(jk) <- join_keys(join_keys(jk), join_key("ds3", "ds4", "some_col2")) -#' #' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" #' jk `join_keys<-.join_keys` <- function(x, value) { @@ -139,7 +143,9 @@ join_keys.default <- function(...) { #' #' @examples #' -#' c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) +#' # Merging multiple `join_keys` +#' +#' jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) c.join_keys <- function(...) { join_keys_obj <- rlang::list2(...)[[1]] x <- rlang::list2(...)[-1] @@ -163,7 +169,13 @@ c.join_keys <- function(...) { #' #' @examples #' -#' c(join_key("a", "b", "c"), join_keys(join_key("a", "d2", "c"))) +#' # Note that you can merge join_keys or a single join_key_set +#' +#' jk_merged <- c( +#' jk_merged, +#' join_key("dataset_A", "dataset_F", "col_a"), +#' join_key("dataset_O", "dataset_G", "col_g") +#' ) c.join_key_set <- function(...) { c.join_keys(...) } @@ -206,8 +218,11 @@ c.join_key_set <- function(...) { } #' @rdname join_keys +#' #' @details -#' Getter for `join_keys` that returns the relationship between pairs of datasets. +#' - `[.join_keys` can be used to return a subset of relationship pairs. It will +#' retrieve the primary keys of the selected elements and its parents (along with) +#' the relationship keys between the selected elements and their parents. #' #' @param i index specifying elements to extract or replace. Index should be a #' a character vector, but it can also take numeric, logical, `NULL` or missing. @@ -221,9 +236,10 @@ c.join_key_set <- function(...) { #' #' # Getter for join_keys ---- #' -#' jk <- join_keys() -#' jk[["ds1"]][["ds2"]] <- "some_col" -#' jk[["ds1"]][["ds3"]] <- "some_col2" +#' jk <- join_keys( +#' join_key("ds1", "ds2", "some_col"), +#' join_key("ds1", "ds3", "some_col2") +#' ) #' #' jk["ds1"] #' jk[1:2] @@ -297,7 +313,7 @@ c.join_key_set <- function(...) { #' @rdname join_keys #' #' @details -#' `[<-` is not a supported operation for `join_keys`. +#' - `[<-` is not a supported operation for `join_keys`. #' #' @export `[<-.join_keys` <- function(x, i, value) { @@ -305,21 +321,23 @@ c.join_key_set <- function(...) { } #' @rdname join_keys -#' @export -#' @examples #' -#' jk <- join_keys() -#' jk[["ds1"]] <- list() -#' jk[["ds2"]][["ds3"]] <- "key" +#' @order 3 #' -#' jk <- join_keys() -#' jk[["ds1"]] <- list() -#' jk[["ds2"]][["ds3"]] <- "key" -#' jk[["ds4"]] <- list(ds5 = "new") +#' @details +#' - `[[<-` is the preferred method to replace or assign new relationship pair to an +#' existing `join_keys` object. +#' - `join_keys(obj)[[dataset_1]] <- value` can also be used to assign a relationship +#' pair to an `obj` that contains a `join_keys`, such as itself or a `teal_data` +#' object. +#' +#' @export +#' @examples #' #' jk <- join_keys() -#' jk[["ds2"]][["ds3"]] <- "key" -#' jk[["ds2"]][["ds3"]] <- NULL +#' jk[["dataset_A"]][["dataset_B"]] <- "key" +#' jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") +#' jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key #' #' jk `[[<-.join_keys` <- function(x, i, value) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 988cf7ea5..8e43beddc 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/join_keys.R \name{join_keys} \alias{join_keys} +\alias{[[<-.join_keys} \alias{join_keys.join_keys} \alias{join_keys.teal_data} \alias{join_keys.TealData} @@ -13,13 +14,14 @@ \alias{c.join_key_set} \alias{[.join_keys} \alias{[<-.join_keys} -\alias{[[<-.join_keys} \alias{format.join_keys} \alias{print.join_keys} \title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} \usage{ join_keys(...) +\method{[[}{join_keys}(x, i) <- value + \method{join_keys}{join_keys}(...) \method{join_keys}{teal_data}(...) @@ -42,8 +44,6 @@ join_keys(x) <- value \method{[}{join_keys}(x, i) <- value -\method{[[}{join_keys}(x, i) <- value - \method{format}{join_keys}(x, ...) \method{print}{join_keys}(x, ...) @@ -57,12 +57,12 @@ constructed from the arguments.} \item{x}{(\code{join_keys}) empty object to set the new relationship pairs.} -\item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add -to \code{join_keys} list.} - \item{i}{index specifying elements to extract or replace. Index should be a a character vector, but it can also take numeric, logical, \code{NULL} or missing.} +\item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add +to \code{join_keys} list.} + \item{keep_all_foreign_keys}{(\code{logical}) flag that keeps foreign keys and other datasets even if they are not a parent of the selected dataset.} } @@ -71,6 +71,10 @@ datasets even if they are not a parent of the selected dataset.} } \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Note that join keys are created symmetrically, that is, if \code{dat1} and \code{dat2} +have a join key of \code{col1}, then 2 join keys are created, \verb{dat1 → dat2} and +\verb{dat2 → dat1}. The only exception is for a primary key. } \details{ \itemize{ @@ -80,18 +84,33 @@ empty constructor. object contained in \code{x} (if it contains a \code{join_keys} object). \item \code{join_keys(...)}: When called with a single or more \code{join_key_set} parameters it will create a new object. +\item \verb{[[.join_keys} is the preferred getter for \code{join_keys} that returns the +relationship between pairs of datasets. It returns \code{NULL} if there is nor +relationship. } -Note that join keys are created symmetrically, that is, if \code{dat1} and \code{dat2} -have a join key of \code{col1}, then 2 join keys are created, \verb{dat1 → dat2} and -\verb{dat2 → dat1}. The only exception is for a primary key. +\itemize{ +\item \verb{[[<-} is the preferred method to replace or assign new relationship pair to an +existing \code{join_keys} object. +\item \code{join_keys(obj)[[dataset_1]] <- value} can also be used to assign a relationship +pair to an \code{obj} that contains a \code{join_keys}, such as itself or a \code{teal_data} +object. +} -The setter assignment \code{join_keys(obj) <- ...} will merge obj and \code{...} if obj -is not empty. +\itemize{ +\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. +\code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. +} -Getter for \code{join_keys} that returns the relationship between pairs of datasets. +\itemize{ +\item \verb{[.join_keys} can be used to return a subset of relationship pairs. It will +retrieve the primary keys of the selected elements and its parents (along with) +the relationship keys between the selected elements and their parents. +} -\verb{[<-} is not a supported operation for \code{join_keys}. +\itemize{ +\item \verb{[<-} is not a supported operation for \code{join_keys}. +} } \examples{ # Setting join keys ---- @@ -108,21 +127,24 @@ jk[["dataset_A"]][["dataset_B"]] <- c("col_1" = "col_a") jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") jk +# Retrieving a key for relationship pair + +jk[["dataset_A"]][["dataset_B"]] + +# Using a teal_data (which contains a join_keys object) + td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) join_keys(td) jk <- join_keys() -join_keys(jk) +jk[["dataset_A"]][["dataset_B"]] <- "key" +jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") +jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key -jk <- join_keys() -jk <- c(jk, join_keys(join_key("a", "b", "c"))) -jk <- c(jk, join_keys(join_key("a", "b", "c"), join_key("a", "b2", "c"))) +jk # Using the setter (assignment) ---- -jk <- join_keys() -join_keys(jk) <- join_keys(join_keys(jk), join_key("ds3", "ds4", "some_col2")) - join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" jk @@ -134,32 +156,26 @@ join_keys(td)[["ds2"]][["ds2"]] <- "key2" join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) -c(join_keys(join_key("a", "b", "c")), join_keys(join_key("a", "d2", "c"))) +# Merging multiple `join_keys` + +jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) + +# Note that you can merge join_keys or a single join_key_set -c(join_key("a", "b", "c"), join_keys(join_key("a", "d2", "c"))) +jk_merged <- c( + jk_merged, + join_key("dataset_A", "dataset_F", "col_a"), + join_key("dataset_O", "dataset_G", "col_g") +) # Getter for join_keys ---- -jk <- join_keys() -jk[["ds1"]][["ds2"]] <- "some_col" -jk[["ds1"]][["ds3"]] <- "some_col2" +jk <- join_keys( + join_key("ds1", "ds2", "some_col"), + join_key("ds1", "ds3", "some_col2") +) jk["ds1"] jk[1:2] jk[c("ds1", "ds2")] - -jk <- join_keys() -jk[["ds1"]] <- list() -jk[["ds2"]][["ds3"]] <- "key" - -jk <- join_keys() -jk[["ds1"]] <- list() -jk[["ds2"]][["ds3"]] <- "key" -jk[["ds4"]] <- list(ds5 = "new") - -jk <- join_keys() -jk[["ds2"]][["ds3"]] <- "key" -jk[["ds2"]][["ds3"]] <- NULL - -jk } From 82f22e1082dbb0c8c084a30c2ddcb592316411b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 11:49:06 +0100 Subject: [PATCH 115/152] docs: adds missing entry to pkgdown --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index e51e49fd4..83a3cf49e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -124,6 +124,7 @@ reference: - join_keys - join_keys<- - length.join_keys + - names<-.join_keys - parent - parents - parents<- From b4087193ee694fc156794eacb9a69505cc72b05f Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 16 Nov 2023 13:03:02 +0100 Subject: [PATCH 116/152] add tests for [[.join_keys --- tests/testthat/test-join_keys.R | 49 +++++++++++++++++++++++++++++++-- 1 file changed, 47 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 1cb083e5e..ca1c9bfea 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -101,9 +101,43 @@ testthat::test_that("join_keys constructor adds symmetric keys on given (named) ) ) }) +# [.join_keys ----------------------------------------------------------------- +testthat::test_that("[[.join_keys returns keys for given pair", { + 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[["b"]][["a"]], c(`child-parent` = "child-parent")) +}) + +testthat::test_that("[[.join_keys doesn't return keys for given a pair without explicit join_key", { + 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_null(my_keys[["b"]][["c"]]) +}) + +testthat::test_that("[[.join_keys infer keys between child by shared foreign keys 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", "child-parent"), + join_key("c", "a", "child-parent") + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + testthat::expect_identical(my_keys[["b"]][["c"]], c(`child-parent` = "child-parent")) +}) # [.join_keys ----------------------------------------------------------------- -testthat::test_that("[.join_keys returns join_keys object", { +testthat::test_that("[.join_keys returns join_keys object when i is missing", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -198,6 +232,18 @@ testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset" testthat::expect_length(my_keys["d2"], 0) }) +testthat::test_that("[.join_keys ignores duplicate indexes - return only first occurrence", { + jk <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d2", "b") + ) + testthat::expect_identical( + jk[c("d1", "d2", "d1")], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + ) +}) + # join_keys.<- ---------------------------------------------------------------- testthat::test_that("join_keys<-.join_keys overwrites existing join_keys", { my_keys <- join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) @@ -239,7 +285,6 @@ testthat::test_that("join_keys()[]<-.join_keys with named empty valued is change expect_equal(jk[["d1"]][["d2"]], c(A = "B", C = "C")) }) - testthat::test_that("join_keys()[]<-.join_keys with empty value in a named vector are ignored ", { jk <- join_keys() testthat::expect_message(join_keys(jk)[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") From 2c412513f1531c6e801978f933a7a21e5dde6ce0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 13:31:23 +0100 Subject: [PATCH 117/152] fix: linter errors --- tests/testthat/test-join_keys.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index ca1c9bfea..5a99a1020 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -459,7 +459,7 @@ testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for s # ----------------------------------------------------------------------------- # -# names<-.join_keys +# Setting names (names<-join_keys) # testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list", { jk <- join_keys( @@ -505,7 +505,7 @@ testthat::test_that("names<-.join_keys will replace names at all levels of the j # ----------------------------------------------------------------------------- # -# c.join_keys +# Merging join_keys (c.join_keys) testthat::test_that("c.join_keys joins join_keys object with join_key objects", { obj <- join_keys() From 3393eda780fa965a9bda823670005dc76abf3a19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 14:10:10 +0100 Subject: [PATCH 118/152] remove clause in favor of unique --- R/join_keys.R | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index c0504f6b1..bca055f1b 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -268,7 +268,7 @@ c.join_key_set <- function(...) { # When retrieving a relationship pair, it will also return the symmetric key new_jk <- new_join_keys() - queue <- i + queue <- unique(i) bin <- character(0) # Need to iterate on a mutating queue if subset of a dataset will also @@ -277,10 +277,6 @@ c.join_key_set <- function(...) { while (length(queue) > 0) { ix <- queue[1] queue <- queue[-1] - - if (ix %in% bin) { - next - } bin <- c(bin, ix) ix_parent <- parent(x, ix) From 3d07a077240686d944cd4b973b8a70cbe190c345 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 16:00:41 +0100 Subject: [PATCH 119/152] initial support for new getter with single bracket --- R/join_keys.R | 19 +++++++++++++++---- R/parents.R | 3 +++ man/join_keys.Rd | 4 ++-- man/update_keys_given_parents.Rd | 4 ++++ tests/testthat/test-join_keys.R | 2 +- 5 files changed, 25 insertions(+), 7 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index bca055f1b..f65c6a28a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -244,7 +244,7 @@ c.join_key_set <- function(...) { #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -`[.join_keys` <- function(x, i, keep_all_foreign_keys = FALSE) { +`[.join_keys` <- function(x, i, j, keep_all_foreign_keys = FALSE) { if (missing(i)) { return(x) } @@ -253,6 +253,10 @@ c.join_key_set <- function(...) { return(new_join_keys()) # replicate base R } + if (!missing(j)) { + return(update_keys_given_parents(x)[[i]][[j]]) + } + checkmate::assert( combine = "or", checkmate::check_integerish(i), @@ -312,8 +316,16 @@ c.join_key_set <- function(...) { #' - `[<-` is not a supported operation for `join_keys`. #' #' @export -`[<-.join_keys` <- function(x, i, value) { - stop("Can't use `[<-` for object `join_keys`. Use [[<- instead.") +`[<-.join_keys` <- function(x, i, j, value) { + if (missing(j)) { + stop("Can't use `[<-` for object `join_keys` with only i. Use [[<- instead.") + } + + checkmate::assert_string(i) + checkmate::assert_string(j) + + x[[i]][[j]] <- value + x } #' @rdname join_keys @@ -436,7 +448,6 @@ length.join_keys <- function(x) { sum(vapply(x, function(.x) length(.x) > 0, logical(1))) } - #' @rdname join_keys #' @export format.join_keys <- function(x, ...) { diff --git a/R/parents.R b/R/parents.R index b68b3a02e..5917e3830 100644 --- a/R/parents.R +++ b/R/parents.R @@ -124,6 +124,9 @@ parents.teal_data <- function(x) { #' @return (`self`) invisibly for chaining #' #' @keywords internal +#' @examples +#' update_keys_given_parents(my_keys) +#' update_keys_given_parents <- function(x) { jk <- join_keys(x) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 8e43beddc..c5d43641d 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -40,9 +40,9 @@ join_keys(x) <- value \method{c}{join_key_set}(...) -\method{[}{join_keys}(x, i, keep_all_foreign_keys = FALSE) +\method{[}{join_keys}(x, i, j, keep_all_foreign_keys = FALSE) -\method{[}{join_keys}(x, i) <- value +\method{[}{join_keys}(x, i, j) <- value \method{format}{join_keys}(x, ...) diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 9c592c2d2..e26a66a2e 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -14,5 +14,9 @@ update_keys_given_parents(x) } \description{ Updates the keys of the datasets based on the parents. +} +\examples{ +update_keys_given_parents(my_keys) + } \keyword{internal} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 5a99a1020..543fa0421 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -110,7 +110,7 @@ testthat::test_that("[[.join_keys returns keys for given pair", { join_key("b", "a", "child-parent"), join_key("c", "a", "child-parent") ) - testthat::expect_identical(my_keys[["b"]][["a"]], c(`child-parent` = "child-parent")) + testthat::expect_identical(my_keys["b", "a"], c(`child-parent` = "child-parent")) }) testthat::test_that("[[.join_keys doesn't return keys for given a pair without explicit join_key", { From 501e79d65855f273ce6ceea506b3bc0f88e46b70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 17:57:33 +0100 Subject: [PATCH 120/152] fix: update_keys_given_parents with common keys instead of primary key --- R/parents.R | 19 +++++++++++++------ man/parents.Rd | 1 + man/update_keys_given_parents.Rd | 4 ---- tests/testthat/test-join_keys.R | 24 +++++++++++++++++++++++- 4 files changed, 37 insertions(+), 11 deletions(-) diff --git a/R/parents.R b/R/parents.R index 5917e3830..cc1f1a83c 100644 --- a/R/parents.R +++ b/R/parents.R @@ -110,6 +110,7 @@ parents.teal_data <- function(x) { #' ADTTE = teal.data::rADTTE, #' ADRS = teal.data::rADRS #' ) +#' #' parents(td) <- list("ADTTE" = "ADSL") # replace existing #' parents(td)["ADRS"] <- "ADSL" # add new parent `parents<-.teal_data` <- function(x, value) { @@ -124,9 +125,6 @@ parents.teal_data <- function(x) { #' @return (`self`) invisibly for chaining #' #' @keywords internal -#' @examples -#' update_keys_given_parents(my_keys) -#' update_keys_given_parents <- function(x) { jk <- join_keys(x) @@ -136,7 +134,7 @@ update_keys_given_parents <- function(x) { duplicate_pairs <- list() for (d1 in datanames) { d1_pk <- jk[[d1]][[d1]] - d1_parent <- parents(jk)[[d1]] + d1_parent <- parent(jk, d1) for (d2 in datanames) { if (paste(d2, d1) %in% duplicate_pairs) { next @@ -152,8 +150,17 @@ update_keys_given_parents <- function(x) { # second is parent of first -> parent keys -> second keys d2_pk } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { - # both has the same parent -> parent keys - jk[[d1_parent]][[d1_parent]] + # both has the same parent -> common keys to parent + keys_d1_parent <- sort(jk[[d1]][[d1_parent]]) + keys_d2_parent <- sort(jk[[d2]][[d2_parent]]) + + common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent) + common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent) + + structure( + names(keys_d2_parent)[common_ix_2], + names = names(keys_d1_parent)[common_ix_1] + ) } else { # cant find connection - leave empty next diff --git a/man/parents.Rd b/man/parents.Rd index 54f75cf23..89e4cf7bd 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -57,6 +57,7 @@ td <- cdisc_data( ADTTE = teal.data::rADTTE, ADRS = teal.data::rADRS ) + parents(td) <- list("ADTTE" = "ADSL") # replace existing parents(td)["ADRS"] <- "ADSL" # add new parent } diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index e26a66a2e..9c592c2d2 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -14,9 +14,5 @@ update_keys_given_parents(x) } \description{ Updates the keys of the datasets based on the parents. -} -\examples{ -update_keys_given_parents(my_keys) - } \keyword{internal} diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 543fa0421..1e603115f 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -133,7 +133,29 @@ testthat::test_that("[[.join_keys infer keys between child by shared foreign key join_key("c", "a", "child-parent") ) parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys[["b"]][["c"]], c(`child-parent` = "child-parent")) + testthat::expect_identical(my_keys["b", "c"], c(`child-parent` = "child-parent")) +}) + +testthat::test_that("[[.join_keys infer keys between child by shared foreign keys 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", c("c1" = "p1", "c3" = "p3", "c2" = "p2", "qq4" = "ww4", "g4_" = "h4_", "**" = "**")), + join_key("c", "a", c("c1" = "p1", "c2" = "p2", "c3" = "p3", "dd4" = "ww4", "f5_" = "z5_", "**" = "**")) + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + + testthat::expect_identical( + my_keys["b", "c"], + c( + "**" = "**", + "c1" = "c1", + "c2" = "c2", + "c3" = "c3", + "qq4" = "dd4" + ) + ) }) # [.join_keys ----------------------------------------------------------------- From 7fc8a12a38ae6dee97324f32f961f624c842ed3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 18:02:14 +0100 Subject: [PATCH 121/152] tests: rename tests --- tests/testthat/test-join_keys.R | 45 ++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 1e603115f..e293b27ed 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -124,7 +124,7 @@ testthat::test_that("[[.join_keys doesn't return keys for given a pair without e testthat::expect_null(my_keys[["b"]][["c"]]) }) -testthat::test_that("[[.join_keys infer keys between child by shared foreign keys to parent ", { +testthat::test_that("[[.join_keys infer keys between child by shared foreign keys to parent", { my_keys <- join_keys( join_key("a", "a", "aa"), join_key("b", "b", "bb"), @@ -136,27 +136,30 @@ testthat::test_that("[[.join_keys infer keys between child by shared foreign key testthat::expect_identical(my_keys["b", "c"], c(`child-parent` = "child-parent")) }) -testthat::test_that("[[.join_keys infer keys between child by shared foreign keys 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", c("c1" = "p1", "c3" = "p3", "c2" = "p2", "qq4" = "ww4", "g4_" = "h4_", "**" = "**")), - join_key("c", "a", c("c1" = "p1", "c2" = "p2", "c3" = "p3", "dd4" = "ww4", "f5_" = "z5_", "**" = "**")) - ) - parents(my_keys) <- list("b" = "a", "c" = "a") - - testthat::expect_identical( - my_keys["b", "c"], - c( - "**" = "**", - "c1" = "c1", - "c2" = "c2", - "c3" = "c3", - "qq4" = "dd4" +testthat::test_that( + "[[.join_keys infer keys between child by shared foreign keys to parent (not all keys have same name)", + { + my_keys <- join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc"), + join_key("b", "a", c("c1" = "p1", "c3" = "p3", "c2" = "p2", "qq4" = "ww4", "g4_" = "h4_", "**" = "**")), + join_key("c", "a", c("c1" = "p1", "c2" = "p2", "c3" = "p3", "dd4" = "ww4", "f5_" = "z5_", "**" = "**")) ) - ) -}) + parents(my_keys) <- list("b" = "a", "c" = "a") + + testthat::expect_identical( + my_keys["b", "c"], + c( + "**" = "**", + "c1" = "c1", + "c2" = "c2", + "c3" = "c3", + "qq4" = "dd4" + ) + ) + } +) # [.join_keys ----------------------------------------------------------------- testthat::test_that("[.join_keys returns join_keys object when i is missing", { From 364157c12c591d26245143c368ec880cd65dcaef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 18:16:56 +0100 Subject: [PATCH 122/152] if no common keys then skip adding foreign keys --- R/parents.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/parents.R b/R/parents.R index cc1f1a83c..d7ad1bafe 100644 --- a/R/parents.R +++ b/R/parents.R @@ -157,6 +157,11 @@ update_keys_given_parents <- function(x) { common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent) common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent) + if (all(!common_ix_1)) { + # No common keys between datasets - leave empty + next + } + structure( names(keys_d2_parent)[common_ix_2], names = names(keys_d1_parent)[common_ix_1] From a2cc7ac1af43433af6917d2ea017477ba68338c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 18:17:15 +0100 Subject: [PATCH 123/152] feat: add implicit hint on print --- R/join_keys.R | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/R/join_keys.R b/R/join_keys.R index f65c6a28a..ff750985a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -456,7 +456,7 @@ format.join_keys <- function(x, ...) { my_parents <- parents(x) names_sorted <- topological_sort(my_parents) names <- union(names_sorted, names(x)) - + x_implicit <- update_keys_given_parents(x) out <- lapply(names, function(i) { this_parent <- my_parents[[i]] out_i <- lapply(union(i, names(x[[i]])), function(j) { @@ -477,6 +477,18 @@ format.join_keys <- function(x, ...) { if (length(keys) == 0) "no primary keys" else toString(keys) ) }) + + implicit_datasets <- setdiff(names(x_implicit[[i]]), names(x[[i]])) + if (length(implicit_datasets) > 0) { + out_i <- c( + out_i, + paste0( + " --* (implicit via parent with): ", + paste(implicit_datasets, collapse = ", ") + ) + ) + } + paste(out_i, collapse = "\n") }) paste( From 02b65e92f10b5948872de83a1d7a53b202c74b0d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Thu, 16 Nov 2023 18:23:26 +0100 Subject: [PATCH 124/152] adds context on fixture --- tests/testthat/test-join_keys.R | 38 ++++++++++++++++++++++++++++++--- 1 file changed, 35 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index e293b27ed..30171c5a3 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -137,14 +137,46 @@ testthat::test_that("[[.join_keys infer keys between child by shared foreign key }) testthat::test_that( - "[[.join_keys infer keys between child by shared foreign keys to parent (not all keys have same name)", + "[[.join_keys infer keys between child by shared foreign keys to parent (key names are unique to datasets)", { my_keys <- join_keys( join_key("a", "a", "aa"), join_key("b", "b", "bb"), join_key("c", "c", "cc"), - join_key("b", "a", c("c1" = "p1", "c3" = "p3", "c2" = "p2", "qq4" = "ww4", "g4_" = "h4_", "**" = "**")), - join_key("c", "a", c("c1" = "p1", "c2" = "p2", "c3" = "p3", "dd4" = "ww4", "f5_" = "z5_", "**" = "**")) + join_key( + "b", + "a", + c( + # Unsorted vector (neither by name nor value) + # Key names shared between "b" and "c" + "c1" = "p1", + "c3" = "p3", + "c2" = "p2", + # Key names unique to "b" + "qq4" = "ww4", + # Key to "a" that is not shared + "g4_" = "h4_", + # Same key across datasets + "**" = "**" + ) + ), + join_key( + "c", + "a", + c( + # Unsorted vector (neither by name nor value) + # Key names shared between "b" and "c" + "c1" = "p1", + "c2" = "p2", + "c3" = "p3", + # Key names unique to "b" + "dd4" = "ww4", + # Key to "a" that is not shared + "f5_" = "z5_", + # Same key across datasets + "**" = "**" + ) + ) ) parents(my_keys) <- list("b" = "a", "c" = "a") From 92093a4ec6b2732fef078c374ff6710ac4cbe008 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 16 Nov 2023 21:30:21 +0100 Subject: [PATCH 125/152] remove keep_foreign_keys argument - todo how to match inferred keys --- R/join_keys.R | 33 +++++++++------ man/join_keys.Rd | 5 +-- tests/testthat/test-join_keys.R | 73 ++++----------------------------- 3 files changed, 29 insertions(+), 82 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index ff750985a..52563c9b8 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -227,8 +227,6 @@ c.join_key_set <- function(...) { #' @param i index specifying elements to extract or replace. Index should be a #' a character vector, but it can also take numeric, logical, `NULL` or missing. #' -#' @param keep_all_foreign_keys (`logical`) flag that keeps foreign keys and other -#' datasets even if they are not a parent of the selected dataset. #' #' @export #' @@ -244,7 +242,7 @@ c.join_key_set <- function(...) { #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -`[.join_keys` <- function(x, i, j, keep_all_foreign_keys = FALSE) { +`[.join_keys` <- function(x, i, j) { if (missing(i)) { return(x) } @@ -254,16 +252,30 @@ c.join_key_set <- function(...) { } if (!missing(j)) { - return(update_keys_given_parents(x)[[i]][[j]]) + checkmate::assert( + combine = "or", + checkmate::check_string(i), + checkmate::check_integerish(i, len = 1), + checkmate::check_logical(i, len = length(x)) + ) + checkmate::assert( + combine = "or", + checkmate::check_string(j), + checkmate::check_integerish(j, len = 1), + checkmate::check_logical(j, len = length(x)) + ) + + subset_x <- update_keys_given_parents(x[union(i, j)]) + return(subset_x[[i]][[j]]) } checkmate::assert( combine = "or", - checkmate::check_integerish(i), - checkmate::check_logical(i), - checkmate::check_character(i) + checkmate::check_character(i, max.len = length(x)), + checkmate::check_integerish(i, max.len = length(x)), + checkmate::check_logical(i, len = length(x)) ) - checkmate::assert_logical(keep_all_foreign_keys, len = 1) + # Convert integer/logical index to named index if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { @@ -290,9 +302,6 @@ c.join_key_set <- function(...) { } ix_valid_names <- names(x[[ix]]) %in% c(queue, bin) - if (keep_all_foreign_keys) { - ix_valid_names <- rep(TRUE, length(names(x[[ix]]))) - } new_jk[[ix]] <- x[[ix]][ix_valid_names] @@ -353,7 +362,7 @@ c.join_key_set <- function(...) { combine = "or", checkmate::check_string(i), checkmate::check_integerish(i, len = 1), - checkmate::check_logical(i, len = 1) + 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)) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index c5d43641d..85e9cd4e2 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -40,7 +40,7 @@ join_keys(x) <- value \method{c}{join_key_set}(...) -\method{[}{join_keys}(x, i, j, keep_all_foreign_keys = FALSE) +\method{[}{join_keys}(x, i, j) \method{[}{join_keys}(x, i, j) <- value @@ -62,9 +62,6 @@ a character vector, but it can also take numeric, logical, \code{NULL} or missin \item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add to \code{join_keys} list.} - -\item{keep_all_foreign_keys}{(\code{logical}) flag that keeps foreign keys and other -datasets even if they are not a parent of the selected dataset.} } \value{ \code{join_keys} object. diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 30171c5a3..6b9c9733c 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -124,16 +124,16 @@ testthat::test_that("[[.join_keys doesn't return keys for given a pair without e testthat::expect_null(my_keys[["b"]][["c"]]) }) -testthat::test_that("[[.join_keys infer keys between child by shared foreign keys to parent", { +testthat::test_that("[[.join_keys infer keys between child by equal (unordered) foreign keys 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", "child-parent"), - join_key("c", "a", "child-parent") + join_key("b", "a", sample(letters[1:5])), + join_key("c", "a", sample(letters[1:5])) ) parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], c(`child-parent` = "child-parent")) + testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) }) testthat::test_that( @@ -143,53 +143,11 @@ testthat::test_that( join_key("a", "a", "aa"), join_key("b", "b", "bb"), join_key("c", "c", "cc"), - join_key( - "b", - "a", - c( - # Unsorted vector (neither by name nor value) - # Key names shared between "b" and "c" - "c1" = "p1", - "c3" = "p3", - "c2" = "p2", - # Key names unique to "b" - "qq4" = "ww4", - # Key to "a" that is not shared - "g4_" = "h4_", - # Same key across datasets - "**" = "**" - ) - ), - join_key( - "c", - "a", - c( - # Unsorted vector (neither by name nor value) - # Key names shared between "b" and "c" - "c1" = "p1", - "c2" = "p2", - "c3" = "p3", - # Key names unique to "b" - "dd4" = "ww4", - # Key to "a" that is not shared - "f5_" = "z5_", - # Same key across datasets - "**" = "**" - ) - ) + join_key("b", "a", c(aa = "bb")), + join_key("c", "a", c(aa = "cc")) ) parents(my_keys) <- list("b" = "a", "c" = "a") - - testthat::expect_identical( - my_keys["b", "c"], - c( - "**" = "**", - "c1" = "c1", - "c2" = "c2", - "c3" = "c3", - "qq4" = "dd4" - ) - ) + testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) } ) @@ -227,23 +185,6 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given in ) }) -testthat::test_that("[.join_keys returns join_keys for given dataset including those connected with foreign keys", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ab"), - join_key("d3", "d1", "ac") - ) - testthat::expect_identical( - my_keys["d2", keep_all_foreign_keys = TRUE], - join_keys( - join_key("d2", "d2", "b"), - join_key("d2", "d1", "ab") - ) - ) -}) - testthat::test_that("[.join_keys returns join_keys object for given dataset including its parent", { my_keys <- join_keys( join_key("d1", "d1", "a"), From 491ad6139d25178fddf89ed35c41ab0ee6a19e40 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 06:57:27 +0100 Subject: [PATCH 126/152] fix --- R/join_keys.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 52563c9b8..89d6c83c4 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -265,15 +265,15 @@ c.join_key_set <- function(...) { checkmate::check_logical(j, len = length(x)) ) - subset_x <- update_keys_given_parents(x[union(i, j)]) + subset_x <- update_keys_given_parents(x)[union(i, j)] return(subset_x[[i]][[j]]) } checkmate::assert( combine = "or", - checkmate::check_character(i, max.len = length(x)), - checkmate::check_integerish(i, max.len = length(x)), - checkmate::check_logical(i, len = length(x)) + checkmate::check_character(i), + checkmate::check_integerish(i), + checkmate::check_logical(i) ) From 53d1df695246d073b544550df447e2bf7cb9b83e Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 09:28:40 +0100 Subject: [PATCH 127/152] fix test and redact --- R/join_keys.R | 28 ++++++++++++++++------------ tests/testthat/test-join_keys.R | 10 +++++----- 2 files changed, 21 insertions(+), 17 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 89d6c83c4..d1de53c7f 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,23 +1,27 @@ # Constructors ==== -#' Create a `join_keys` out of a list of `join_key_set` objects +#' Manage relationships between datasets using `join_keys` #' -#' @description `r lifecycle::badge("stable")` +#' @description +#' `join_keys()` facilitates the creation and retrieval of relationships between datasets. +#' `join_keys` class extends a list and contains keys connecting pairs of datasets. Each element +#' of the list contains keys for specific dataset. Each dataset can have a relationship with +#' itself (primary key) and with other datasets. #' -#' Note that join keys are created symmetrically, that is, if `dat1` and `dat2` -#' have a join key of `col1`, then 2 join keys are created, `dat1 → dat2` and +#' Note that `join_keys` list is symmetrical, that is, when keys are set between `dat1` and `dat2` it +#' is automatically mirrored between `dat2` and `dat1`. #' `dat2 → dat1`. The only exception is for a primary key. #' #' @details #' -#' - `join_keys()`: When called without arguments it will return an -#' empty constructor. -#' - `join_keys(x)`: When called with a single argument it will return the `join_keys` -#' object contained in `x` (if it contains a `join_keys` object). -#' - `join_keys(...)`: When called with a single or more `join_key_set` parameters it will -#' create a new object. -#' - `[[.join_keys` is the preferred getter for `join_keys` that returns the -#' relationship between pairs of datasets. It returns `NULL` if there is nor +#' - `join_keys()`: Returns an empty `join_keys` object when called without arguments. +#' - `join_keys(x)`: Returns the `join_keys` object contained in `x` (if it contains one). +#' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. +#' - `join_keys[datanames]`: Returns a subset of the `join_keys` object for given datanames, +#' including their symmetric mirror keys. +#' - `join_keys[i, j]`: Returns join keys between datasets `i` and `j`, +#' including implicit keys inferred from their relationship with a parent. +#' #' relationship. #' #' @order 1 diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 6b9c9733c..e3b7e127c 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -124,7 +124,7 @@ testthat::test_that("[[.join_keys doesn't return keys for given a pair without e testthat::expect_null(my_keys[["b"]][["c"]]) }) -testthat::test_that("[[.join_keys infer keys between child by equal (unordered) foreign keys to parent", { +testthat::test_that("[[.join_keys infer keys between children by equal (unordered) foreign keys to parent", { my_keys <- join_keys( join_key("a", "a", "aa"), join_key("b", "b", "bb"), @@ -137,14 +137,14 @@ testthat::test_that("[[.join_keys infer keys between child by equal (unordered) }) testthat::test_that( - "[[.join_keys infer keys between child by shared foreign keys to parent (key names are unique to datasets)", + "[[.join_keys infer keys between children by foreign keys to common parent. ", { my_keys <- join_keys( join_key("a", "a", "aa"), join_key("b", "b", "bb"), join_key("c", "c", "cc"), - join_key("b", "a", c(aa = "bb")), - join_key("c", "a", c(aa = "cc")) + join_key("b", "a", c(bb = "aa")), + join_key("c", "a", c(cc = "aa")) ) parents(my_keys) <- list("b" = "a", "c" = "a") testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) @@ -205,7 +205,7 @@ testthat::test_that("[.join_keys returns join_keys object for given dataset incl testthat::expect_equal(my_keys["d2"], expected) }) -testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its childs", { +testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its children", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), From a51197b8335f26ca72fff38de50c02cc0190b791 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 17 Nov 2023 08:30:49 +0000 Subject: [PATCH 128/152] [skip actions] Roxygen Man Pages Auto Update --- man/join_keys.Rd | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 85e9cd4e2..3a8669f45 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -16,7 +16,7 @@ \alias{[<-.join_keys} \alias{format.join_keys} \alias{print.join_keys} -\title{Create a \code{join_keys} out of a list of \code{join_key_set} objects} +\title{Manage relationships between datasets using \code{join_keys}} \usage{ join_keys(...) @@ -67,25 +67,28 @@ to \code{join_keys} list.} \code{join_keys} object. } \description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} +\code{join_keys()} facilitates the creation and retrieval of relationships between datasets. +\code{join_keys} class extends a list and contains keys connecting pairs of datasets. Each element +of the list contains keys for specific dataset. Each dataset can have a relationship with +itself (primary key) and with other datasets. -Note that join keys are created symmetrically, that is, if \code{dat1} and \code{dat2} -have a join key of \code{col1}, then 2 join keys are created, \verb{dat1 → dat2} and +Note that \code{join_keys} list is symmetrical, that is, when keys are set between \code{dat1} and \code{dat2} it +is automatically mirrored between \code{dat2} and \code{dat1}. \verb{dat2 → dat1}. The only exception is for a primary key. } \details{ \itemize{ -\item \code{join_keys()}: When called without arguments it will return an -empty constructor. -\item \code{join_keys(x)}: When called with a single argument it will return the \code{join_keys} -object contained in \code{x} (if it contains a \code{join_keys} object). -\item \code{join_keys(...)}: When called with a single or more \code{join_key_set} parameters it will -create a new object. -\item \verb{[[.join_keys} is the preferred getter for \code{join_keys} that returns the -relationship between pairs of datasets. It returns \code{NULL} if there is nor -relationship. +\item \code{join_keys()}: Returns an empty \code{join_keys} object when called without arguments. +\item \code{join_keys(x)}: Returns the \code{join_keys} object contained in \code{x} (if it contains one). +\item \code{join_keys(...)}: Creates a new object with one or more \code{join_key_set} parameters. +\item \code{join_keys[datanames]}: Returns a subset of the \code{join_keys} object for given datanames, +including their symmetric mirror keys. +\item \code{join_keys[i, j]}: Returns join keys between datasets \code{i} and \code{j}, +including implicit keys inferred from their relationship with a parent. } +relationship. + \itemize{ \item \verb{[[<-} is the preferred method to replace or assign new relationship pair to an existing \code{join_keys} object. From 0948118e618d3c6a984bc6a924a0faa4a7a6cdfa Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 09:49:58 +0100 Subject: [PATCH 129/152] split files --- R/cdisc_join_keys.R | 2 +- R/join_keys-c.R | 25 ++ R/join_keys-extract.R | 107 ++++++++ R/{parents.R => join_keys-parents.R} | 63 ----- R/join_keys-print.R | 61 +++++ R/join_keys-utils.R | 171 +++++++++++++ R/join_keys.R | 361 +++------------------------ man/assert_compatible_keys.Rd | 2 +- man/assert_parent_child.Rd | 2 +- man/join_keys.Rd | 129 +++++----- man/length.join_keys.Rd | 2 +- man/parent.Rd | 2 +- man/parents.Rd | 2 +- man/update_keys_given_parents.Rd | 2 +- 14 files changed, 470 insertions(+), 461 deletions(-) create mode 100644 R/join_keys-c.R create mode 100644 R/join_keys-extract.R rename R/{parents.R => join_keys-parents.R} (59%) create mode 100644 R/join_keys-print.R create mode 100644 R/join_keys-utils.R diff --git a/R/cdisc_join_keys.R b/R/cdisc_join_keys.R index 30ad35457..8ccd11cfe 100644 --- a/R/cdisc_join_keys.R +++ b/R/cdisc_join_keys.R @@ -16,7 +16,7 @@ NULL build_cdisc_join_keys <- function(default_cdisc_keys) { checkmate::assert_list(default_cdisc_keys, types = "list") - jk <- new_join_keys() + jk <- join_keys() for (name in names(default_cdisc_keys)) { # Set default primary keys keys_list <- default_cdisc_keys[[name]] diff --git a/R/join_keys-c.R b/R/join_keys-c.R new file mode 100644 index 000000000..23c898e29 --- /dev/null +++ b/R/join_keys-c.R @@ -0,0 +1,25 @@ +#' @rdname join_keys +#' @export +#' +#' @examples +#' +#' # Merging multiple `join_keys` +#' +#' jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) +c.join_keys <- function(...) { + join_keys_obj <- rlang::list2(...)[[1]] + x <- rlang::list2(...)[-1] + checkmate::assert_multi_class(join_keys_obj, classes = c("join_keys", "join_key_set")) + checkmate::assert_list(x, types = c("join_keys", "join_key_set")) + + x_merged <- Reduce( + init = join_keys(), + x = x, + f = function(.x, .y) { + assert_compatible_keys2(.x, .y) + utils::modifyList(.x, .y, keep.null = FALSE) + } + ) + + utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) +} diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R new file mode 100644 index 000000000..919752df7 --- /dev/null +++ b/R/join_keys-extract.R @@ -0,0 +1,107 @@ +#' @rdname join_keys +#' +#' @details +#' - `[.join_keys` can be used to return a subset of relationship pairs. It will +#' retrieve the primary keys of the selected elements and its parents (along with) +#' the relationship keys between the selected elements and their parents. +#' +#' @param i index specifying elements to extract or replace. Index should be a +#' a character vector, but it can also take numeric, logical, `NULL` or missing. +#' +#' @param j index specifying elements to extract or replace. Index should be a +#' a character vector, but it can also take numeric, logical, `NULL` or missing. +#' +#' @export +#' +#' @examples +#' +#' # Getter for join_keys ---- +#' +#' jk <- join_keys( +#' join_key("ds1", "ds1", "primary-key-1"), +#' join_key("ds2", "ds2", "primary-key-2"), +#' join_key("ds3", "ds3", "primary-key-3"), +#' join_key("ds2", "ds1", "foreign-key-2-1"), +#' join_key("ds3", "ds1", "foregin-key-3-1") +#' ) +#' +#' jk["ds1"] +#' jk[1:2] +#' jk[c("ds1", "ds2")] +#' jk["ds1", "ds2"] +`[.join_keys` <- function(x, i, j) { + if (missing(i)) { + return(x) + } + + if (is.null(i)) { + return(join_keys()) # replicate base R + } + + if (!missing(j)) { + checkmate::assert( + combine = "or", + checkmate::check_string(i), + checkmate::check_integerish(i, len = 1), + checkmate::check_logical(i, len = length(x)) + ) + checkmate::assert( + combine = "or", + checkmate::check_string(j), + checkmate::check_integerish(j, len = 1), + checkmate::check_logical(j, len = length(x)) + ) + + subset_x <- update_keys_given_parents(x)[union(i, j)] + return(subset_x[[i]][[j]]) + } + + checkmate::assert( + combine = "or", + checkmate::check_character(i), + checkmate::check_integerish(i), + checkmate::check_logical(i) + ) + + + # Convert integer/logical index to named index + if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { + i <- names(x)[i] + } + + # When retrieving a relationship pair, it will also return the symmetric key + new_jk <- new_join_keys() + queue <- unique(i) + bin <- character(0) + + # Need to iterate on a mutating queue if subset of a dataset will also + # select its parent as that parent might have relationships with others + # already selected. + while (length(queue) > 0) { + ix <- queue[1] + queue <- queue[-1] + bin <- c(bin, ix) + + ix_parent <- parent(x, ix) + + if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) { + queue <- c(queue, ix_parent) + } + + ix_valid_names <- names(x[[ix]]) %in% c(queue, bin) + + new_jk[[ix]] <- x[[ix]][ix_valid_names] + + # Add primary key of parent + if (length(ix_parent) > 0) { + new_jk[[ix_parent]][[ix_parent]] <- x[[ix_parent]][[ix_parent]] + } + } + + common_parents_ix <- names(parents(x)) %in% names(new_jk) & + parents(x) %in% names(new_jk) + + if (any(common_parents_ix)) parents(new_jk) <- parents(x)[common_parents_ix] + + new_jk +} diff --git a/R/parents.R b/R/join_keys-parents.R similarity index 59% rename from R/parents.R rename to R/join_keys-parents.R index d7ad1bafe..927f6dec3 100644 --- a/R/parents.R +++ b/R/join_keys-parents.R @@ -117,66 +117,3 @@ parents.teal_data <- function(x) { parents(x@join_keys) <- value x } - -#' Updates the keys of the datasets based on the parents. -#' -#' @param x (`join_keys`) object to update the keys. -#' -#' @return (`self`) invisibly for chaining -#' -#' @keywords internal -update_keys_given_parents <- function(x) { - jk <- join_keys(x) - - checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(x)) - - datanames <- names(jk) - duplicate_pairs <- list() - for (d1 in datanames) { - d1_pk <- jk[[d1]][[d1]] - d1_parent <- parent(jk, d1) - for (d2 in datanames) { - if (paste(d2, d1) %in% duplicate_pairs) { - next - } - if (length(jk[[d1]][[d2]]) == 0) { - d2_parent <- parent(jk, d2) - d2_pk <- jk[[d2]][[d2]] - - fk <- if (identical(d1, d2_parent)) { - # first is parent of second -> parent keys -> first keys - d1_pk - } else if (identical(d1_parent, d2)) { - # second is parent of first -> parent keys -> second keys - d2_pk - } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { - # both has the same parent -> common keys to parent - keys_d1_parent <- sort(jk[[d1]][[d1_parent]]) - keys_d2_parent <- sort(jk[[d2]][[d2_parent]]) - - common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent) - common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent) - - if (all(!common_ix_1)) { - # No common keys between datasets - leave empty - next - } - - structure( - names(keys_d2_parent)[common_ix_2], - names = names(keys_d1_parent)[common_ix_1] - ) - } else { - # cant find connection - leave empty - next - } - jk[[d1]][[d2]] <- fk # mutate join key - duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) - } - } - } - # check parent child relation - assert_parent_child(x = jk) - - jk -} diff --git a/R/join_keys-print.R b/R/join_keys-print.R new file mode 100644 index 000000000..69e7f0c6a --- /dev/null +++ b/R/join_keys-print.R @@ -0,0 +1,61 @@ +#' @rdname join_keys +#' @export +format.join_keys <- function(x, ...) { + check_ellipsis(...) + if (length(x) > 0) { + my_parents <- parents(x) + names_sorted <- topological_sort(my_parents) + names <- union(names_sorted, names(x)) + x_implicit <- update_keys_given_parents(x) + out <- lapply(names, function(i) { + this_parent <- my_parents[[i]] + out_i <- lapply(union(i, names(x[[i]])), function(j) { + direction <- if (identical(my_parents[[j]], i)) { + " <-- " + } else if (identical(my_parents[[i]], j)) { + " --> " + } else if (!identical(i, j)) { + " <-> " + } else { + "" + } + + keys <- x[[i]][[j]] + sprintf( + "%s%s: [%s]", + direction, j, + if (length(keys) == 0) "no primary keys" else toString(keys) + ) + }) + + implicit_datasets <- setdiff(names(x_implicit[[i]]), names(x[[i]])) + if (length(implicit_datasets) > 0) { + out_i <- c( + out_i, + paste0( + " --* (implicit via parent with): ", + paste(implicit_datasets, collapse = ", ") + ) + ) + } + + paste(out_i, collapse = "\n") + }) + paste( + c( + sprintf("A join_keys object containing foreign keys between %s datasets:", length(x)), + out + ), + collapse = "\n" + ) + } else { + "An empty join_keys object." + } +} + +#' @rdname join_keys +#' @export +print.join_keys <- function(x, ...) { + cat(format(x, ...), "\n") + invisible(x) +} diff --git a/R/join_keys-utils.R b/R/join_keys-utils.R new file mode 100644 index 000000000..90cb46f31 --- /dev/null +++ b/R/join_keys-utils.R @@ -0,0 +1,171 @@ +#' Length of `join_keys` object. +#' @inheritParams base::length +#' @export +length.join_keys <- function(x) { + if (NextMethod("length", x) == 0) { + return(0) + } + sum(vapply(x, function(.x) length(.x) > 0, logical(1))) +} + +#' Helper function to assert if two key sets contain incompatible keys +#' +#' return TRUE if compatible, throw error otherwise +#' @keywords internal +assert_compatible_keys <- function(join_key_1, join_key_2) { + stop_message <- function(dataset_1, dataset_2) { + stop( + paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2) + ) + } + + dataset_1_one <- names(join_key_1) + dataset_2_one <- names(join_key_1[[1]]) + keys_one <- join_key_1[[1]][[1]] + + dataset_1_two <- names(join_key_2) + dataset_2_two <- names(join_key_2[[1]]) + keys_two <- join_key_2[[1]][[1]] + + # if first datasets and the second datasets match and keys + # must contain the same named elements + if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) { + if (!identical(sort(keys_one), sort(keys_two))) { + stop_message(dataset_1_one, dataset_2_one) + } + } + + # if first dataset of join_key_1 matches second dataset of join_key_2 + # and the first dataset of join_key_2 must match second dataset of join_key_1 + # and keys must contain the same elements but with names and values swapped + if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) { + if ( + xor(length(keys_one) == 0, length(keys_two) == 0) || + !identical(sort(keys_one), sort(setNames(names(keys_two), keys_two))) + ) { + stop_message(dataset_1_one, dataset_2_one) + } + } + + # otherwise they are compatible + return(TRUE) +} + +#' Helper function checks the parent-child relations are valid +#' +#' @param x (`join_keys`) object to assert validity of relations +#' +#' @return `join_keys` invisibly +#' +#' @keywords internal +assert_parent_child <- function(x) { + jk <- join_keys(x) + jk_parents <- parents(jk) + + checkmate::assert_class(jk, c("join_keys", "list")) + + if (!is.null(jk_parents)) { + for (idx1 in seq_along(jk_parents)) { + name_from <- names(jk_parents)[[idx1]] + for (idx2 in seq_along(jk_parents[[idx1]])) { + name_to <- jk_parents[[idx1]][[idx2]] + keys_from <- jk[[name_from]][[name_to]] + keys_to <- jk[[name_to]][[name_from]] + if (length(keys_from) == 0 && length(keys_to) == 0) { + stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) + } + } + } + } + invisible(x) +} + +assert_compatible_keys2 <- function(x, y) { + # Helper to flatten join_keys / join_key_set + flatten_join_key_sets <- function(value) { + value <- unclass(value) + Reduce( + init = list(), + f = function(u, v, ...) { + el <- value[v][[1]] + res <- lapply(seq_along(el), function(ix) el[ix]) + names(res) <- rep(v, length(res)) + append(u, res) + }, + x = names(value) + ) + } + + x <- flatten_join_key_sets(x) + y <- flatten_join_key_sets(y) + + for (idx_1 in seq_along(x)) { + for (idx_2 in seq_along(y)) { + assert_compatible_keys(x[idx_1], y[idx_2]) + } + } + TRUE +} + +#' Updates the keys of the datasets based on the parents. +#' +#' @param x (`join_keys`) object to update the keys. +#' +#' @return (`self`) invisibly for chaining +#' +#' @keywords internal +update_keys_given_parents <- function(x) { + jk <- join_keys(x) + + checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(x)) + + datanames <- names(jk) + duplicate_pairs <- list() + for (d1 in datanames) { + d1_pk <- jk[[d1]][[d1]] + d1_parent <- parent(jk, d1) + for (d2 in datanames) { + if (paste(d2, d1) %in% duplicate_pairs) { + next + } + if (length(jk[[d1]][[d2]]) == 0) { + d2_parent <- parent(jk, d2) + d2_pk <- jk[[d2]][[d2]] + + fk <- if (identical(d1, d2_parent)) { + # first is parent of second -> parent keys -> first keys + d1_pk + } else if (identical(d1_parent, d2)) { + # second is parent of first -> parent keys -> second keys + d2_pk + } else if (identical(d1_parent, d2_parent) && length(d1_parent) > 0) { + # both has the same parent -> common keys to parent + keys_d1_parent <- sort(jk[[d1]][[d1_parent]]) + keys_d2_parent <- sort(jk[[d2]][[d2_parent]]) + + common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent) + common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent) + + if (all(!common_ix_1)) { + # No common keys between datasets - leave empty + next + } + + structure( + names(keys_d2_parent)[common_ix_2], + names = names(keys_d1_parent)[common_ix_1] + ) + } else { + # cant find connection - leave empty + next + } + jk[[d1]][[d2]] <- fk # mutate join key + duplicate_pairs <- append(duplicate_pairs, paste(d1, d2)) + } + } + } + # check parent child relation + assert_parent_child(x = jk) + + jk +} diff --git a/R/join_keys.R b/R/join_keys.R index d1de53c7f..05bad6e12 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,5 +1,3 @@ -# Constructors ==== - #' Manage relationships between datasets using `join_keys` #' #' @description @@ -10,7 +8,6 @@ #' #' Note that `join_keys` list is symmetrical, that is, when keys are set between `dat1` and `dat2` it #' is automatically mirrored between `dat2` and `dat1`. -#' `dat2 → dat1`. The only exception is for a primary key. #' #' @details #' @@ -22,7 +19,6 @@ #' - `join_keys[i, j]`: Returns join keys between datasets `i` and `j`, #' including implicit keys inferred from their relationship with a parent. #' -#' relationship. #' #' @order 1 #' @@ -40,25 +36,14 @@ #' # Setting join keys ---- #' #' jk <- join_keys( -#' join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), -#' join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) +#' join_key("ds1", "ds1", "pk1"), +#' join_key("ds2", "ds2", "pk2"), +#' join_key("ds3", "ds3", "pk3"), +#' join_key("ds2", "ds1", c(pk2 = "pk1")), +#' join_key("ds3", "ds1", c(pk3 = "pk1")) #' ) -#' jk #' -#' # or -#' jk <- join_keys() -#' jk[["dataset_A"]][["dataset_B"]] <- c("col_1" = "col_a") -#' jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") #' jk -#' -#' # Retrieving a key for relationship pair -#' -#' jk[["dataset_A"]][["dataset_B"]] -#' -#' # Using a teal_data (which contains a join_keys object) -#' -#' td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) -#' join_keys(td) join_keys <- function(...) { if (missing(...)) { return(new_join_keys()) @@ -71,6 +56,12 @@ join_keys <- function(...) { } } +#' @rdname join_keys +#' @export +join_keys.default <- function(...) { + c(new_join_keys(), ...) +} + #' @rdname join_keys #' @export join_keys.join_keys <- function(...) { @@ -79,7 +70,20 @@ join_keys.join_keys <- function(...) { } #' @rdname join_keys +#' @order 1000 #' @export +#' @examples +#' # Using a `join_keys` with `teal_data` +#' +#' td <- teal_data() +#' join_keys(td) <- join_keys( +#' join_key("ds1", "ds1", "pk1"), +#' join_key("ds2", "ds2", "pk2"), +#' join_key("ds3", "ds3", "pk3"), +#' join_key("ds2", "ds1", c(pk2 = "pk1")), +#' join_key("ds3", "ds1", c(pk3 = "pk1")) +#' ) +#' join_keys(td) join_keys.teal_data <- function(...) { x <- rlang::list2(...) x[[1]]@join_keys @@ -92,11 +96,6 @@ join_keys.TealData <- function(...) { x[[1]]$get_join_keys() } -#' @rdname join_keys -#' @export -join_keys.default <- function(...) { - c(new_join_keys(), ...) -} #' @rdname join_keys #' @@ -119,9 +118,12 @@ join_keys.default <- function(...) { #' @examples #' #' # Using the setter (assignment) ---- -#' -#' join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" -#' jk +#' jk <- join_keys() +#' jk["ds1", "ds1"] <- "pk1" +#' jk["ds2", "ds2"] <- "pk2" +#' jk["ds3", "ds3"] <- "pk3" +#' jk["ds2", "ds1"] <- c(pk2 = "pk1") +#' jk["ds3", "ds1"] <- c(pk3 = "pk1") `join_keys<-.join_keys` <- function(x, value) { value } @@ -133,8 +135,7 @@ join_keys.default <- function(...) { #' # Setter for join_keys within teal_data ---- #' #' td <- teal_data() -#' join_keys(td)[["ds1"]][["ds2"]] <- "key1" -#' join_keys(td)[["ds2"]][["ds2"]] <- "key2" +#' join_keys(td)["ds1", "ds2"] <- "key1" #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) #' join_keys(td) `join_keys<-.teal_data` <- function(x, value) { @@ -142,31 +143,7 @@ join_keys.default <- function(...) { x } -#' @rdname join_keys -#' @export -#' -#' @examples -#' -#' # Merging multiple `join_keys` -#' -#' jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) -c.join_keys <- function(...) { - join_keys_obj <- rlang::list2(...)[[1]] - x <- rlang::list2(...)[-1] - checkmate::assert_multi_class(join_keys_obj, classes = c("join_keys", "join_key_set")) - checkmate::assert_list(x, types = c("join_keys", "join_key_set")) - - x_merged <- Reduce( - init = join_keys(), - x = x, - f = function(.x, .y) { - assert_compatible_keys2(.x, .y) - utils::modifyList(.x, .y, keep.null = FALSE) - } - ) - utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) -} #' @rdname join_keys #' @export @@ -221,107 +198,7 @@ c.join_key_set <- function(...) { new_x } -#' @rdname join_keys -#' -#' @details -#' - `[.join_keys` can be used to return a subset of relationship pairs. It will -#' retrieve the primary keys of the selected elements and its parents (along with) -#' the relationship keys between the selected elements and their parents. -#' -#' @param i index specifying elements to extract or replace. Index should be a -#' a character vector, but it can also take numeric, logical, `NULL` or missing. -#' -#' -#' @export -#' -#' @examples -#' -#' # Getter for join_keys ---- -#' -#' jk <- join_keys( -#' join_key("ds1", "ds2", "some_col"), -#' join_key("ds1", "ds3", "some_col2") -#' ) -#' -#' jk["ds1"] -#' jk[1:2] -#' jk[c("ds1", "ds2")] -`[.join_keys` <- function(x, i, j) { - if (missing(i)) { - return(x) - } - - if (is.null(i)) { - return(new_join_keys()) # replicate base R - } - - if (!missing(j)) { - checkmate::assert( - combine = "or", - checkmate::check_string(i), - checkmate::check_integerish(i, len = 1), - checkmate::check_logical(i, len = length(x)) - ) - checkmate::assert( - combine = "or", - checkmate::check_string(j), - checkmate::check_integerish(j, len = 1), - checkmate::check_logical(j, len = length(x)) - ) - - subset_x <- update_keys_given_parents(x)[union(i, j)] - return(subset_x[[i]][[j]]) - } - - checkmate::assert( - combine = "or", - checkmate::check_character(i), - checkmate::check_integerish(i), - checkmate::check_logical(i) - ) - - - # Convert integer/logical index to named index - if (checkmate::test_integerish(i) || checkmate::test_logical(i)) { - i <- names(x)[i] - } - # When retrieving a relationship pair, it will also return the symmetric key - new_jk <- new_join_keys() - queue <- unique(i) - bin <- character(0) - - # Need to iterate on a mutating queue if subset of a dataset will also - # select its parent as that parent might have relationships with others - # already selected. - while (length(queue) > 0) { - ix <- queue[1] - queue <- queue[-1] - bin <- c(bin, ix) - - ix_parent <- parent(x, ix) - - if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) { - queue <- c(queue, ix_parent) - } - - ix_valid_names <- names(x[[ix]]) %in% c(queue, bin) - - new_jk[[ix]] <- x[[ix]][ix_valid_names] - - # Add primary key of parent - if (length(ix_parent) > 0) { - new_jk[[ix_parent]][[ix_parent]] <- x[[ix_parent]][[ix_parent]] - } - } - - common_parents_ix <- names(parents(x)) %in% names(new_jk) & - parents(x) %in% names(new_jk) - - if (any(common_parents_ix)) parents(new_jk) <- parents(x)[common_parents_ix] - - new_jk -} #' @rdname join_keys #' @@ -451,83 +328,6 @@ c.join_key_set <- function(...) { new_x } -#' Length of `join_keys` object. -#' @inheritParams base::length -#' @export -length.join_keys <- function(x) { - if (NextMethod("length", x) == 0) { - return(0) - } - sum(vapply(x, function(.x) length(.x) > 0, logical(1))) -} - -#' @rdname join_keys -#' @export -format.join_keys <- function(x, ...) { - check_ellipsis(...) - if (length(x) > 0) { - my_parents <- parents(x) - names_sorted <- topological_sort(my_parents) - names <- union(names_sorted, names(x)) - x_implicit <- update_keys_given_parents(x) - out <- lapply(names, function(i) { - this_parent <- my_parents[[i]] - out_i <- lapply(union(i, names(x[[i]])), function(j) { - direction <- if (identical(my_parents[[j]], i)) { - " <-- " - } else if (identical(my_parents[[i]], j)) { - " --> " - } else if (!identical(i, j)) { - " <-> " - } else { - "" - } - - keys <- x[[i]][[j]] - sprintf( - "%s%s: [%s]", - direction, j, - if (length(keys) == 0) "no primary keys" else toString(keys) - ) - }) - - implicit_datasets <- setdiff(names(x_implicit[[i]]), names(x[[i]])) - if (length(implicit_datasets) > 0) { - out_i <- c( - out_i, - paste0( - " --* (implicit via parent with): ", - paste(implicit_datasets, collapse = ", ") - ) - ) - } - - paste(out_i, collapse = "\n") - }) - paste( - c( - sprintf("A join_keys object containing foreign keys between %s datasets:", length(x)), - out - ), - collapse = "\n" - ) - } else { - "An empty join_keys object." - } -} - -#' @rdname join_keys -#' @export -print.join_keys <- function(x, ...) { - cat(format(x, ...), "\n") - invisible(x) -} - -# ----------------------------------------------------------------------------- -# -# -# Helpers (non-exported) -# #' Internal constructor #' @@ -540,102 +340,3 @@ new_join_keys <- function() { class = c("join_keys", "list") ) } - -assert_compatible_keys2 <- function(x, y) { - # Helper to flatten join_keys / join_key_set - flatten_join_key_sets <- function(value) { - value <- unclass(value) - Reduce( - init = list(), - f = function(u, v, ...) { - el <- value[v][[1]] - res <- lapply(seq_along(el), function(ix) el[ix]) - names(res) <- rep(v, length(res)) - append(u, res) - }, - x = names(value) - ) - } - - x <- flatten_join_key_sets(x) - y <- flatten_join_key_sets(y) - - for (idx_1 in seq_along(x)) { - for (idx_2 in seq_along(y)) { - assert_compatible_keys(x[idx_1], y[idx_2]) - } - } - TRUE -} - -#' Helper function to assert if two key sets contain incompatible keys -#' -#' return TRUE if compatible, throw error otherwise -#' @keywords internal -assert_compatible_keys <- function(join_key_1, join_key_2) { - stop_message <- function(dataset_1, dataset_2) { - stop( - paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2) - ) - } - - dataset_1_one <- names(join_key_1) - dataset_2_one <- names(join_key_1[[1]]) - keys_one <- join_key_1[[1]][[1]] - - dataset_1_two <- names(join_key_2) - dataset_2_two <- names(join_key_2[[1]]) - keys_two <- join_key_2[[1]][[1]] - - # if first datasets and the second datasets match and keys - # must contain the same named elements - if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) { - if (!identical(sort(keys_one), sort(keys_two))) { - stop_message(dataset_1_one, dataset_2_one) - } - } - - # if first dataset of join_key_1 matches second dataset of join_key_2 - # and the first dataset of join_key_2 must match second dataset of join_key_1 - # and keys must contain the same elements but with names and values swapped - if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) { - if ( - xor(length(keys_one) == 0, length(keys_two) == 0) || - !identical(sort(keys_one), sort(setNames(names(keys_two), keys_two))) - ) { - stop_message(dataset_1_one, dataset_2_one) - } - } - - # otherwise they are compatible - return(TRUE) -} - -#' Helper function checks the parent-child relations are valid -#' -#' @param x (`join_keys`) object to assert validity of relations -#' -#' @return `join_keys` invisibly -#' -#' @keywords internal -assert_parent_child <- function(x) { - jk <- join_keys(x) - jk_parents <- parents(jk) - - checkmate::assert_class(jk, c("join_keys", "list")) - - if (!is.null(jk_parents)) { - for (idx1 in seq_along(jk_parents)) { - name_from <- names(jk_parents)[[idx1]] - for (idx2 in seq_along(jk_parents[[idx1]])) { - name_to <- jk_parents[[idx1]][[idx2]] - keys_from <- jk[[name_from]][[name_to]] - keys_to <- jk[[name_to]][[name_from]] - if (length(keys_from) == 0 && length(keys_to) == 0) { - stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to)) - } - } - } - } - invisible(x) -} diff --git a/man/assert_compatible_keys.Rd b/man/assert_compatible_keys.Rd index 2502996d2..1ede2e575 100644 --- a/man/assert_compatible_keys.Rd +++ b/man/assert_compatible_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/join_keys-utils.R \name{assert_compatible_keys} \alias{assert_compatible_keys} \title{Helper function to assert if two key sets contain incompatible keys} diff --git a/man/assert_parent_child.Rd b/man/assert_parent_child.Rd index 9b64598a0..30f24efe9 100644 --- a/man/assert_parent_child.Rd +++ b/man/assert_parent_child.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/join_keys-utils.R \name{assert_parent_child} \alias{assert_parent_child} \title{Helper function checks the parent-child relations are valid} diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 3a8669f45..08b6d7654 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -1,52 +1,53 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/join_keys.R, R/join_keys-c.R, +% R/join_keys-extract.R, R/join_keys-print.R \name{join_keys} \alias{join_keys} \alias{[[<-.join_keys} -\alias{join_keys.join_keys} \alias{join_keys.teal_data} -\alias{join_keys.TealData} +\alias{c.join_keys} +\alias{[.join_keys} +\alias{format.join_keys} +\alias{print.join_keys} \alias{join_keys.default} +\alias{join_keys.join_keys} +\alias{join_keys.TealData} \alias{join_keys<-} \alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} -\alias{c.join_keys} \alias{c.join_key_set} -\alias{[.join_keys} \alias{[<-.join_keys} -\alias{format.join_keys} -\alias{print.join_keys} \title{Manage relationships between datasets using \code{join_keys}} \usage{ join_keys(...) \method{[[}{join_keys}(x, i) <- value -\method{join_keys}{join_keys}(...) - \method{join_keys}{teal_data}(...) -\method{join_keys}{TealData}(...) +\method{c}{join_keys}(...) + +\method{[}{join_keys}(x, i, j) + +\method{format}{join_keys}(x, ...) + +\method{print}{join_keys}(x, ...) \method{join_keys}{default}(...) +\method{join_keys}{join_keys}(...) + +\method{join_keys}{TealData}(...) + join_keys(x) <- value \method{join_keys}{join_keys}(x) <- value \method{join_keys}{teal_data}(x) <- value -\method{c}{join_keys}(...) - \method{c}{join_key_set}(...) -\method{[}{join_keys}(x, i, j) - \method{[}{join_keys}(x, i, j) <- value - -\method{format}{join_keys}(x, ...) - -\method{print}{join_keys}(x, ...) } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. @@ -62,6 +63,9 @@ a character vector, but it can also take numeric, logical, \code{NULL} or missin \item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add to \code{join_keys} list.} + +\item{j}{index specifying elements to extract or replace. Index should be a +a character vector, but it can also take numeric, logical, \code{NULL} or missing.} } \value{ \code{join_keys} object. @@ -74,7 +78,6 @@ itself (primary key) and with other datasets. Note that \code{join_keys} list is symmetrical, that is, when keys are set between \code{dat1} and \code{dat2} it is automatically mirrored between \code{dat2} and \code{dat1}. -\verb{dat2 → dat1}. The only exception is for a primary key. } \details{ \itemize{ @@ -87,8 +90,6 @@ including their symmetric mirror keys. including implicit keys inferred from their relationship with a parent. } -relationship. - \itemize{ \item \verb{[[<-} is the preferred method to replace or assign new relationship pair to an existing \code{join_keys} object. @@ -97,17 +98,17 @@ pair to an \code{obj} that contains a \code{join_keys}, such as itself or a \cod object. } -\itemize{ -\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. -\code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. -} - \itemize{ \item \verb{[.join_keys} can be used to return a subset of relationship pairs. It will retrieve the primary keys of the selected elements and its parents (along with) the relationship keys between the selected elements and their parents. } +\itemize{ +\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. +\code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. +} + \itemize{ \item \verb{[<-} is not a supported operation for \code{join_keys}. } @@ -116,50 +117,67 @@ the relationship keys between the selected elements and their parents. # Setting join keys ---- jk <- join_keys( - join_key("dataset_A", "dataset_B", c("col_1" = "col_a")), - join_key("dataset_A", "dataset_C", c("col_2" = "col_x", "col_3" = "col_y")) + join_key("ds1", "ds1", "pk1"), + join_key("ds2", "ds2", "pk2"), + join_key("ds3", "ds3", "pk3"), + join_key("ds2", "ds1", c(pk2 = "pk1")), + join_key("ds3", "ds1", c(pk3 = "pk1")) ) + jk -# or jk <- join_keys() -jk[["dataset_A"]][["dataset_B"]] <- c("col_1" = "col_a") -jk[["dataset_A"]][["dataset_C"]] <- c("col_2" = "col_x", "col_3" = "col_y") +jk[["dataset_A"]][["dataset_B"]] <- "key" +jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") +jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key + jk +# Using a `join_keys` with `teal_data` -# Retrieving a key for relationship pair +td <- teal_data() +join_keys(td) <- join_keys( + join_key("ds1", "ds1", "pk1"), + join_key("ds2", "ds2", "pk2"), + join_key("ds3", "ds3", "pk3"), + join_key("ds2", "ds1", c(pk2 = "pk1")), + join_key("ds3", "ds1", c(pk3 = "pk1")) +) +join_keys(td) -jk[["dataset_A"]][["dataset_B"]] +# Merging multiple `join_keys` -# Using a teal_data (which contains a join_keys object) +jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) -td <- teal_data(join_keys = join_keys(join_key("a", "b", "c"))) -join_keys(td) +# Getter for join_keys ---- -jk <- join_keys() -jk[["dataset_A"]][["dataset_B"]] <- "key" -jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") -jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key +jk <- join_keys( + join_key("ds1", "ds1", "primary-key-1"), + join_key("ds2", "ds2", "primary-key-2"), + join_key("ds3", "ds3", "primary-key-3"), + join_key("ds2", "ds1", "foreign-key-2-1"), + join_key("ds3", "ds1", "foregin-key-3-1") +) -jk +jk["ds1"] +jk[1:2] +jk[c("ds1", "ds2")] +jk["ds1", "ds2"] # Using the setter (assignment) ---- - -join_keys(jk)[["ds1"]][["ds3"]] <- "some_col3" -jk +jk <- join_keys() +jk["ds1", "ds1"] <- "pk1" +jk["ds2", "ds2"] <- "pk2" +jk["ds3", "ds3"] <- "pk3" +jk["ds2", "ds1"] <- c(pk2 = "pk1") +jk["ds3", "ds1"] <- c(pk3 = "pk1") # Setter for join_keys within teal_data ---- td <- teal_data() -join_keys(td)[["ds1"]][["ds2"]] <- "key1" -join_keys(td)[["ds2"]][["ds2"]] <- "key2" +join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) -# Merging multiple `join_keys` - -jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) - # Note that you can merge join_keys or a single join_key_set jk_merged <- c( @@ -167,15 +185,4 @@ jk_merged <- c( join_key("dataset_A", "dataset_F", "col_a"), join_key("dataset_O", "dataset_G", "col_g") ) - -# Getter for join_keys ---- - -jk <- join_keys( - join_key("ds1", "ds2", "some_col"), - join_key("ds1", "ds3", "some_col2") -) - -jk["ds1"] -jk[1:2] -jk[c("ds1", "ds2")] } diff --git a/man/length.join_keys.Rd b/man/length.join_keys.Rd index 80cbbe1cc..faded460e 100644 --- a/man/length.join_keys.Rd +++ b/man/length.join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/join_keys-utils.R \name{length.join_keys} \alias{length.join_keys} \title{Length of \code{join_keys} object.} diff --git a/man/parent.Rd b/man/parent.Rd index a86e3a23f..a57663cb3 100644 --- a/man/parent.Rd +++ b/man/parent.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/parents.R +% Please edit documentation in R/join_keys-parents.R \name{parent} \alias{parent} \title{Getter and setter for specific parent} diff --git a/man/parents.Rd b/man/parents.Rd index 89e4cf7bd..2bbaa0f3b 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/parents.R +% Please edit documentation in R/join_keys-parents.R \name{parents} \alias{parents} \alias{parents.join_keys} diff --git a/man/update_keys_given_parents.Rd b/man/update_keys_given_parents.Rd index 9c592c2d2..704a4b548 100644 --- a/man/update_keys_given_parents.Rd +++ b/man/update_keys_given_parents.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/parents.R +% Please edit documentation in R/join_keys-utils.R \name{update_keys_given_parents} \alias{update_keys_given_parents} \title{Updates the keys of the datasets based on the parents.} From ee47d5ddd2db5f0ffd808d4a558c8c9c41e3f579 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 10:09:53 +0100 Subject: [PATCH 130/152] split followup --- R/join_keys-c.R | 16 + R/join_keys-names.R | 36 ++ R/join_keys.R | 56 -- tests/testthat/test-join_keys-c.R | 98 ++++ tests/testthat/test-join_keys-extract.R | 306 +++++++++++ tests/testthat/test-join_keys-names.R | 41 ++ ...est-parents.R => test-join_keys-parents.R} | 0 tests/testthat/test-join_keys-print.R | 54 ++ tests/testthat/test-join_keys.R | 505 ------------------ 9 files changed, 551 insertions(+), 561 deletions(-) create mode 100644 R/join_keys-names.R create mode 100644 tests/testthat/test-join_keys-c.R create mode 100644 tests/testthat/test-join_keys-extract.R create mode 100644 tests/testthat/test-join_keys-names.R rename tests/testthat/{test-parents.R => test-join_keys-parents.R} (100%) create mode 100644 tests/testthat/test-join_keys-print.R diff --git a/R/join_keys-c.R b/R/join_keys-c.R index 23c898e29..8f7224b4e 100644 --- a/R/join_keys-c.R +++ b/R/join_keys-c.R @@ -23,3 +23,19 @@ c.join_keys <- function(...) { utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) } + +#' @rdname join_keys +#' @export +#' +#' @examples +#' +#' # Note that you can merge join_keys or a single join_key_set +#' +#' jk_merged <- c( +#' jk_merged, +#' join_key("dataset_A", "dataset_F", "col_a"), +#' join_key("dataset_O", "dataset_G", "col_g") +#' ) +c.join_key_set <- function(...) { + c.join_keys(...) +} diff --git a/R/join_keys-names.R b/R/join_keys-names.R new file mode 100644 index 000000000..6503a5d5c --- /dev/null +++ b/R/join_keys-names.R @@ -0,0 +1,36 @@ +#' The Names of an `join_keys` Object +#' @inheritParams base::`names<-` +#' @export +`names<-.join_keys` <- function(x, value) { + new_x <- unclass(x) + parent_list <- parents(x) + # Update inner keys + for (old_name in setdiff(names(new_x), value)) { + old_entry <- new_x[[old_name]] + new_name <- value[names(new_x) == old_name] + + # Change 2nd-tier first + for (sub_name in names(old_entry)) { + names(new_x[[sub_name]])[names(new_x[[sub_name]]) == old_name] <- new_name + } + + # Change in first tier + names(new_x)[names(new_x) == old_name] <- new_name + + # 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 + } + }) + attr(new_x, "__parents__") <- parent_list + } + } + + class(new_x) <- c("join_keys", "list") + new_x +} diff --git a/R/join_keys.R b/R/join_keys.R index 05bad6e12..977d31899 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -144,62 +144,6 @@ join_keys.TealData <- function(...) { } - -#' @rdname join_keys -#' @export -#' -#' @examples -#' -#' # Note that you can merge join_keys or a single join_key_set -#' -#' jk_merged <- c( -#' jk_merged, -#' join_key("dataset_A", "dataset_F", "col_a"), -#' join_key("dataset_O", "dataset_G", "col_g") -#' ) -c.join_key_set <- function(...) { - c.join_keys(...) -} - -#' The Names of an `join_keys` Object -#' @inheritParams base::`names<-` -#' @export -`names<-.join_keys` <- function(x, value) { - new_x <- unclass(x) - parent_list <- parents(x) - # Update inner keys - for (old_name in setdiff(names(new_x), value)) { - old_entry <- new_x[[old_name]] - new_name <- value[names(new_x) == old_name] - - # Change 2nd-tier first - for (sub_name in names(old_entry)) { - names(new_x[[sub_name]])[names(new_x[[sub_name]]) == old_name] <- new_name - } - - # Change in first tier - names(new_x)[names(new_x) == old_name] <- new_name - - # 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 - } - }) - attr(new_x, "__parents__") <- parent_list - } - } - - class(new_x) <- c("join_keys", "list") - new_x -} - - - #' @rdname join_keys #' #' @details diff --git a/tests/testthat/test-join_keys-c.R b/tests/testthat/test-join_keys-c.R new file mode 100644 index 000000000..846be3fce --- /dev/null +++ b/tests/testthat/test-join_keys-c.R @@ -0,0 +1,98 @@ +testthat::test_that("c.join_keys joins join_keys object with join_key objects", { + obj <- join_keys() + obj <- c(obj, join_key("a", "a", "aa"), join_key("b", "b", "bb")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) + ) +}) + +testthat::test_that("c.join_keys duplicated keys are ignored", { + obj <- join_keys() + obj <- c(obj, join_key("a", "a", "aa"), join_key("a", "a", "aa")) + testthat::expect_identical( + obj, + join_keys(join_key("a", "a", "aa")) + ) +}) + +testthat::test_that("c.join_keys joins join_keys object with join_keys objects", { + obj <- join_keys() + obj <- c( + obj, + join_keys(join_key("a", "a", "aa")), + join_keys(join_key("b", "b", "bb")) + ) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) + ) +}) + +testthat::test_that("c.join_keys joins join_keys object with join_keys and join_key objects", { + obj <- join_keys() + obj <- c( + obj, + join_keys(join_key("a", "a", "aa")), + join_key("b", "b", "bb") + ) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb") + ) + ) +}) + +testthat::test_that("c.join_keys throws when joining with a list", { + obj <- join_keys() + testthat::expect_error(c( + obj, + list(c = list(c = "cc")) + )) +}) + +testthat::test_that("c.join_keys doesn't throw when second object is empty join_keys", { + x <- join_keys(join_key("a", "a", "aa")) + y <- join_keys() + testthat::expect_no_error(c(x, y)) +}) + +testthat::test_that("c.join_keys throws on conflicting join_keys_set objects", { + obj <- join_keys() + testthat::expect_error( + c( + obj, + join_keys(join_key("a", "b", "aa")), + join_keys(join_key("b", "a", "bb")) + ), + "cannot specify multiple different join keys between datasets" + ) + + testthat::expect_error( + c( + obj, + join_key("a", "b", "aa"), + join_key("b", "a", "bb") + ), + "cannot specify multiple different join keys between datasets" + ) +}) + +testthat::test_that("c.join_key_set throws on conflicting join_keys_set objects", { + testthat::expect_error( + c( + join_key("a", "b", "aa"), + join_key("a", "b", "ca"), + join_key("a", "b", "cc") + ), + "cannot specify multiple different join keys between datasets" + ) +}) diff --git a/tests/testthat/test-join_keys-extract.R b/tests/testthat/test-join_keys-extract.R new file mode 100644 index 000000000..f44262f2b --- /dev/null +++ b/tests/testthat/test-join_keys-extract.R @@ -0,0 +1,306 @@ +# [.join_keys ----------------------------------------------------------------- +testthat::test_that("[[.join_keys returns keys for given pair", { + 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["b", "a"], c(`child-parent` = "child-parent")) +}) + +testthat::test_that("[[.join_keys doesn't return keys for given a pair without explicit join_key", { + 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_null(my_keys[["b"]][["c"]]) +}) + +testthat::test_that("[[.join_keys infer keys between children by equal (unordered) foreign keys 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])) + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) +}) + +testthat::test_that( + "[[.join_keys infer keys between children by foreign keys to common parent. ", + { + my_keys <- join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc"), + join_key("b", "a", c(bb = "aa")), + join_key("c", "a", c(cc = "aa")) + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) + } +) + +# [.join_keys ----------------------------------------------------------------- +testthat::test_that("[.join_keys returns join_keys object when i is missing", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c") + ) + testthat::expect_identical(my_keys[], my_keys) +}) + +testthat::test_that("[.join_keys returns join_keys object with keys for given datasets", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c") + ) + testthat::expect_identical( + my_keys[c("d1", "d2")], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + ) +}) + +testthat::test_that("[.join_keys returns join_keys object with 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[c(1, 2)], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + ) +}) + +testthat::test_that("[.join_keys returns join_keys object for given dataset including its parent", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ab"), + join_key("d3", "d1", "ac") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d2", "d1", "ab") + ) + parents(expected) <- list("d2" = "d1") + + testthat::expect_equal(my_keys["d2"], expected) +}) + +testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its children", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ab"), + join_key("d3", "d1", "ac") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d1") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d2", "d1", "ab") + ) + parents(expected) <- list("d2" = "d1") + + testthat::expect_equal(my_keys["d2"], expected) +}) + +testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset", { + my_keys <- join_keys(join_key("d1", "d1", "a")) + testthat::expect_length(my_keys["d2"], 0) +}) + +testthat::test_that("[.join_keys ignores duplicate indexes - return only first occurrence", { + jk <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d2", "b") + ) + testthat::expect_identical( + jk[c("d1", "d2", "d1")], + join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) + ) +}) + +# [<-.join_keys and [[<-.join_keys ------------------------------------------------ +testthat::test_that("[[<-.join_keys accepts named list where each containing character", { + jk <- join_keys() + testthat::expect_no_error( + jk[["d1"]] <- list(d1 = c("a", "b", "c"), d2 = c(b = "c", "d" = "d")) + ) +}) + +testthat::test_that("[[<-.join_keys accepts integerish as index", { + jk <- join_keys(join_key("a", "a", "aa")) + testthat::expect_no_error( + jk[[1]][[1]] <- "bb" + ) +}) + +testthat::test_that("[[<-.join_keys accepts unnamed vector", { + jk <- join_keys() + testthat::expect_no_error( + jk[["d1"]] <- list(d1 = c("a", "b", "c")) + ) +}) + +testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { + jk <- join_keys() + testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) +}) + +testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { + jk <- join_keys() + testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) + testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) + testthat::expect_error(jk[["d1"]] <- "test") +}) + +testthat::test_that("[[<-.join_keys adds join_keys specified as named list to the list of keys", { + jk <- join_keys() + jk[["d1"]] <- list(d1 = "a") + testthat::expect_identical(jk, join_keys(join_key("d1", "d1", "a"))) +}) + +testthat::test_that("[[<-.join_keys assigning NULL drops a key", { + jk <- join_keys(join_key("d1", "d1", "a")) + jk[["d1"]] <- NULL + testthat::expect_null(jk[["d1"]]) +}) + +testthat::test_that("[[<-.join_keys adds symmetrical change to the foreign dataset", { + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") + + testthat::expect_identical( + jk, + join_keys( + join_key("d1", "d2", c("A" = "B", "C" = "C")), + join_key("d2", "d1", c("B" = "A", "C" = "C")) + ) + ) +}) + +testthat::test_that("[<-.join_keys throws when assigning anything", { + jk_expected <- join_keys() + testthat::expect_error(jk_expected["a"] <- join_key("a", "b", "test"), "Can't use `\\[<-`") +}) + +testthat::test_that("[[<- can mutate existing keys", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d1"]][["d2"]] <- "B" + testthat::expect_identical(my_keys, join_keys(join_key("d1", "d2", "B"))) +}) + +testthat::test_that("[[<- mutating non-existing keys adds them", { + my_keys <- join_keys(join_key("d1", "d2", "A")) + my_keys[["d2"]][["d3"]] <- "B" + testthat::expect_identical( + my_keys, + join_keys( + join_key("d1", "d2", "A"), + join_key("d2", "d3", "B") + ) + ) +}) + +testthat::test_that("[[<- setting a key to character(0) drops the key", { + my_keys <- join_keys( + join_key("d1", "d2", "A"), + join_key("d2", "d3", "B") + ) + + my_keys[["d1"]][["d2"]] <- character(0) + + testthat::expect_identical( + my_keys, + join_keys(join_key("d2", "d3", "B")) + ) +}) + +testthat::test_that("[[<-.join_keys removes keys with NULL", { + my_keys <- join_keys( + join_key("d1", "d1", "A"), + join_key("d2", "d2", "B") + ) + my_keys[["d2"]][["d2"]] <- NULL + + testthat::expect_identical( + my_keys, + join_keys( + join_key("d1", "d1", "A") + ) + ) +}) + +testthat::test_that("[[<-.join_keys removes keys with NULL and applies summetrical changes", { + my_keys <- join_keys( + join_key("d1", "d2", "A"), + join_key("d2", "d1", "A"), + join_key("d2", "d3", "B"), + join_key("d3", "d2", "B") + ) + my_keys[["d1"]][["d2"]] <- NULL + + testthat::expect_identical( + my_keys, + join_keys( + join_key("d2", "d3", "B"), + join_key("d3", "d2", "B") + ) + ) +}) + +testthat::test_that("[[<-.join_keys with empty name is changed to the key value", { + # set empty key name + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) +}) + +testthat::test_that("[[<-.join_keys with empty value is set to its name", { + jk <- join_keys() + jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "") + expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) +}) + +testthat::test_that("[[<-.join_keys passing key unnamed 'empty' value is ignored", { + # set key on empty variable name equal to "" + jk <- join_keys() + testthat::expect_message(jk[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") + testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) +}) + +testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for same datasets, but different keys", { + jk <- join_keys() + testthat::expect_error( + jk[["ds1"]] <- list(ds2 = "new", ds2 = "new_but_different"), + "cannot specify multiple different join keys between datasets" + ) +}) + +testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for same datasets and same keys", { + jk <- join_keys() + testthat::expect_silent(jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new"))) + testthat::expect_identical(jk, join_keys(join_key("ds1", "ds2", "new"))) +}) diff --git a/tests/testthat/test-join_keys-names.R b/tests/testthat/test-join_keys-names.R new file mode 100644 index 000000000..53ca3cf07 --- /dev/null +++ b/tests/testthat/test-join_keys-names.R @@ -0,0 +1,41 @@ +testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list", { + jk <- join_keys( + join_key("a", "a", "a"), + join_key("a", "b", "ab"), + join_key("a", "c", "ac"), + join_key("d", "b", "db") + ) + + names(jk)[1:2] <- c("x", "y") + + testthat::expect_identical( + jk, + join_keys( + join_key("x", "x", "a"), + join_key("x", "y", "ab"), + join_key("x", "c", "ac"), + join_key("d", "y", "db") + ) + ) +}) + +testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list when parents set", { + jk <- join_keys( + join_key("a", "a", "a"), + join_key("b", "a", "ba"), + join_key("c", "a", "ca"), + join_key("d", "b", "db") + ) + parents(jk) <- list(b = "a", c = "a", d = "b") + + expected <- join_keys( + join_key("a", "a", "a"), + join_key("B", "a", "ba"), + join_key("c", "a", "ca"), + join_key("d", "B", "db") + ) + parents(expected) <- list(B = "a", c = "a", d = "B") + + names(jk)[2] <- "B" + testthat::expect_identical(jk, expected) +}) diff --git a/tests/testthat/test-parents.R b/tests/testthat/test-join_keys-parents.R similarity index 100% rename from tests/testthat/test-parents.R rename to tests/testthat/test-join_keys-parents.R diff --git a/tests/testthat/test-join_keys-print.R b/tests/testthat/test-join_keys-print.R new file mode 100644 index 000000000..973dacc76 --- /dev/null +++ b/tests/testthat/test-join_keys-print.R @@ -0,0 +1,54 @@ +testthat::test_that("format.join_keys for empty set", { + jk <- join_keys() + testthat::expect_identical(format(jk), "An empty join_keys object.") +}) + +testthat::test_that("format.join_keys with empty parents", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") + ) + testthat::expect_identical( + format(my_keys), + paste( + "A join_keys object containing foreign keys between 3 datasets:", + "d1: [a]", " <-> d2: [ba]", "d2: [b]", " <-> d1: [ba]", " <-> d3: [ca]", + "d3: [c]", " <-> d2: [ca]", + sep = "\n" + ) + ) +}) + +testthat::test_that("format.join_keys for parents", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") + ) + parents(my_keys) <- list("d2" = "d1", "d3" = "d2") + testthat::expect_identical( + format(my_keys), + paste( + "A join_keys object containing foreign keys between 3 datasets:", + "d1: [a]", " <-- d2: [ba]", "d2: [b]", " --> d1: [ba]", " <-- d3: [ca]", + "d3: [c]", " --> d2: [ca]", + sep = "\n" + ) + ) +}) + +testthat::test_that("print.join_keys produces output same as format", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d2", "d1", "ba"), + join_key("d3", "d2", "ca") + ) + testthat::expect_output(print(my_keys), format(my_keys), fixed = TRUE) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index e3b7e127c..92f7ec729 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -101,146 +101,8 @@ testthat::test_that("join_keys constructor adds symmetric keys on given (named) ) ) }) -# [.join_keys ----------------------------------------------------------------- -testthat::test_that("[[.join_keys returns keys for given pair", { - 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["b", "a"], c(`child-parent` = "child-parent")) -}) - -testthat::test_that("[[.join_keys doesn't return keys for given a pair without explicit join_key", { - 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_null(my_keys[["b"]][["c"]]) -}) - -testthat::test_that("[[.join_keys infer keys between children by equal (unordered) foreign keys 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])) - ) - parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) -}) -testthat::test_that( - "[[.join_keys infer keys between children by foreign keys to common parent. ", - { - my_keys <- join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb"), - join_key("c", "c", "cc"), - join_key("b", "a", c(bb = "aa")), - join_key("c", "a", c(cc = "aa")) - ) - parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) - } -) -# [.join_keys ----------------------------------------------------------------- -testthat::test_that("[.join_keys returns join_keys object when i is missing", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c") - ) - testthat::expect_identical(my_keys[], my_keys) -}) - -testthat::test_that("[.join_keys returns join_keys object with keys for given datasets", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c") - ) - testthat::expect_identical( - my_keys[c("d1", "d2")], - join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) - ) -}) - -testthat::test_that("[.join_keys returns join_keys object with 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[c(1, 2)], - join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) - ) -}) - -testthat::test_that("[.join_keys returns join_keys object for given dataset including its parent", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ab"), - join_key("d3", "d1", "ac") - ) - parents(my_keys) <- list("d2" = "d1", "d3" = "d1") - - expected <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d2", "d1", "ab") - ) - parents(expected) <- list("d2" = "d1") - - testthat::expect_equal(my_keys["d2"], expected) -}) - -testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its children", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ab"), - join_key("d3", "d1", "ac") - ) - parents(my_keys) <- list("d2" = "d1", "d3" = "d1") - - expected <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d2", "d1", "ab") - ) - parents(expected) <- list("d2" = "d1") - - testthat::expect_equal(my_keys["d2"], expected) -}) - -testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset", { - my_keys <- join_keys(join_key("d1", "d1", "a")) - testthat::expect_length(my_keys["d2"], 0) -}) - -testthat::test_that("[.join_keys ignores duplicate indexes - return only first occurrence", { - jk <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d2", "b") - ) - testthat::expect_identical( - jk[c("d1", "d2", "d1")], - join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) - ) -}) # join_keys.<- ---------------------------------------------------------------- testthat::test_that("join_keys<-.join_keys overwrites existing join_keys", { @@ -289,376 +151,9 @@ testthat::test_that("join_keys()[]<-.join_keys with empty value in a named vecto testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) }) -# [<-.join_keys and [[<-.join_keys ------------------------------------------------ -testthat::test_that("[[<-.join_keys accepts named list where each containing character", { - jk <- join_keys() - testthat::expect_no_error( - jk[["d1"]] <- list(d1 = c("a", "b", "c"), d2 = c(b = "c", "d" = "d")) - ) -}) - -testthat::test_that("[[<-.join_keys accepts integerish as index", { - jk <- join_keys(join_key("a", "a", "aa")) - testthat::expect_no_error( - jk[[1]][[1]] <- "bb" - ) -}) - -testthat::test_that("[[<-.join_keys accepts unnamed vector", { - jk <- join_keys() - testthat::expect_no_error( - jk[["d1"]] <- list(d1 = c("a", "b", "c")) - ) -}) - -testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { - jk <- join_keys() - testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) - testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) - testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) -}) - -testthat::test_that("[[<-.join_keys doesn't accepts other list than named containing character", { - jk <- join_keys() - testthat::expect_error(jk[["d1"]] <- list(d1 = 1:5, d2 = c(b = "c", "d" = "d"))) - testthat::expect_error(jk[["d1"]] <- list(d1 = list(a = "a"))) - testthat::expect_error(jk[["d1"]] <- list(d1 = NULL)) - testthat::expect_error(jk[["d1"]] <- "test") -}) - -testthat::test_that("[[<-.join_keys adds join_keys specified as named list to the list of keys", { - jk <- join_keys() - jk[["d1"]] <- list(d1 = "a") - testthat::expect_identical(jk, join_keys(join_key("d1", "d1", "a"))) -}) - -testthat::test_that("[[<-.join_keys assigning NULL drops a key", { - jk <- join_keys(join_key("d1", "d1", "a")) - jk[["d1"]] <- NULL - testthat::expect_null(jk[["d1"]]) -}) - -testthat::test_that("[[<-.join_keys adds symmetrical change to the foreign dataset", { - jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - - testthat::expect_identical( - jk, - join_keys( - join_key("d1", "d2", c("A" = "B", "C" = "C")), - join_key("d2", "d1", c("B" = "A", "C" = "C")) - ) - ) -}) - -testthat::test_that("[<-.join_keys throws when assigning anything", { - jk_expected <- join_keys() - testthat::expect_error(jk_expected["a"] <- join_key("a", "b", "test"), "Can't use `\\[<-`") -}) - -testthat::test_that("[[<- can mutate existing keys", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys[["d1"]][["d2"]] <- "B" - testthat::expect_identical(my_keys, join_keys(join_key("d1", "d2", "B"))) -}) - -testthat::test_that("[[<- mutating non-existing keys adds them", { - my_keys <- join_keys(join_key("d1", "d2", "A")) - my_keys[["d2"]][["d3"]] <- "B" - testthat::expect_identical( - my_keys, - join_keys( - join_key("d1", "d2", "A"), - join_key("d2", "d3", "B") - ) - ) -}) - -testthat::test_that("[[<- setting a key to character(0) drops the key", { - my_keys <- join_keys( - join_key("d1", "d2", "A"), - join_key("d2", "d3", "B") - ) - - my_keys[["d1"]][["d2"]] <- character(0) - - testthat::expect_identical( - my_keys, - join_keys(join_key("d2", "d3", "B")) - ) -}) - -testthat::test_that("[[<-.join_keys removes keys with NULL", { - my_keys <- join_keys( - join_key("d1", "d1", "A"), - join_key("d2", "d2", "B") - ) - my_keys[["d2"]][["d2"]] <- NULL - - testthat::expect_identical( - my_keys, - join_keys( - join_key("d1", "d1", "A") - ) - ) -}) - -testthat::test_that("[[<-.join_keys removes keys with NULL and applies summetrical changes", { - my_keys <- join_keys( - join_key("d1", "d2", "A"), - join_key("d2", "d1", "A"), - join_key("d2", "d3", "B"), - join_key("d3", "d2", "B") - ) - my_keys[["d1"]][["d2"]] <- NULL - - testthat::expect_identical( - my_keys, - join_keys( - join_key("d2", "d3", "B"), - join_key("d3", "d2", "B") - ) - ) -}) - -testthat::test_that("[[<-.join_keys with empty name is changed to the key value", { - # set empty key name - jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) -}) - -testthat::test_that("[[<-.join_keys with empty value is set to its name", { - jk <- join_keys() - jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "") - expect_equal(jk[["d1"]][["d2"]], setNames(c("B", "C"), c("A", "C"))) -}) - -testthat::test_that("[[<-.join_keys passing key unnamed 'empty' value is ignored", { - # set key on empty variable name equal to "" - jk <- join_keys() - testthat::expect_message(jk[["d1"]][["d2"]] <- c("A" = "B", ""), "are ignored") - testthat::expect_equal(jk[["d1"]][["d2"]], c(A = "B")) -}) - -testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for same datasets, but different keys", { - jk <- join_keys() - testthat::expect_error( - jk[["ds1"]] <- list(ds2 = "new", ds2 = "new_but_different"), - "cannot specify multiple different join keys between datasets" - ) -}) -testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for same datasets and same keys", { - jk <- join_keys() - testthat::expect_silent(jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new"))) - testthat::expect_identical(jk, join_keys(join_key("ds1", "ds2", "new"))) -}) # ----------------------------------------------------------------------------- # # Setting names (names<-join_keys) # -testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list", { - jk <- join_keys( - join_key("a", "a", "a"), - join_key("a", "b", "ab"), - join_key("a", "c", "ac"), - join_key("d", "b", "db") - ) - - names(jk)[1:2] <- c("x", "y") - - testthat::expect_identical( - jk, - join_keys( - join_key("x", "x", "a"), - join_key("x", "y", "ab"), - join_key("x", "c", "ac"), - join_key("d", "y", "db") - ) - ) -}) - -testthat::test_that("names<-.join_keys will replace names at all levels of the join_keys list when parents set", { - jk <- join_keys( - join_key("a", "a", "a"), - join_key("b", "a", "ba"), - join_key("c", "a", "ca"), - join_key("d", "b", "db") - ) - parents(jk) <- list(b = "a", c = "a", d = "b") - - expected <- join_keys( - join_key("a", "a", "a"), - join_key("B", "a", "ba"), - join_key("c", "a", "ca"), - join_key("d", "B", "db") - ) - parents(expected) <- list(B = "a", c = "a", d = "B") - - names(jk)[2] <- "B" - testthat::expect_identical(jk, expected) -}) - -# ----------------------------------------------------------------------------- -# -# Merging join_keys (c.join_keys) - -testthat::test_that("c.join_keys joins join_keys object with join_key objects", { - obj <- join_keys() - obj <- c(obj, join_key("a", "a", "aa"), join_key("b", "b", "bb")) - testthat::expect_identical( - obj, - join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb") - ) - ) -}) - -testthat::test_that("c.join_keys duplicated keys are ignored", { - obj <- join_keys() - obj <- c(obj, join_key("a", "a", "aa"), join_key("a", "a", "aa")) - testthat::expect_identical( - obj, - join_keys(join_key("a", "a", "aa")) - ) -}) - -testthat::test_that("c.join_keys joins join_keys object with join_keys objects", { - obj <- join_keys() - obj <- c( - obj, - join_keys(join_key("a", "a", "aa")), - join_keys(join_key("b", "b", "bb")) - ) - testthat::expect_identical( - obj, - join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb") - ) - ) -}) - -testthat::test_that("c.join_keys joins join_keys object with join_keys and join_key objects", { - obj <- join_keys() - obj <- c( - obj, - join_keys(join_key("a", "a", "aa")), - join_key("b", "b", "bb") - ) - testthat::expect_identical( - obj, - join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb") - ) - ) -}) - -testthat::test_that("c.join_keys throws when joining with a list", { - obj <- join_keys() - testthat::expect_error(c( - obj, - list(c = list(c = "cc")) - )) -}) - -testthat::test_that("c.join_keys doesn't throw when second object is empty join_keys", { - x <- join_keys(join_key("a", "a", "aa")) - y <- join_keys() - testthat::expect_no_error(c(x, y)) -}) - -testthat::test_that("c.join_keys throws on conflicting join_keys_set objects", { - obj <- join_keys() - testthat::expect_error( - c( - obj, - join_keys(join_key("a", "b", "aa")), - join_keys(join_key("b", "a", "bb")) - ), - "cannot specify multiple different join keys between datasets" - ) - - testthat::expect_error( - c( - obj, - join_key("a", "b", "aa"), - join_key("b", "a", "bb") - ), - "cannot specify multiple different join keys between datasets" - ) -}) - -testthat::test_that("c.join_key_set throws on conflicting join_keys_set objects", { - testthat::expect_error( - c( - join_key("a", "b", "aa"), - join_key("a", "b", "ca"), - join_key("a", "b", "cc") - ), - "cannot specify multiple different join keys between datasets" - ) -}) - -# ----------------------------------------------------------------------------- -# -# print.join_keys - -testthat::test_that("format.join_keys for empty set", { - jk <- join_keys() - testthat::expect_identical(format(jk), "An empty join_keys object.") -}) - -testthat::test_that("format.join_keys with empty parents", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ba"), - join_key("d3", "d2", "ca") - ) - testthat::expect_identical( - format(my_keys), - paste( - "A join_keys object containing foreign keys between 3 datasets:", - "d1: [a]", " <-> d2: [ba]", "d2: [b]", " <-> d1: [ba]", " <-> d3: [ca]", - "d3: [c]", " <-> d2: [ca]", - sep = "\n" - ) - ) -}) - -testthat::test_that("format.join_keys for parents", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ba"), - join_key("d3", "d2", "ca") - ) - parents(my_keys) <- list("d2" = "d1", "d3" = "d2") - testthat::expect_identical( - format(my_keys), - paste( - "A join_keys object containing foreign keys between 3 datasets:", - "d1: [a]", " <-- d2: [ba]", "d2: [b]", " --> d1: [ba]", " <-- d3: [ca]", - "d3: [c]", " --> d2: [ca]", - sep = "\n" - ) - ) -}) - -testthat::test_that("print.join_keys produces output same as format", { - my_keys <- join_keys( - join_key("d1", "d1", "a"), - join_key("d2", "d2", "b"), - join_key("d3", "d3", "c"), - join_key("d2", "d1", "ba"), - join_key("d3", "d2", "ca") - ) - testthat::expect_output(print(my_keys), format(my_keys), fixed = TRUE) -}) From df16d326f423bc65662faf9d886d0a76a78b459d Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 17 Nov 2023 09:12:33 +0000 Subject: [PATCH 131/152] [skip actions] Roxygen Man Pages Auto Update --- man/join_keys.Rd | 22 +++++++++++----------- man/names-set-.join_keys.Rd | 2 +- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 08b6d7654..072d8cb98 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -6,6 +6,7 @@ \alias{[[<-.join_keys} \alias{join_keys.teal_data} \alias{c.join_keys} +\alias{c.join_key_set} \alias{[.join_keys} \alias{format.join_keys} \alias{print.join_keys} @@ -15,7 +16,6 @@ \alias{join_keys<-} \alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} -\alias{c.join_key_set} \alias{[<-.join_keys} \title{Manage relationships between datasets using \code{join_keys}} \usage{ @@ -27,6 +27,8 @@ join_keys(...) \method{c}{join_keys}(...) +\method{c}{join_key_set}(...) + \method{[}{join_keys}(x, i, j) \method{format}{join_keys}(x, ...) @@ -45,8 +47,6 @@ join_keys(x) <- value \method{join_keys}{teal_data}(x) <- value -\method{c}{join_key_set}(...) - \method{[}{join_keys}(x, i, j) <- value } \arguments{ @@ -148,6 +148,14 @@ join_keys(td) jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) +# Note that you can merge join_keys or a single join_key_set + +jk_merged <- c( + jk_merged, + join_key("dataset_A", "dataset_F", "col_a"), + join_key("dataset_O", "dataset_G", "col_g") +) + # Getter for join_keys ---- jk <- join_keys( @@ -177,12 +185,4 @@ td <- teal_data() join_keys(td)["ds1", "ds2"] <- "key1" join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) - -# Note that you can merge join_keys or a single join_key_set - -jk_merged <- c( - jk_merged, - join_key("dataset_A", "dataset_F", "col_a"), - join_key("dataset_O", "dataset_G", "col_g") -) } diff --git a/man/names-set-.join_keys.Rd b/man/names-set-.join_keys.Rd index 892694a8d..4d276845f 100644 --- a/man/names-set-.join_keys.Rd +++ b/man/names-set-.join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R +% Please edit documentation in R/join_keys-names.R \name{names<-.join_keys} \alias{names<-.join_keys} \title{The Names of an \code{join_keys} Object} From 28292a877071f87e9e6be0e0920ad3afcd6148cc Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 10:28:32 +0100 Subject: [PATCH 132/152] remove length.join_keys move [[ to join_keys-extract.R --- NAMESPACE | 1 - R/join_keys-extract.R | 128 +++++++++++++++++++++++++++++++++++++++ R/join_keys-utils.R | 10 --- R/join_keys.R | 131 ---------------------------------------- man/length.join_keys.Rd | 14 ----- 5 files changed, 128 insertions(+), 156 deletions(-) delete mode 100644 man/length.join_keys.Rd diff --git a/NAMESPACE b/NAMESPACE index 1ee9b0b06..b3c2deb23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,7 +48,6 @@ S3method(join_keys,TealData) S3method(join_keys,default) S3method(join_keys,join_keys) S3method(join_keys,teal_data) -S3method(length,join_keys) S3method(load_dataset,TealDataset) S3method(load_dataset,TealDatasetConnector) S3method(load_datasets,TealData) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index 919752df7..8f85ac473 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -105,3 +105,131 @@ new_jk } + +#' @rdname join_keys +#' +#' @details +#' - `[<-` is not a supported operation for `join_keys`. +#' +#' @export +`[<-.join_keys` <- function(x, i, j, value) { + if (missing(j)) { + stop("Can't use `[<-` for object `join_keys` with only i. Use [[<- instead.") + } + + checkmate::assert_string(i) + checkmate::assert_string(j) + + x[[i]][[j]] <- value + x +} + +#' @rdname join_keys +#' +#' @order 3 +#' +#' @details +#' - `[[<-` is the preferred method to replace or assign new relationship pair to an +#' existing `join_keys` object. +#' - `join_keys(obj)[[dataset_1]] <- value` can also be used to assign a relationship +#' pair to an `obj` that contains a `join_keys`, such as itself or a `teal_data` +#' object. +#' +#' @export +#' @examples +#' +#' jk <- join_keys() +#' jk[["dataset_A"]][["dataset_B"]] <- "key" +#' jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") +#' jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key +#' +#' jk +`[[<-.join_keys` <- function(x, i, value) { + checkmate::assert( + combine = "or", + checkmate::check_string(i), + checkmate::check_integerish(i, len = 1), + 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)) { + i <- names(x)[[i]] + } + + # Normalize values + norm_value <- lapply(seq_along(value), function(.x) { + join_key(i, names(value)[.x], value[[.x]]) + }) + names(norm_value) <- names(value) + + # Check if multiple modifications don't have a conflict + repeated_value_ix <- names(value) %in% names(value)[duplicated(names(value))] + repeated <- norm_value[repeated_value_ix] + vapply( + seq_along(repeated), + function(.ix, .x_value = repeated[[.ix]], .x_name = names(.x_value[[1]])) { + assert_compatible_keys2( + .x_value, + unlist(unname( + repeated[-.ix][names(repeated[-.ix]) == .x_name] + ), recursive = FALSE) + ) + }, + logical(1) + ) + + norm_value <- lapply(norm_value, function(x) x[[1]][[1]]) + names(norm_value) <- names(value) + + # 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) + + # 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 + } + + new_x[[i]] <- norm_value + + # Iterate on all new values to create symmetrical pair + for (ds2 in names(norm_value)) { + if (ds2 == i) next + + keep_value <- new_x[[ds2]] %||% list() + new_value <- norm_value[[ds2]] + + if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { + new_value <- setNames(new_value, new_value) + } else if (checkmate::test_character(new_value, min.len = 1)) { + # Invert key + new_value <- setNames(names(new_value), new_value) + } + + keep_value[[i]] <- new_value + + # Assign symmetrical + new_x[[ds2]] <- keep_value + } + + # Remove NULL or empty keys + empty_ix <- vapply( + new_x, + function(.x) is.null(.x) || length(.x) == 0, + logical(1) + ) + preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"] + new_x <- new_x[!empty_ix] + attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr) + + # + # restore class + class(new_x) <- class(x) + new_x +} diff --git a/R/join_keys-utils.R b/R/join_keys-utils.R index 90cb46f31..87e64bf77 100644 --- a/R/join_keys-utils.R +++ b/R/join_keys-utils.R @@ -1,13 +1,3 @@ -#' Length of `join_keys` object. -#' @inheritParams base::length -#' @export -length.join_keys <- function(x) { - if (NextMethod("length", x) == 0) { - return(0) - } - sum(vapply(x, function(.x) length(.x) > 0, logical(1))) -} - #' Helper function to assert if two key sets contain incompatible keys #' #' return TRUE if compatible, throw error otherwise diff --git a/R/join_keys.R b/R/join_keys.R index 977d31899..1c3af062c 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -96,7 +96,6 @@ join_keys.TealData <- function(...) { x[[1]]$get_join_keys() } - #' @rdname join_keys #' #' @details @@ -143,136 +142,6 @@ join_keys.TealData <- function(...) { x } - -#' @rdname join_keys -#' -#' @details -#' - `[<-` is not a supported operation for `join_keys`. -#' -#' @export -`[<-.join_keys` <- function(x, i, j, value) { - if (missing(j)) { - stop("Can't use `[<-` for object `join_keys` with only i. Use [[<- instead.") - } - - checkmate::assert_string(i) - checkmate::assert_string(j) - - x[[i]][[j]] <- value - x -} - -#' @rdname join_keys -#' -#' @order 3 -#' -#' @details -#' - `[[<-` is the preferred method to replace or assign new relationship pair to an -#' existing `join_keys` object. -#' - `join_keys(obj)[[dataset_1]] <- value` can also be used to assign a relationship -#' pair to an `obj` that contains a `join_keys`, such as itself or a `teal_data` -#' object. -#' -#' @export -#' @examples -#' -#' jk <- join_keys() -#' jk[["dataset_A"]][["dataset_B"]] <- "key" -#' jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") -#' jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key -#' -#' jk -`[[<-.join_keys` <- function(x, i, value) { - checkmate::assert( - combine = "or", - checkmate::check_string(i), - checkmate::check_integerish(i, len = 1), - 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)) { - i <- names(x)[[i]] - } - - # Normalize values - norm_value <- lapply(seq_along(value), function(.x) { - join_key(i, names(value)[.x], value[[.x]]) - }) - names(norm_value) <- names(value) - - # Check if multiple modifications don't have a conflict - repeated_value_ix <- names(value) %in% names(value)[duplicated(names(value))] - repeated <- norm_value[repeated_value_ix] - vapply( - seq_along(repeated), - function(.ix, .x_value = repeated[[.ix]], .x_name = names(.x_value[[1]])) { - assert_compatible_keys2( - .x_value, - unlist(unname( - repeated[-.ix][names(repeated[-.ix]) == .x_name] - ), recursive = FALSE) - ) - }, - logical(1) - ) - - norm_value <- lapply(norm_value, function(x) x[[1]][[1]]) - names(norm_value) <- names(value) - - # 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) - - # 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 - } - - new_x[[i]] <- norm_value - - # Iterate on all new values to create symmetrical pair - for (ds2 in names(norm_value)) { - if (ds2 == i) next - - keep_value <- new_x[[ds2]] %||% list() - new_value <- norm_value[[ds2]] - - if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { - new_value <- setNames(new_value, new_value) - } else if (checkmate::test_character(new_value, min.len = 1)) { - # Invert key - new_value <- setNames(names(new_value), new_value) - } - - keep_value[[i]] <- new_value - - # Assign symmetrical - new_x[[ds2]] <- keep_value - } - - # Remove NULL or empty keys - empty_ix <- vapply( - new_x, - function(.x) is.null(.x) || length(.x) == 0, - logical(1) - ) - preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"] - new_x <- new_x[!empty_ix] - attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr) - - # - # restore class - class(new_x) <- class(x) - new_x -} - - #' Internal constructor #' #' @return an empty `join_keys` list diff --git a/man/length.join_keys.Rd b/man/length.join_keys.Rd deleted file mode 100644 index faded460e..000000000 --- a/man/length.join_keys.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys-utils.R -\name{length.join_keys} -\alias{length.join_keys} -\title{Length of \code{join_keys} object.} -\usage{ -\method{length}{join_keys}(x) -} -\arguments{ -\item{x}{an \R object. For replacement, a vector or factor.} -} -\description{ -Length of \code{join_keys} object. -} From 0971e0a07a09753c8cbd91783b8f3fc0b83bf342 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 17 Nov 2023 09:30:45 +0000 Subject: [PATCH 133/152] [skip actions] Roxygen Man Pages Auto Update --- man/join_keys.Rd | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 072d8cb98..ea648c63a 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -1,6 +1,6 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys.R, R/join_keys-c.R, -% R/join_keys-extract.R, R/join_keys-print.R +% Please edit documentation in R/join_keys.R, R/join_keys-extract.R, +% R/join_keys-c.R, R/join_keys-print.R \name{join_keys} \alias{join_keys} \alias{[[<-.join_keys} @@ -8,6 +8,7 @@ \alias{c.join_keys} \alias{c.join_key_set} \alias{[.join_keys} +\alias{[<-.join_keys} \alias{format.join_keys} \alias{print.join_keys} \alias{join_keys.default} @@ -16,7 +17,6 @@ \alias{join_keys<-} \alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} -\alias{[<-.join_keys} \title{Manage relationships between datasets using \code{join_keys}} \usage{ join_keys(...) @@ -31,6 +31,8 @@ join_keys(...) \method{[}{join_keys}(x, i, j) +\method{[}{join_keys}(x, i, j) <- value + \method{format}{join_keys}(x, ...) \method{print}{join_keys}(x, ...) @@ -46,8 +48,6 @@ join_keys(x) <- value \method{join_keys}{join_keys}(x) <- value \method{join_keys}{teal_data}(x) <- value - -\method{[}{join_keys}(x, i, j) <- value } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. @@ -105,12 +105,12 @@ the relationship keys between the selected elements and their parents. } \itemize{ -\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. -\code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. +\item \verb{[<-} is not a supported operation for \code{join_keys}. } \itemize{ -\item \verb{[<-} is not a supported operation for \code{join_keys}. +\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. +\code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. } } \examples{ From 55149620c6401acac1582f1b8091c41f78718a05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 10:34:20 +0100 Subject: [PATCH 134/152] pr: improve on filtering empty entries --- R/join_keys-extract.R | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index 8f85ac473..55a51090c 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -218,14 +218,9 @@ new_x[[ds2]] <- keep_value } - # Remove NULL or empty keys - empty_ix <- vapply( - new_x, - function(.x) is.null(.x) || length(.x) == 0, - logical(1) - ) preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"] - new_x <- new_x[!empty_ix] + # Remove NULL or empty keys + new_x <- Filter(function(x) length(x) != 0L, new_x) attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr) # From e525093fac61d2e971d1c336b3b7cfe3f84e7701 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 10:34:33 +0100 Subject: [PATCH 135/152] docs: cleanup of pkgdown --- _pkgdown.yml | 2 -- 1 file changed, 2 deletions(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index 83a3cf49e..4f3a40d7e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -123,12 +123,10 @@ reference: - join_key - join_keys - join_keys<- - - length.join_keys - names<-.join_keys - parent - parents - parents<- - - print.join_keys - python_code - read_script - update_keys_given_parents From 469bc5ae6cb7f7145c5dc0c72ebfc8d1120a9fea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 10:38:48 +0100 Subject: [PATCH 136/152] docs: minor correction due to spelling --- R/join_keys.R | 2 +- man/join_keys.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/join_keys.R b/R/join_keys.R index 1c3af062c..cf5e099fe 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -14,7 +14,7 @@ #' - `join_keys()`: Returns an empty `join_keys` object when called without arguments. #' - `join_keys(x)`: Returns the `join_keys` object contained in `x` (if it contains one). #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. -#' - `join_keys[datanames]`: Returns a subset of the `join_keys` object for given datanames, +#' - `join_keys[datanames]`: Returns a subset of the `join_keys` object for given `datanames`, #' including their symmetric mirror keys. #' - `join_keys[i, j]`: Returns join keys between datasets `i` and `j`, #' including implicit keys inferred from their relationship with a parent. diff --git a/man/join_keys.Rd b/man/join_keys.Rd index ea648c63a..8e3426037 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -84,7 +84,7 @@ is automatically mirrored between \code{dat2} and \code{dat1}. \item \code{join_keys()}: Returns an empty \code{join_keys} object when called without arguments. \item \code{join_keys(x)}: Returns the \code{join_keys} object contained in \code{x} (if it contains one). \item \code{join_keys(...)}: Creates a new object with one or more \code{join_key_set} parameters. -\item \code{join_keys[datanames]}: Returns a subset of the \code{join_keys} object for given datanames, +\item \code{join_keys[datanames]}: Returns a subset of the \code{join_keys} object for given \code{datanames}, including their symmetric mirror keys. \item \code{join_keys[i, j]}: Returns join keys between datasets \code{i} and \code{j}, including implicit keys inferred from their relationship with a parent. From 803386db587f8ed9d60d8388aa157960e0fe2819 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 12:30:33 +0100 Subject: [PATCH 137/152] tests and asserts round 1 --- R/join_keys-extract.R | 90 ++++++---- tests/testthat/test-join_keys-extract.R | 225 +++++++++++++++++------- 2 files changed, 216 insertions(+), 99 deletions(-) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index 55a51090c..d5c085f6e 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -30,30 +30,41 @@ #' jk[c("ds1", "ds2")] #' jk["ds1", "ds2"] `[.join_keys` <- function(x, i, j) { - if (missing(i)) { + if (missing(i) && missing(j)) { + # because: + # - list(a = 1)[] returns list(a = 1) + # - data.frame(a = 1)[] returns data.frame(a = 1) return(x) - } - - if (is.null(i)) { - return(join_keys()) # replicate base R - } - - if (!missing(j)) { - checkmate::assert( - combine = "or", - checkmate::check_string(i), - checkmate::check_integerish(i, len = 1), - checkmate::check_logical(i, len = length(x)) - ) - checkmate::assert( - combine = "or", - checkmate::check_string(j), - checkmate::check_integerish(j, len = 1), - checkmate::check_logical(j, len = length(x)) - ) + } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) { + # because list(a = 1)[NULL] returns NULL + # data.frame(a = 1)[NULL, NULL] returns data.frame( + return(join_keys()) + } else if (!missing(i) && !missing(j)) { + if ( + !any( + checkmate::test_string(i), + checkmate::test_integerish(i, len = 1), + checkmate::test_logical(i, len = length(x)) && sum(j) == 1 + ) || + !any( + checkmate::test_string(j), + checkmate::test_integerish(j, len = 1), + checkmate::test_logical(j, len = length(x)) && sum(j) == 1 + ) + ) { + stop( + "join_keys[i, j] - Can't extract keys for multiple pairs.", + "When specifying a pair [i, j], both indices must point to a single key pair.\n", + call. = FALSE + ) + } - subset_x <- update_keys_given_parents(x)[union(i, j)] + subset_x <- update_keys_given_parents(x[union(i, j)]) return(subset_x[[i]][[j]]) + } else if (!missing(j)) { + # ie. select all keys which have j as dataset_2 + # since list is symmetrical it is equivalent to selecting by i + i <- j } checkmate::assert( @@ -113,13 +124,29 @@ #' #' @export `[<-.join_keys` <- function(x, i, j, value) { - if (missing(j)) { - stop("Can't use `[<-` for object `join_keys` with only i. Use [[<- instead.") + if (missing(i) || missing(j)) { + stop("join_keys[i, j] specify both indices to set a key pair.") + } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) { + stop("join_keys[i, j] neither i nor j can be NULL.") + } else if ( + !any( + checkmate::test_string(i), + checkmate::test_integerish(i, len = 1), + checkmate::test_logical(i, len = length(x)) && sum(j) == 1 + ) || + !any( + checkmate::test_string(j), + checkmate::test_integerish(j, len = 1), + checkmate::test_logical(j, len = length(x)) && sum(j) == 1 + ) + ) { + stop( + "join_keys[i, j] <- Can't set keys to specified indices.\n", + "When setting pair [i, j], both indices must point to a single key pair.\n", + call. = FALSE + ) } - checkmate::assert_string(i) - checkmate::assert_string(j) - x[[i]][[j]] <- value x } @@ -203,15 +230,8 @@ if (ds2 == i) next keep_value <- new_x[[ds2]] %||% list() - new_value <- norm_value[[ds2]] - - if (checkmate::test_character(new_value, min.len = 1, names = "unnamed")) { - new_value <- setNames(new_value, new_value) - } else if (checkmate::test_character(new_value, min.len = 1)) { - # Invert key - new_value <- setNames(names(new_value), new_value) - } - + # Invert key + new_value <- setNames(names(norm_value[[ds2]]), norm_value[[ds2]]) keep_value[[i]] <- new_value # Assign symmetrical diff --git a/tests/testthat/test-join_keys-extract.R b/tests/testthat/test-join_keys-extract.R index f44262f2b..abfc7a6d8 100644 --- a/tests/testthat/test-join_keys-extract.R +++ b/tests/testthat/test-join_keys-extract.R @@ -1,55 +1,5 @@ -# [.join_keys ----------------------------------------------------------------- -testthat::test_that("[[.join_keys returns keys for given pair", { - 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["b", "a"], c(`child-parent` = "child-parent")) -}) - -testthat::test_that("[[.join_keys doesn't return keys for given a pair without explicit join_key", { - 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_null(my_keys[["b"]][["c"]]) -}) - -testthat::test_that("[[.join_keys infer keys between children by equal (unordered) foreign keys 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])) - ) - parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) -}) - -testthat::test_that( - "[[.join_keys infer keys between children by foreign keys to common parent. ", - { - my_keys <- join_keys( - join_key("a", "a", "aa"), - join_key("b", "b", "bb"), - join_key("c", "c", "cc"), - join_key("b", "a", c(bb = "aa")), - join_key("c", "a", c(cc = "aa")) - ) - parents(my_keys) <- list("b" = "a", "c" = "a") - testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) - } -) - -# [.join_keys ----------------------------------------------------------------- -testthat::test_that("[.join_keys returns join_keys object when i is missing", { +# join_keys[i] ----------------------------------------------------------------- +testthat::test_that("join_keys[i] returns join_keys object when i and j is missing", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -58,7 +8,13 @@ testthat::test_that("[.join_keys returns join_keys object when i is missing", { testthat::expect_identical(my_keys[], my_keys) }) -testthat::test_that("[.join_keys returns join_keys object with keys for given datasets", { +testthat::test_that("join_keys[i] returns empty join_keys when i or j are NULL", { + my_keys <- join_keys(join_key("d1", "d1", "a")) + testthat::expect_identical(my_keys[NULL], join_keys()) + testthat::expect_identical(my_keys[, NULL], join_keys()) +}) + +testthat::test_that("join_keys[i] subsets join_keys object to specific datasets", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -70,7 +26,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given da ) }) -testthat::test_that("[.join_keys returns join_keys object with keys for given index", { +testthat::test_that("join_keys[i] returns join_keys object with keys for given index", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -82,7 +38,7 @@ testthat::test_that("[.join_keys returns join_keys object with keys for given in ) }) -testthat::test_that("[.join_keys returns join_keys object for given dataset including its parent", { +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"), join_key("d2", "d2", "b"), @@ -102,7 +58,7 @@ testthat::test_that("[.join_keys returns join_keys object for given dataset incl testthat::expect_equal(my_keys["d2"], expected) }) -testthat::test_that("[.join_keys returns join_keys object for given dataset and doesn't include its children", { +testthat::test_that("join_keys[i] returns join_keys object for given dataset and doesn't include its children", { my_keys <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -122,12 +78,12 @@ testthat::test_that("[.join_keys returns join_keys object for given dataset and testthat::expect_equal(my_keys["d2"], expected) }) -testthat::test_that("[.join_keys returns empty join_keys for inexisting dataset", { +testthat::test_that("join_keys[i] returns empty join_keys for inexisting dataset", { my_keys <- join_keys(join_key("d1", "d1", "a")) testthat::expect_length(my_keys["d2"], 0) }) -testthat::test_that("[.join_keys ignores duplicate indexes - return only first occurrence", { +testthat::test_that("join_keys[i] ignores duplicate indexes - return only first occurrence", { jk <- join_keys( join_key("d1", "d1", "a"), join_key("d2", "d2", "b"), @@ -139,7 +95,153 @@ testthat::test_that("[.join_keys ignores duplicate indexes - return only first o ) }) -# [<-.join_keys and [[<-.join_keys ------------------------------------------------ +testthat::test_that("join_keys[,j] returns the same as join_keys[i,]", { + my_keys <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c") + ) + testthat::expect_identical( + my_keys[, c("d1", "d2")], + my_keys[c("d1", "d2")] + ) +}) + +# join_keys[i, j] ----------------------------------------------------------------- +testthat::test_that("join_keys[i,j] returns keys for given pair", { + 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["b", "a"], 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"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc"), + join_key("b", "a", "child-parent"), + join_key("c", "a", "child-parent") + ) + testthat::expect_null(my_keys["b", "c"]) +}) + +testthat::test_that( + "join_keys[i,j] infer keys between children through unnamed foreign keys to parent (reglardless keys order)", + { + 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])) + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + testthat::expect_identical(my_keys["b", "c"], setNames(letters[1:5], letters[1:5])) + } +) + +testthat::test_that( + "join_keys[i,j] doesn't infer keys between grandchildren", + { + 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"), + join_key("d", "b", "grandchild-child"), + join_key("e", "c", "grandchild-child") + ) + parents(my_keys) <- list("b" = "a", "c" = "a", "d" = "b", "e" = "c") + testthat::expect_null(my_keys["d", "e"]) + } +) + +testthat::test_that( + "join_keys[i,j ] infer keys between children through foreign keys 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", c(bb = "aa")), + join_key("c", "a", c(cc = "aa")) + ) + parents(my_keys) <- list("b" = "a", "c" = "a") + # "bb" and "cc" are the names in child datasets, "aa" is the name in parent dataset + testthat::expect_identical(my_keys["b", "c"], c(bb = "cc")) + } +) + +testthat::test_that("join_keys[i,j] returns NULL for inexisting key pair (can't even infer)", { + my_keys <- join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc") + ) + testthat::expect_null(my_keys["inexisting", "inexisting"]) +}) + +testthat::test_that("join_keys[i,j] throws when one of the indices is longer than 1", { + my_keys <- join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc") + ) + testthat::expect_error(my_keys[c("a", "b"), "c"], "Can't extract keys for multiple pairs.") +}) + +# [<-.join_keys ------------------------------------------------ +testthat::test_that("join_keys[i]<- throws when assigning anything", { + my_keys <- join_keys() + testthat::expect_error(my_keys["a"] <- join_key("a", "b", "test"), "specify both indices to set a key pair.") +}) + +testthat::test_that("join_keys[i]<- throws when no index specified", { + my_keys <- join_keys() + testthat::expect_error(my_keys[] <- join_key("a", "b", "test"), "specify both indices to set a key pair.") +}) + +testthat::test_that("join_keys[i,j]<- can set new value for existing pair", { + my_keys <- join_keys(join_key("a", "a", "aa")) + testthat::expect_no_error(my_keys["a", "a"] <- "new key") + testthat::expect_identical(my_keys, join_keys(join_key("a", "a", "new key"))) +}) + +testthat::test_that("join_keys[i,j]<- sets a new keys for inexisting pair", { + my_keys <- join_keys(join_key("a", "a", "aa")) + testthat::expect_no_error(my_keys["b", "c"] <- "new key") + testthat::expect_identical(my_keys, join_keys(join_key("a", "a", "aa"), join_key("b", "c", "new key"))) +}) + +testthat::test_that("join_keys[i,j]<- throws when assigning to inspecific index", { + my_keys <- join_keys() + testthat::expect_error(my_keys[, "b"] <- join_key("a", "b", "test")) +}) + +testthat::test_that("join_keys[i,j]<- throws when assigning to j only", { + my_keys <- join_keys() + testthat::expect_error(my_keys[, "b"] <- join_key("a", "b", "test")) +}) + +testthat::test_that("join_keys[i,j]<- throws when i or j are NULL", { + my_keys <- join_keys() + testthat::expect_error(my_keys[NULL, 1] <- join_key("a", "b", "test"), "NULL") + testthat::expect_error(my_keys[1, NULL] <- join_key("a", "b", "test"), "NULL") +}) + +testthat::test_that("join_keys[i,j]<- throws when i or j are longer than 1", { + my_keys <- join_keys() + testthat::expect_error(my_keys[c("a", "b"), "a"] <- "new key") + testthat::expect_error(my_keys["a", c("a", "b")] <- "new key") +}) + +# [[<-.join_keys ------------------------------------------------ testthat::test_that("[[<-.join_keys accepts named list where each containing character", { jk <- join_keys() testthat::expect_no_error( @@ -201,11 +303,6 @@ testthat::test_that("[[<-.join_keys adds symmetrical change to the foreign datas ) }) -testthat::test_that("[<-.join_keys throws when assigning anything", { - jk_expected <- join_keys() - testthat::expect_error(jk_expected["a"] <- join_key("a", "b", "test"), "Can't use `\\[<-`") -}) - testthat::test_that("[[<- can mutate existing keys", { my_keys <- join_keys(join_key("d1", "d2", "A")) my_keys[["d1"]][["d2"]] <- "B" From 31767bc09053f5ced79b44bdf8537d96cba5ce5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 12:43:43 +0100 Subject: [PATCH 138/152] docs: first pass at join_keys documentation --- R/join_keys-c.R | 19 +++-- R/join_keys-extract.R | 62 ++++++++++------ R/join_keys-print.R | 2 + R/join_keys.R | 67 +++++++++-------- man/join_keys.Rd | 168 +++++++++++++++++++++--------------------- 5 files changed, 179 insertions(+), 139 deletions(-) diff --git a/R/join_keys-c.R b/R/join_keys-c.R index 8f7224b4e..cf4db5323 100644 --- a/R/join_keys-c.R +++ b/R/join_keys-c.R @@ -1,11 +1,18 @@ #' @rdname join_keys +#' @order 4 #' @export #' #' @examples #' -#' # Merging multiple `join_keys` +#' # Merging multiple `join_keys` --- #' -#' jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) +#' jk_merged <- c( +#' jk, +#' join_keys( +#' join_key("ds4", keys = c("pk4", "pk4_2")), +#' join_key("ds4", "ds3", c(pk4_2 = "pk3")) +#' ) +#' ) c.join_keys <- function(...) { join_keys_obj <- rlang::list2(...)[[1]] x <- rlang::list2(...)[-1] @@ -25,16 +32,18 @@ c.join_keys <- function(...) { } #' @rdname join_keys +#' @order 4 +#' #' @export #' #' @examples #' -#' # Note that you can merge join_keys or a single join_key_set +#' # note: merge can be performed with both join_keys and join_key_set #' #' jk_merged <- c( #' jk_merged, -#' join_key("dataset_A", "dataset_F", "col_a"), -#' join_key("dataset_O", "dataset_G", "col_g") +#' join_key("ds5", keys = "pk5"), +#' join_key("ds5", "ds1", c(pk5 = "pk1")) #' ) c.join_key_set <- function(...) { c.join_keys(...) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index d5c085f6e..e7f80db52 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -1,9 +1,12 @@ #' @rdname join_keys +#' @order 2 #' #' @details -#' - `[.join_keys` can be used to return a subset of relationship pairs. It will -#' retrieve the primary keys of the selected elements and its parents (along with) -#' the relationship keys between the selected elements and their parents. +#' - `x[datanames]`: Returns a subset of the `join_keys` object for +#' given `datanames`, including parent `datanames` and symmetric mirror keys between +#' `datanames` in the result. +#' - `x[i, j]`: Returns join keys between datasets `i` and `j`, +#' including implicit keys inferred from their relationship with a parent. #' #' @param i index specifying elements to extract or replace. Index should be a #' a character vector, but it can also take numeric, logical, `NULL` or missing. @@ -15,20 +18,15 @@ #' #' @examples #' -#' # Getter for join_keys ---- +#' # Getter for join_keys --- #' -#' jk <- join_keys( -#' join_key("ds1", "ds1", "primary-key-1"), -#' join_key("ds2", "ds2", "primary-key-2"), -#' join_key("ds3", "ds3", "primary-key-3"), -#' join_key("ds2", "ds1", "foreign-key-2-1"), -#' join_key("ds3", "ds1", "foregin-key-3-1") -#' ) +#' jk["ds1", "ds2"] +#' +#' # Subsetting join_keys ---- #' #' jk["ds1"] #' jk[1:2] #' jk[c("ds1", "ds2")] -#' jk["ds1", "ds2"] `[.join_keys` <- function(x, i, j) { if (missing(i) && missing(j)) { # because: @@ -118,11 +116,30 @@ } #' @rdname join_keys +#' @order 2 #' #' @details -#' - `[<-` is not a supported operation for `join_keys`. +#' - `x[i, j] <- value`: Assignment of a key to pair `(i, j)`. +#' - `x[i] <- value`: This (without `j` parameter) **is not** a supported +#' operation for `join_keys`. +#' - `join_keys(x)[i, j] <- value`: Assignment to `join_keys` object stored in `x`, +#' such as a `teal_data` or `join_keys` itself. #' #' @export +#' @examples +#' +#' # Setting a new primary key --- +#' +#' jk["ds4", "ds4"] <- "pk4" +#' jk["ds5", "ds5"] <- "pk5" +#' +#' # Setting a single relationship pair --- +#' +#' jk["ds4", "ds1"] <- c("pk4" = "pk1") +#' +#' # Removing a key --- +#' +#' jk["ds5", "ds5"] <- NULL `[<-.join_keys` <- function(x, i, j, value) { if (missing(i) || missing(j)) { stop("join_keys[i, j] specify both indices to set a key pair.") @@ -151,24 +168,25 @@ x } +#' @noRd #' @rdname join_keys #' -#' @order 3 +#' @order 1000 +#' @usage ## Prefered method is x[i, j] <- value +#' x[[i]][[j]] <- value #' #' @details -#' - `[[<-` is the preferred method to replace or assign new relationship pair to an -#' existing `join_keys` object. -#' - `join_keys(obj)[[dataset_1]] <- value` can also be used to assign a relationship -#' pair to an `obj` that contains a `join_keys`, such as itself or a `teal_data` -#' object. +#' - `x[[i]][[j]] <- value`: It is equivalent as `x[i, j] <- value`. #' #' @export #' @examples #' +#' # Setting via x[[i]] <- value --- +#' #' jk <- join_keys() -#' jk[["dataset_A"]][["dataset_B"]] <- "key" -#' jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") -#' jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key +#' jk[["ds6"]][["ds6"]] <- "pk6" +#' jk[["ds7"]] <- list(ds7 = "pk7", ds6 = c(pk7 = "pk6")) +#' jk[["ds7"]][["ds7"]] <- NULL # removes key #' #' jk `[[<-.join_keys` <- function(x, i, value) { diff --git a/R/join_keys-print.R b/R/join_keys-print.R index 69e7f0c6a..361120bf7 100644 --- a/R/join_keys-print.R +++ b/R/join_keys-print.R @@ -1,4 +1,5 @@ #' @rdname join_keys +#' @order 7 #' @export format.join_keys <- function(x, ...) { check_ellipsis(...) @@ -54,6 +55,7 @@ format.join_keys <- function(x, ...) { } #' @rdname join_keys +#' @order 7 #' @export print.join_keys <- function(x, ...) { cat(format(x, ...), "\n") diff --git a/R/join_keys.R b/R/join_keys.R index cf5e099fe..d5e8c4726 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -1,4 +1,9 @@ #' Manage relationships between datasets using `join_keys` +#' @order 1 +#' @name join_keys +#' +#' @usage ## Constructor, getter and setter +#' join_keys(...) #' #' @description #' `join_keys()` facilitates the creation and retrieval of relationships between datasets. @@ -14,13 +19,6 @@ #' - `join_keys()`: Returns an empty `join_keys` object when called without arguments. #' - `join_keys(x)`: Returns the `join_keys` object contained in `x` (if it contains one). #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. -#' - `join_keys[datanames]`: Returns a subset of the `join_keys` object for given `datanames`, -#' including their symmetric mirror keys. -#' - `join_keys[i, j]`: Returns join keys between datasets `i` and `j`, -#' including implicit keys inferred from their relationship with a parent. -#' -#' -#' @order 1 #' #' @param ... (optional), when no argument is given the empty constructor is called. #' Otherwise, when called with only one argument of type: `join_keys` or `teal_data` @@ -32,8 +30,13 @@ #' #' @export #' +#' @seealso [join_key()] for creating `join_keys_set`, +#' [parents()] for parent operations, +#' [teal_data()] for `teal_data` constructor _and_ +#' [default_cdisc_join_keys] for default `CDISC` keys. +#' #' @examples -#' # Setting join keys ---- +#' # Creating a new join keys ---- #' #' jk <- join_keys( #' join_key("ds1", "ds1", "pk1"), @@ -57,12 +60,14 @@ join_keys <- function(...) { } #' @rdname join_keys +#' @order 1 #' @export join_keys.default <- function(...) { c(new_join_keys(), ...) } #' @rdname join_keys +#' @order 1 #' @export join_keys.join_keys <- function(...) { x <- rlang::list2(...) @@ -70,26 +75,15 @@ join_keys.join_keys <- function(...) { } #' @rdname join_keys -#' @order 1000 +#' @order 1 #' @export -#' @examples -#' # Using a `join_keys` with `teal_data` -#' -#' td <- teal_data() -#' join_keys(td) <- join_keys( -#' join_key("ds1", "ds1", "pk1"), -#' join_key("ds2", "ds2", "pk2"), -#' join_key("ds3", "ds3", "pk3"), -#' join_key("ds2", "ds1", c(pk2 = "pk1")), -#' join_key("ds3", "ds1", c(pk3 = "pk1")) -#' ) -#' join_keys(td) join_keys.teal_data <- function(...) { x <- rlang::list2(...) x[[1]]@join_keys } #' @rdname join_keys +#' @order 1 #' @export join_keys.TealData <- function(...) { x <- rlang::list2(...) @@ -97,12 +91,15 @@ join_keys.TealData <- function(...) { } #' @rdname join_keys +#' @order 5 #' #' @details -#' - "`join_keys(obj) <- value`" will set the `join_keys` in object with `value`. +#' - `join_keys(x) <- value`: Assignment of the `join_keys` in object with `value`. #' `value` needs to be an object of class `join_keys` or `join_key_set`. #' #' @param x (`join_keys`) empty object to set the new relationship pairs. +#' `x` is typically an object of `join_keys` class. When called with the `join_keys(x)` +#' or `join_keys(x) <- value` then it can also take a supported class (`teal_data`, `join_keys`) #' @param value (`join_key_set` or list of `join_key_set`) relationship pairs to add #' to `join_keys` list. #' @@ -113,28 +110,38 @@ join_keys.TealData <- function(...) { } #' @rdname join_keys +#' @order 5 #' @export #' @examples #' -#' # Using the setter (assignment) ---- -#' jk <- join_keys() -#' jk["ds1", "ds1"] <- "pk1" -#' jk["ds2", "ds2"] <- "pk2" -#' jk["ds3", "ds3"] <- "pk3" -#' jk["ds2", "ds1"] <- c(pk2 = "pk1") -#' jk["ds3", "ds1"] <- c(pk3 = "pk1") +#' # Assigning keys via join_keys(x)[i, j] <- value ---- +#' +#' obj <- join_keys() +#' # or +#' obj <- teal_data() +#' +#' join_keys(obj)["ds1", "ds1"] <- "pk1" +#' join_keys(obj)["ds2", "ds2"] <- "pk2" +#' join_keys(obj)["ds3", "ds3"] <- "pk3" +#' join_keys(obj)["ds2", "ds1"] <- c(pk2 = "pk1") +#' join_keys(obj)["ds3", "ds1"] <- c(pk3 = "pk1") +#' +#' identical(jk, join_keys(obj)) `join_keys<-.join_keys` <- function(x, value) { value } #' @rdname join_keys +#' @order 5 #' @export #' @examples #' #' # Setter for join_keys within teal_data ---- #' #' td <- teal_data() -#' join_keys(td)["ds1", "ds2"] <- "key1" +#' join_keys(td) <- jk +#' +#' join_keys(td)["ds1", "ds2"] <- "new_key" #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) #' join_keys(td) `join_keys<-.teal_data` <- function(x, value) { diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 8e3426037..6eabbe1da 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -3,51 +3,49 @@ % R/join_keys-c.R, R/join_keys-print.R \name{join_keys} \alias{join_keys} -\alias{[[<-.join_keys} -\alias{join_keys.teal_data} -\alias{c.join_keys} -\alias{c.join_key_set} -\alias{[.join_keys} -\alias{[<-.join_keys} -\alias{format.join_keys} -\alias{print.join_keys} \alias{join_keys.default} \alias{join_keys.join_keys} +\alias{join_keys.teal_data} \alias{join_keys.TealData} +\alias{[.join_keys} +\alias{[<-.join_keys} +\alias{c.join_keys} +\alias{c.join_key_set} \alias{join_keys<-} \alias{join_keys<-.join_keys} \alias{join_keys<-.teal_data} +\alias{format.join_keys} +\alias{print.join_keys} \title{Manage relationships between datasets using \code{join_keys}} \usage{ +## Constructor, getter and setter join_keys(...) -\method{[[}{join_keys}(x, i) <- value +\method{join_keys}{default}(...) -\method{join_keys}{teal_data}(...) +\method{join_keys}{join_keys}(...) -\method{c}{join_keys}(...) +\method{join_keys}{teal_data}(...) -\method{c}{join_key_set}(...) +\method{join_keys}{TealData}(...) \method{[}{join_keys}(x, i, j) \method{[}{join_keys}(x, i, j) <- value -\method{format}{join_keys}(x, ...) - -\method{print}{join_keys}(x, ...) - -\method{join_keys}{default}(...) - -\method{join_keys}{join_keys}(...) +\method{c}{join_keys}(...) -\method{join_keys}{TealData}(...) +\method{c}{join_key_set}(...) join_keys(x) <- value \method{join_keys}{join_keys}(x) <- value \method{join_keys}{teal_data}(x) <- value + +\method{format}{join_keys}(x, ...) + +\method{print}{join_keys}(x, ...) } \arguments{ \item{...}{(optional), when no argument is given the empty constructor is called. @@ -56,16 +54,18 @@ it will return the \code{join_keys} of that object. When called with 1 or more \code{join_key_set} it will create a new \code{join_keys} with constructed from the arguments.} -\item{x}{(\code{join_keys}) empty object to set the new relationship pairs.} +\item{x}{(\code{join_keys}) empty object to set the new relationship pairs. +\code{x} is typically an object of \code{join_keys} class. When called with the \code{join_keys(x)} +or \code{join_keys(x) <- value} then it can also take a supported class (\code{teal_data}, \code{join_keys})} \item{i}{index specifying elements to extract or replace. Index should be a a character vector, but it can also take numeric, logical, \code{NULL} or missing.} -\item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add -to \code{join_keys} list.} - \item{j}{index specifying elements to extract or replace. Index should be a a character vector, but it can also take numeric, logical, \code{NULL} or missing.} + +\item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add +to \code{join_keys} list.} } \value{ \code{join_keys} object. @@ -84,37 +84,31 @@ is automatically mirrored between \code{dat2} and \code{dat1}. \item \code{join_keys()}: Returns an empty \code{join_keys} object when called without arguments. \item \code{join_keys(x)}: Returns the \code{join_keys} object contained in \code{x} (if it contains one). \item \code{join_keys(...)}: Creates a new object with one or more \code{join_key_set} parameters. -\item \code{join_keys[datanames]}: Returns a subset of the \code{join_keys} object for given \code{datanames}, -including their symmetric mirror keys. -\item \code{join_keys[i, j]}: Returns join keys between datasets \code{i} and \code{j}, -including implicit keys inferred from their relationship with a parent. -} - -\itemize{ -\item \verb{[[<-} is the preferred method to replace or assign new relationship pair to an -existing \code{join_keys} object. -\item \code{join_keys(obj)[[dataset_1]] <- value} can also be used to assign a relationship -pair to an \code{obj} that contains a \code{join_keys}, such as itself or a \code{teal_data} -object. } \itemize{ -\item \verb{[.join_keys} can be used to return a subset of relationship pairs. It will -retrieve the primary keys of the selected elements and its parents (along with) -the relationship keys between the selected elements and their parents. +\item \code{x[datanames]}: Returns a subset of the \code{join_keys} object for +given \code{datanames}, including parent \code{datanames} and symmetric mirror keys between +\code{datanames} in the result. +\item \code{x[i, j]}: Returns join keys between datasets \code{i} and \code{j}, +including implicit keys inferred from their relationship with a parent. } \itemize{ -\item \verb{[<-} is not a supported operation for \code{join_keys}. +\item \code{x[i, j] <- value}: Assignment of a key to pair \verb{(i, j)}. +\item \code{x[i] <- value}: This (without \code{j} parameter) \strong{is not} a supported +operation for \code{join_keys}. +\item \code{join_keys(x)[i, j] <- value}: Assignment to \code{join_keys} object stored in \code{x}, +such as a \code{teal_data} or \code{join_keys} itself. } \itemize{ -\item "\code{join_keys(obj) <- value}" will set the \code{join_keys} in object with \code{value}. +\item \code{join_keys(x) <- value}: Assignment of the \code{join_keys} in object with \code{value}. \code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. } } \examples{ -# Setting join keys ---- +# Creating a new join keys ---- jk <- join_keys( join_key("ds1", "ds1", "pk1"), @@ -126,63 +120,73 @@ jk <- join_keys( jk -jk <- join_keys() -jk[["dataset_A"]][["dataset_B"]] <- "key" -jk[["dataset_C"]] <- list(dataset_A = "key_2", dataset_B = "key_3") -jk[["dataset_A"]][["dataset_C"]] <- NULL # removes key +# Getter for join_keys --- -jk -# Using a `join_keys` with `teal_data` +jk["ds1", "ds2"] -td <- teal_data() -join_keys(td) <- join_keys( - join_key("ds1", "ds1", "pk1"), - join_key("ds2", "ds2", "pk2"), - join_key("ds3", "ds3", "pk3"), - join_key("ds2", "ds1", c(pk2 = "pk1")), - join_key("ds3", "ds1", c(pk3 = "pk1")) -) -join_keys(td) +# Subsetting join_keys ---- + +jk["ds1"] +jk[1:2] +jk[c("ds1", "ds2")] + +# Setting a new primary key --- + +jk["ds4", "ds4"] <- "pk4" +jk["ds5", "ds5"] <- "pk5" -# Merging multiple `join_keys` +# Setting a single relationship pair --- -jk_merged <- c(jk, join_keys(join_key("dataset_D", "dataset_E", "col_2"))) +jk["ds4", "ds1"] <- c("pk4" = "pk1") -# Note that you can merge join_keys or a single join_key_set +# Removing a key --- + +jk["ds5", "ds5"] <- NULL + +# Merging multiple `join_keys` --- jk_merged <- c( - jk_merged, - join_key("dataset_A", "dataset_F", "col_a"), - join_key("dataset_O", "dataset_G", "col_g") + jk, + join_keys( + join_key("ds4", keys = c("pk4", "pk4_2")), + join_key("ds4", "ds3", c(pk4_2 = "pk3")) + ) ) -# Getter for join_keys ---- +# note: merge can be performed with both join_keys and join_key_set -jk <- join_keys( - join_key("ds1", "ds1", "primary-key-1"), - join_key("ds2", "ds2", "primary-key-2"), - join_key("ds3", "ds3", "primary-key-3"), - join_key("ds2", "ds1", "foreign-key-2-1"), - join_key("ds3", "ds1", "foregin-key-3-1") +jk_merged <- c( + jk_merged, + join_key("ds5", keys = "pk5"), + join_key("ds5", "ds1", c(pk5 = "pk1")) ) -jk["ds1"] -jk[1:2] -jk[c("ds1", "ds2")] -jk["ds1", "ds2"] +# Assigning keys via join_keys(x)[i, j] <- value ---- -# Using the setter (assignment) ---- -jk <- join_keys() -jk["ds1", "ds1"] <- "pk1" -jk["ds2", "ds2"] <- "pk2" -jk["ds3", "ds3"] <- "pk3" -jk["ds2", "ds1"] <- c(pk2 = "pk1") -jk["ds3", "ds1"] <- c(pk3 = "pk1") +obj <- join_keys() +# or +obj <- teal_data() + +join_keys(obj)["ds1", "ds1"] <- "pk1" +join_keys(obj)["ds2", "ds2"] <- "pk2" +join_keys(obj)["ds3", "ds3"] <- "pk3" +join_keys(obj)["ds2", "ds1"] <- c(pk2 = "pk1") +join_keys(obj)["ds3", "ds1"] <- c(pk3 = "pk1") + +identical(jk, join_keys(obj)) # Setter for join_keys within teal_data ---- td <- teal_data() -join_keys(td)["ds1", "ds2"] <- "key1" +join_keys(td) <- jk + +join_keys(td)["ds1", "ds2"] <- "new_key" join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3"))) join_keys(td) } +\seealso{ +\code{\link[=join_key]{join_key()}} for creating \code{join_keys_set}, +\code{\link[=parents]{parents()}} for parent operations, +\code{\link[=teal_data]{teal_data()}} for \code{teal_data} constructor \emph{and} +\link{default_cdisc_join_keys} for default \code{CDISC} keys. +} From 341f938fc4ca5fb654a24681e5f982e779c3e509 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 13:19:26 +0100 Subject: [PATCH 139/152] docs: first pass at parents documentation --- R/join_keys-parents.R | 84 ++++++++++++++++++++++++++----------------- man/parent.Rd | 22 ------------ man/parents.Rd | 72 +++++++++++++++++++++++++++++-------- 3 files changed, 109 insertions(+), 69 deletions(-) delete mode 100644 man/parent.Rd diff --git a/R/join_keys-parents.R b/R/join_keys-parents.R index 927f6dec3..fd59e16b9 100644 --- a/R/join_keys-parents.R +++ b/R/join_keys-parents.R @@ -1,54 +1,51 @@ -#' Getter and setter for specific parent +#' Getter and setter functions for parents attribute of `join_keys` #' -#' @param x (`join_keys`) object to retrieve. -#' @param dataset_name (`character(1)`) +#' @description +#' `parents()` facilitates the creation of dependencies between datasets by +#' assigning a parent-child relationship. #' -#' @export +#' Each element is defined by a list element, where `list("child" = "parent")`. #' -#' @examples -#' jk <- join_keys(join_key("ds1", "ds2", "key")) -#' parent(jk, "ds2") -#' parents(jk) <- list("ds2" = "ds1") -#' parent(jk, "ds2") -parent <- function(x, dataset_name) { - checkmate::assert_string(dataset_name) - # assert x is performed by parents() - parents(x)[[dataset_name]] -} - -#' Getter and setter functions for parents attribute of `join_keys` +#' @param x (`join_keys` or `teal_data`) object that contains "parents" information +#' to retrieve or manipulate. #' -#' @param x (`join_keys`) object to retrieve or manipulate. #' @return a list of `character` representing the parents. #' #' @export +#' @seealso [join_keys()] parents <- function(x) { UseMethod("parents", x) } -#' @rdname parents +#' @describeIn parents Retrieves parents of `join_keys` object. #' @export #' @examples +#' # Get parents of join_keys --- +#' #' jk <- default_cdisc_join_keys["ADEX"] #' parents(jk) parents.join_keys <- function(x) { attr(x, "__parents__") %||% list() } -#' @rdname parents +#' @describeIn parents Retrieves parents of `join_keys` inside `teal_data` object. #' @export #' @examples #' -#' td <- cdisc_data( +#' # Get parents of join_keys inside teal_data object --- +#' +#' td <- teal_data( #' ADSL = teal.data::rADSL, -#' ADTTE = teal.data::rADTTE +#' ADTTE = teal.data::rADTTE, +#' ADRS = teal.data::rADRS, +#' join_keys = default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS")] #' ) #' parents(td) parents.teal_data <- function(x) { attr(x@join_keys, "__parents__") %||% list() } -#' @rdname parents +#' @describeIn parents Assignment of parents in `join_keys` object. #' #' @param value (`list`) named list of character values #' @@ -57,19 +54,24 @@ parents.teal_data <- function(x) { UseMethod("parents<-", x) } -#' @rdname parents +#' @describeIn parents Assignment of parents of `join_keys` object. #' @export #' @examples #' +#' # Assigment of parents --- +#' #' jk <- join_keys( #' join_key("ds1", "ds2", "id"), #' join_key("ds5", "ds6", "id"), #' join_key("ds7", "ds6", "id") #' ) -#' parents(jk) <- list() -#' parents(jk) <- list(ds1 = "ds2") -#' parents(jk)["ds5"] <- "ds6" -#' parents(jk)["ds6"] <- "ds7" +#' +#' parents(jk) <- list(ds2 = "ds1") +#' +#' # Setting individual parent-child relationship +#' +#' parents(jk)["ds6"] <- "ds5" +#' parents(jk)["ds7"] <- "ds6" `parents<-.join_keys` <- function(x, value) { checkmate::assert_list(value, types = "character", names = "named") @@ -101,15 +103,11 @@ parents.teal_data <- function(x) { x } -#' @rdname parents +#' @describeIn parents Assignment of parents of `join_keys` inside `teal_data` object. #' @export #' @examples #' -#' td <- cdisc_data( -#' ADSL = teal.data::rADSL, -#' ADTTE = teal.data::rADTTE, -#' ADRS = teal.data::rADRS -#' ) +#' # Assigment of parents of join_keys inside teal_data object --- #' #' parents(td) <- list("ADTTE" = "ADSL") # replace existing #' parents(td)["ADRS"] <- "ADSL" # add new parent @@ -117,3 +115,23 @@ parents.teal_data <- function(x) { parents(x@join_keys) <- value x } + +#' @describeIn parents Getter for individual parent +#' +#' @param dataset_name (`character(1)`) Name of dataset to query on their parent. +#' +#' @return For `parent(x, dataset_name)` returns `NULL` if parent does not exist. +#' +#' @export +#' +#' @examples +#' +#' # Get individual parent --- +#' +#' parent(jk, "ds2") +#' parent(td, "ADTTE") +parent <- function(x, dataset_name) { + checkmate::assert_string(dataset_name) + # assert x is performed by parents() + parents(x)[[dataset_name]] +} diff --git a/man/parent.Rd b/man/parent.Rd deleted file mode 100644 index a57663cb3..000000000 --- a/man/parent.Rd +++ /dev/null @@ -1,22 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys-parents.R -\name{parent} -\alias{parent} -\title{Getter and setter for specific parent} -\usage{ -parent(x, dataset_name) -} -\arguments{ -\item{x}{(\code{join_keys}) object to retrieve.} - -\item{dataset_name}{(\code{character(1)})} -} -\description{ -Getter and setter for specific parent -} -\examples{ -jk <- join_keys(join_key("ds1", "ds2", "key")) -parent(jk, "ds2") -parents(jk) <- list("ds2" = "ds1") -parent(jk, "ds2") -} diff --git a/man/parents.Rd b/man/parents.Rd index 2bbaa0f3b..0f7721f07 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -1,6 +1,7 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_keys-parents.R -\name{parents} +\name{parent} +\alias{parent} \alias{parents} \alias{parents.join_keys} \alias{parents.teal_data} @@ -9,6 +10,8 @@ \alias{parents<-.teal_data} \title{Getter and setter functions for parents attribute of \code{join_keys}} \usage{ +parent(x, dataset_name) + parents(x) \method{parents}{join_keys}(x) @@ -22,42 +25,83 @@ parents(x) <- value \method{parents}{teal_data}(x) <- value } \arguments{ -\item{x}{(\code{join_keys}) object to retrieve or manipulate.} +\item{x}{(\code{join_keys} or \code{teal_data}) object that contains "parents" information +to retrieve or manipulate.} + +\item{dataset_name}{(\code{character(1)}) Name of dataset to query on their parent.} \item{value}{(\code{list}) named list of character values} } \value{ +For \code{parent(x, dataset_name)} returns \code{NULL} if parent does not exist. + a list of \code{character} representing the parents. } \description{ -Getter and setter functions for parents attribute of \code{join_keys} +\code{parents()} facilitates the creation of dependencies between datasets by +assigning a parent-child relationship. + +Each element is defined by a list element, where \code{list("child" = "parent")}. } +\section{Methods (by class)}{ +\itemize{ +\item \code{parents(join_keys)}: Retrieves parents of \code{join_keys} object. + +\item \code{parents(teal_data)}: Retrieves parents of \code{join_keys} inside \code{teal_data} object. + +}} +\section{Functions}{ +\itemize{ +\item \code{parent()}: Getter for individual parent + +\item \code{parents(x) <- value}: Assignment of parents in \code{join_keys} object. + +\item \code{parents(join_keys) <- value}: Assignment of parents of \code{join_keys} object. + +\item \code{parents(teal_data) <- value}: Assignment of parents of \code{join_keys} inside \code{teal_data} object. + +}} \examples{ + +# Get individual parent --- + +parent(jk, "ds2") +parent(td, "ADTTE") +# Get parents of join_keys --- + jk <- default_cdisc_join_keys["ADEX"] parents(jk) -td <- cdisc_data( +# Get parents of join_keys inside teal_data object --- + +td <- teal_data( ADSL = teal.data::rADSL, - ADTTE = teal.data::rADTTE + ADTTE = teal.data::rADTTE, + ADRS = teal.data::rADRS, + join_keys = default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS")] ) parents(td) +# Assigment of parents --- + jk <- join_keys( join_key("ds1", "ds2", "id"), join_key("ds5", "ds6", "id"), join_key("ds7", "ds6", "id") ) -parents(jk) <- list() -parents(jk) <- list(ds1 = "ds2") -parents(jk)["ds5"] <- "ds6" -parents(jk)["ds6"] <- "ds7" -td <- cdisc_data( - ADSL = teal.data::rADSL, - ADTTE = teal.data::rADTTE, - ADRS = teal.data::rADRS -) +parents(jk) <- list(ds2 = "ds1") + +# Setting individual parent-child relationship + +parents(jk)["ds6"] <- "ds5" +parents(jk)["ds7"] <- "ds6" + +# Assigment of parents of join_keys inside teal_data object --- parents(td) <- list("ADTTE" = "ADSL") # replace existing parents(td)["ADRS"] <- "ADSL" # add new parent } +\seealso{ +\code{\link[=join_keys]{join_keys()}} +} From 4fe3597fee76db99f35b63ec90083b91e2cf34d5 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 17 Nov 2023 12:21:36 +0000 Subject: [PATCH 140/152] [skip actions] Roxygen Man Pages Auto Update --- man/parents.Rd | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/man/parents.Rd b/man/parents.Rd index 0f7721f07..a425430a2 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -1,17 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/join_keys-parents.R -\name{parent} -\alias{parent} +\name{parents} \alias{parents} \alias{parents.join_keys} \alias{parents.teal_data} \alias{parents<-} \alias{parents<-.join_keys} \alias{parents<-.teal_data} +\alias{parent} \title{Getter and setter functions for parents attribute of \code{join_keys}} \usage{ -parent(x, dataset_name) - parents(x) \method{parents}{join_keys}(x) @@ -23,19 +21,21 @@ parents(x) <- value \method{parents}{join_keys}(x) <- value \method{parents}{teal_data}(x) <- value + +parent(x, dataset_name) } \arguments{ \item{x}{(\code{join_keys} or \code{teal_data}) object that contains "parents" information to retrieve or manipulate.} -\item{dataset_name}{(\code{character(1)}) Name of dataset to query on their parent.} - \item{value}{(\code{list}) named list of character values} + +\item{dataset_name}{(\code{character(1)}) Name of dataset to query on their parent.} } \value{ -For \code{parent(x, dataset_name)} returns \code{NULL} if parent does not exist. - a list of \code{character} representing the parents. + +For \code{parent(x, dataset_name)} returns \code{NULL} if parent does not exist. } \description{ \code{parents()} facilitates the creation of dependencies between datasets by @@ -52,21 +52,16 @@ Each element is defined by a list element, where \code{list("child" = "parent")} }} \section{Functions}{ \itemize{ -\item \code{parent()}: Getter for individual parent - \item \code{parents(x) <- value}: Assignment of parents in \code{join_keys} object. \item \code{parents(join_keys) <- value}: Assignment of parents of \code{join_keys} object. \item \code{parents(teal_data) <- value}: Assignment of parents of \code{join_keys} inside \code{teal_data} object. +\item \code{parent()}: Getter for individual parent + }} \examples{ - -# Get individual parent --- - -parent(jk, "ds2") -parent(td, "ADTTE") # Get parents of join_keys --- jk <- default_cdisc_join_keys["ADEX"] @@ -101,6 +96,11 @@ parents(jk)["ds7"] <- "ds6" parents(td) <- list("ADTTE" = "ADSL") # replace existing parents(td)["ADRS"] <- "ADSL" # add new parent + +# Get individual parent --- + +parent(jk, "ds2") +parent(td, "ADTTE") } \seealso{ \code{\link[=join_keys]{join_keys()}} From 295f9721d4de8de7359539af11a84c0d15588b57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 13:51:59 +0100 Subject: [PATCH 141/152] docs: use Functions/Methods sections just as like @describeIn --- R/join_keys-extract.R | 6 +++--- R/join_keys.R | 8 ++++---- man/join_keys.Rd | 12 ++++++++++-- 3 files changed, 17 insertions(+), 9 deletions(-) diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index e7f80db52..011d287d3 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -1,7 +1,7 @@ #' @rdname join_keys #' @order 2 #' -#' @details +#' @section Functions: #' - `x[datanames]`: Returns a subset of the `join_keys` object for #' given `datanames`, including parent `datanames` and symmetric mirror keys between #' `datanames` in the result. @@ -118,7 +118,7 @@ #' @rdname join_keys #' @order 2 #' -#' @details +#' @section Functions: #' - `x[i, j] <- value`: Assignment of a key to pair `(i, j)`. #' - `x[i] <- value`: This (without `j` parameter) **is not** a supported #' operation for `join_keys`. @@ -175,7 +175,7 @@ #' @usage ## Prefered method is x[i, j] <- value #' x[[i]][[j]] <- value #' -#' @details +#' @section Functions: #' - `x[[i]][[j]] <- value`: It is equivalent as `x[i, j] <- value`. #' #' @export diff --git a/R/join_keys.R b/R/join_keys.R index d5e8c4726..e79103c07 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -14,10 +14,10 @@ #' Note that `join_keys` list is symmetrical, that is, when keys are set between `dat1` and `dat2` it #' is automatically mirrored between `dat2` and `dat1`. #' -#' @details -#' +#' @section Methods (by class): #' - `join_keys()`: Returns an empty `join_keys` object when called without arguments. -#' - `join_keys(x)`: Returns the `join_keys` object contained in `x` (if it contains one). +#' - `join_keys(join_keys)`: Returns itself. +#' - `join_keys(teal_data)`: Returns the `join_keys` object contained in `teal_data`. #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. #' #' @param ... (optional), when no argument is given the empty constructor is called. @@ -93,7 +93,7 @@ join_keys.TealData <- function(...) { #' @rdname join_keys #' @order 5 #' -#' @details +#' @section Functions: #' - `join_keys(x) <- value`: Assignment of the `join_keys` in object with `value`. #' `value` needs to be an object of class `join_keys` or `join_key_set`. #' diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 6eabbe1da..2bd16fcdb 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -79,12 +79,17 @@ itself (primary key) and with other datasets. Note that \code{join_keys} list is symmetrical, that is, when keys are set between \code{dat1} and \code{dat2} it is automatically mirrored between \code{dat2} and \code{dat1}. } -\details{ +\section{Methods (by class)}{ + \itemize{ \item \code{join_keys()}: Returns an empty \code{join_keys} object when called without arguments. -\item \code{join_keys(x)}: Returns the \code{join_keys} object contained in \code{x} (if it contains one). +\item \code{join_keys(join_keys)}: Returns itself. +\item \code{join_keys(teal_data)}: Returns the \code{join_keys} object contained in \code{teal_data}. \item \code{join_keys(...)}: Creates a new object with one or more \code{join_key_set} parameters. } +} + +\section{Functions}{ \itemize{ \item \code{x[datanames]}: Returns a subset of the \code{join_keys} object for @@ -94,6 +99,7 @@ given \code{datanames}, including parent \code{datanames} and symmetric mirror k including implicit keys inferred from their relationship with a parent. } + \itemize{ \item \code{x[i, j] <- value}: Assignment of a key to pair \verb{(i, j)}. \item \code{x[i] <- value}: This (without \code{j} parameter) \strong{is not} a supported @@ -102,11 +108,13 @@ operation for \code{join_keys}. such as a \code{teal_data} or \code{join_keys} itself. } + \itemize{ \item \code{join_keys(x) <- value}: Assignment of the \code{join_keys} in object with \code{value}. \code{value} needs to be an object of class \code{join_keys} or \code{join_key_set}. } } + \examples{ # Creating a new join keys ---- From a62c356e42ed4f6d0cf0f3dce054461e87db8b3c Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 14:14:05 +0100 Subject: [PATCH 142/152] 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) -# From 750e4898d0ea1641041a2e171e4d748b26197b6c Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 17 Nov 2023 14:38:07 +0100 Subject: [PATCH 143/152] lintr --- tests/testthat/test-join_keys-parents.R | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-join_keys-parents.R b/tests/testthat/test-join_keys-parents.R index d06281734..3244d60b1 100644 --- a/tests/testthat/test-join_keys-parents.R +++ b/tests/testthat/test-join_keys-parents.R @@ -1,7 +1,4 @@ -# ----------------------------------------------------------------------------- -# -# parents() -# +# get parents ----------------------------------------------------------------------------- testthat::test_that("parents will return empty list when empty/not set", { jk <- join_keys() testthat::expect_identical(parents(jk), list()) @@ -14,10 +11,7 @@ testthat::test_that("parents returns the same list as used in parents<-", { testthat::expect_identical(parents(jk), parents) }) -# ----------------------------------------------------------------------------- -# -# parents<- -# +# set parents ---------------------------------------------------------------------------- testthat::test_that("parents<- accepts a named list containing (non-empty, non-missing) character", { jk <- join_keys(join_key("a", "b", "test")) testthat::expect_no_error(parents(jk) <- list(b = "a")) @@ -74,7 +68,6 @@ testthat::test_that("parents<- single parent can be changed utilizing list funct testthat::test_that("parents<- fails when value isn't a list (non-empty, non-missing) character", { jk <- join_keys(join_key("a", "b", "test")) - # testthat::expect_error(parents(jk) <- list(b = character(0))) # todo: make an assert testthat::expect_error(parents(jk) <- list(b = 1)) testthat::expect_error(parents(jk) <- list(b = NA_character_)) testthat::expect_error(parents(jk) <- list(b = NULL)) From 5c375dab1f4b568064259fae00cfdf0b1d89ecd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 14:47:10 +0100 Subject: [PATCH 144/152] docs: documentaion suggestions by @chlebowa MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Aleksander Chlebowski <114988527+chlebowa@users.noreply.github.com> Signed-off-by: André Veríssimo <211358+averissimo@users.noreply.github.com> --- R/join_key.R | 10 ++++------ R/join_keys-extract.R | 5 +---- R/join_keys-parents.R | 2 +- R/join_keys.R | 9 ++++----- 4 files changed, 10 insertions(+), 16 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 1ce3dcaf9..201a8d446 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -5,13 +5,11 @@ #' @details `join_key()` will create a relationship for the variables on a pair #' of datasets. #' -#' @param dataset_1 (`character(1)`) dataset name. -#' @param dataset_2 (optional `character(1)`) other dataset name. In case it is omitted, then it -#' will create a primary key for `dataset_1`. +#' @param dataset_1,dataset_2 (`character(1)`) dataset names. If `dataset_2` is omitted, +#' a primary key for `dataset_1` is created. #' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` -#' with relationship to columns of `dataset_2` given by the elements in `keys`. -#' If `names(keys)` is `NULL` then the same column names are used for both `dataset_1` -#' and `dataset_2`. +#' corresponding to columns of `dataset_2` given by the elements of `keys`. +#' If unnamed, the same column names are used for both datasets. #' #' @return object of class `join_key_set` to be passed into `join_keys` function. #' diff --git a/R/join_keys-extract.R b/R/join_keys-extract.R index eeeb0fe42..3c398e706 100644 --- a/R/join_keys-extract.R +++ b/R/join_keys-extract.R @@ -8,10 +8,7 @@ #' - `x[i, j]`: Returns join keys between datasets `i` and `j`, #' including implicit keys inferred from their relationship with a parent. #' -#' @param i index specifying elements to extract or replace. Index should be a -#' a character vector, but it can also take numeric, logical, `NULL` or missing. -#' -#' @param j index specifying elements to extract or replace. Index should be a +#' @param i,j indices specifying elements to extract or replace. Index should be a #' a character vector, but it can also take numeric, logical, `NULL` or missing. #' #' @export diff --git a/R/join_keys-parents.R b/R/join_keys-parents.R index fd59e16b9..8737bb08e 100644 --- a/R/join_keys-parents.R +++ b/R/join_keys-parents.R @@ -47,7 +47,7 @@ parents.teal_data <- function(x) { #' @describeIn parents Assignment of parents in `join_keys` object. #' -#' @param value (`list`) named list of character values +#' @param value (`named list`) of `character` vectors. #' #' @export `parents<-` <- function(x, value) { diff --git a/R/join_keys.R b/R/join_keys.R index e79103c07..5df2ab63a 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -20,11 +20,10 @@ #' - `join_keys(teal_data)`: Returns the `join_keys` object contained in `teal_data`. #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. #' -#' @param ... (optional), when no argument is given the empty constructor is called. -#' Otherwise, when called with only one argument of type: `join_keys` or `teal_data` -#' it will return the `join_keys` of that object. -#' When called with 1 or more `join_key_set` it will create a new `join_keys` with -#' constructed from the arguments. +#' @param ... (optional)\cr +#' either `teal_data` or `join_keys` to extract `join_keys`, \cr +#' or any number of `join_key_set` objects to create `join_keys`, \cr +#' or nothing to create an empty `join_keys` #' #' @return `join_keys` object. #' From 6e786eb78fadb99b8a4c26219139034b1ed60eed Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 17 Nov 2023 13:49:12 +0000 Subject: [PATCH 145/152] [skip actions] Roxygen Man Pages Auto Update --- man/get_join_keys.Rd | 6 ++---- man/join_key.Rd | 11 ++++------- man/join_keys.Rd | 14 +++++--------- man/parents.Rd | 2 +- 4 files changed, 12 insertions(+), 21 deletions(-) diff --git a/man/get_join_keys.Rd b/man/get_join_keys.Rd index b724114c6..b6d1a63c6 100644 --- a/man/get_join_keys.Rd +++ b/man/get_join_keys.Rd @@ -12,10 +12,8 @@ get_join_keys(data, dataset_1, dataset_2 = NULL) <- value \arguments{ \item{data}{`` - object to extract the join keys} -\item{dataset_1}{(\code{character(1)}) dataset name.} - -\item{dataset_2}{(optional \code{character(1)}) other dataset name. In case it is omitted, then it -will create a primary key for \code{dataset_1}.} +\item{dataset_1, dataset_2}{(\code{character(1)}) dataset names. If \code{dataset_2} is omitted, +a primary key for \code{dataset_1} is created.} \item{value}{value to assign} } diff --git a/man/join_key.Rd b/man/join_key.Rd index 7fda787ab..3a65d0794 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -7,15 +7,12 @@ join_key(dataset_1, dataset_2 = dataset_1, keys) } \arguments{ -\item{dataset_1}{(\code{character(1)}) dataset name.} - -\item{dataset_2}{(optional \code{character(1)}) other dataset name. In case it is omitted, then it -will create a primary key for \code{dataset_1}.} +\item{dataset_1, dataset_2}{(\code{character(1)}) dataset names. If \code{dataset_2} is omitted, +a primary key for \code{dataset_1} is created.} \item{keys}{(optionally named \code{character}) where \code{names(keys)} are columns in \code{dataset_1} -with relationship to columns of \code{dataset_2} given by the elements in \code{keys}. -If \code{names(keys)} is \code{NULL} then the same column names are used for both \code{dataset_1} -and \code{dataset_2}.} +corresponding to columns of \code{dataset_2} given by the elements of \code{keys}. +If unnamed, the same column names are used for both datasets.} } \value{ object of class \code{join_key_set} to be passed into \code{join_keys} function. diff --git a/man/join_keys.Rd b/man/join_keys.Rd index 2bd16fcdb..a2836e86c 100644 --- a/man/join_keys.Rd +++ b/man/join_keys.Rd @@ -48,20 +48,16 @@ join_keys(x) <- value \method{print}{join_keys}(x, ...) } \arguments{ -\item{...}{(optional), when no argument is given the empty constructor is called. -Otherwise, when called with only one argument of type: \code{join_keys} or \code{teal_data} -it will return the \code{join_keys} of that object. -When called with 1 or more \code{join_key_set} it will create a new \code{join_keys} with -constructed from the arguments.} +\item{...}{(optional)\cr +either \code{teal_data} or \code{join_keys} to extract \code{join_keys}, \cr +or any number of \code{join_key_set} objects to create \code{join_keys}, \cr +or nothing to create an empty \code{join_keys}} \item{x}{(\code{join_keys}) empty object to set the new relationship pairs. \code{x} is typically an object of \code{join_keys} class. When called with the \code{join_keys(x)} or \code{join_keys(x) <- value} then it can also take a supported class (\code{teal_data}, \code{join_keys})} -\item{i}{index specifying elements to extract or replace. Index should be a -a character vector, but it can also take numeric, logical, \code{NULL} or missing.} - -\item{j}{index specifying elements to extract or replace. Index should be a +\item{i, j}{indices specifying elements to extract or replace. Index should be a a character vector, but it can also take numeric, logical, \code{NULL} or missing.} \item{value}{(\code{join_key_set} or list of \code{join_key_set}) relationship pairs to add diff --git a/man/parents.Rd b/man/parents.Rd index a425430a2..ace27bd46 100644 --- a/man/parents.Rd +++ b/man/parents.Rd @@ -28,7 +28,7 @@ parent(x, dataset_name) \item{x}{(\code{join_keys} or \code{teal_data}) object that contains "parents" information to retrieve or manipulate.} -\item{value}{(\code{list}) named list of character values} +\item{value}{(\verb{named list}) of \code{character} vectors.} \item{dataset_name}{(\code{character(1)}) Name of dataset to query on their parent.} } From 5d03b9c8798a2dbae492543be54c86f189f6972c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 14:57:39 +0100 Subject: [PATCH 146/152] docs: better explain inner behavior of join_key --- R/join_key.R | 4 ++++ man/join_key.Rd | 6 +++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/R/join_key.R b/R/join_key.R index 201a8d446..6de86fb67 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -9,8 +9,12 @@ #' a primary key for `dataset_1` is created. #' @param keys (optionally named `character`) where `names(keys)` are columns in `dataset_1` #' corresponding to columns of `dataset_2` given by the elements of `keys`. +#' #' If unnamed, the same column names are used for both datasets. #' +#' If any element of the `keys` vector is empty with a non-empty name, then the name is +#' used for both datasets. +#' #' @return object of class `join_key_set` to be passed into `join_keys` function. #' #' @seealso [join_keys()] diff --git a/man/join_key.Rd b/man/join_key.Rd index 3a65d0794..f31fe1f0f 100644 --- a/man/join_key.Rd +++ b/man/join_key.Rd @@ -12,7 +12,11 @@ a primary key for \code{dataset_1} is created.} \item{keys}{(optionally named \code{character}) where \code{names(keys)} are columns in \code{dataset_1} corresponding to columns of \code{dataset_2} given by the elements of \code{keys}. -If unnamed, the same column names are used for both datasets.} + +If unnamed, the same column names are used for both datasets. + +If any element of the \code{keys} vector is empty with a non-empty name, then the name is +used for both datasets.} } \value{ object of class \code{join_key_set} to be passed into \code{join_keys} function. From 54f72b0c3f7c6a5da7981fb4b80de1057df21542 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 15:02:43 +0100 Subject: [PATCH 147/152] cleanup: move error guard inside the if clause --- R/join_key.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/join_key.R b/R/join_key.R index 6de86fb67..29d90aaef 100644 --- a/R/join_key.R +++ b/R/join_key.R @@ -57,14 +57,14 @@ join_key <- function(dataset_1, dataset_2 = dataset_1, keys) { stopifnot(!is.null(names(keys))) stopifnot(!anyDuplicated(keys)) stopifnot(!anyDuplicated(names(keys))) + + if (dataset_1 == dataset_2 && any(names(keys) != keys)) { + stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed") + } } else { keys <- NULL } - if (dataset_1 == dataset_2 && any(names(keys) != keys)) { - stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed") - } - structure( list( structure( From 935aae4772f18fdc59a0a545399c4bdacd204699 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 18:25:56 +0100 Subject: [PATCH 148/152] feat: move compare function to exported all.equal --- NAMESPACE | 1 + R/join_keys-all.equal.R | 50 +++++++++++++++ man/all.equal.join_keys.Rd | 18 ++++++ tests/testthat/helper-compare.R | 37 ----------- tests/testthat/test-join_keys-all.equal.R | 76 +++++++++++++++++++++++ 5 files changed, 145 insertions(+), 37 deletions(-) create mode 100644 R/join_keys-all.equal.R create mode 100644 man/all.equal.join_keys.Rd delete mode 100644 tests/testthat/helper-compare.R create mode 100644 tests/testthat/test-join_keys-all.equal.R diff --git a/NAMESPACE b/NAMESPACE index b3c2deb23..68ca66642 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,7 @@ S3method("join_keys<-",teal_data) S3method("names<-",join_keys) S3method("parents<-",join_keys) S3method("parents<-",teal_data) +S3method(all,equal.join_keys) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(c,join_key_set) diff --git a/R/join_keys-all.equal.R b/R/join_keys-all.equal.R new file mode 100644 index 000000000..8c7f20c69 --- /dev/null +++ b/R/join_keys-all.equal.R @@ -0,0 +1,50 @@ +#' Test if Two Objects are (Nearly) Equal +#' +#' `all.equal(target, current)` is a utility to compare `join_keys` objects target +#' and current testing ‘near equality’. +#' +#' If they are different, comparison is still made to some extent, and a report +#' of the differences is returned. +#' Do not use all.equal directly in if expressions—either use isTRUE(all.equal(....)) +#' or identical if appropriate. +#' +#' @inheritParams base::all.equal +#' @param ... further arguments for different methods. Not used with `join_keys`. +#' +#' @details +#' The parents attribute comparison tolerates `NULL` and empty lists and will find +#' no difference. +#' +#' The list containing all the relationships is treated like a map and ignores +#' entries with `NULL` if they exist. +#' +#' @export +all.equal.join_keys <- function(target, current, ...) { + .as_map <- function(.x) { + old_attributes <- attributes(.x) + # Keep only non-list attributes + old_attributes[["names"]] <- NULL + old_attributes[["class"]] <- NULL + old_attributes[["__parents__"]] <- old_attributes[["__parents__"]] %||% list() + + attr(.x, "class") <- "list" + + # Remove nulls + is_null <- vapply(.x, is.null, logical(1)) + .x <- .x[!is_null] + + # Sort named components, preserving positions of unnamed + nx <- rlang::names2(.x) + is_named <- nx != "" + if (any(is_named)) { + idx <- seq_along(.x) + idx[is_named] <- idx[is_named][order(nx[is_named])] + .x <- .x[idx] + } + attributes(.x) <- utils::modifyList(old_attributes, attributes(.x) %||% list()) + .x + } + x <- .as_map(target) + y <- .as_map(current) + all.equal(x, y) +} diff --git a/man/all.equal.join_keys.Rd b/man/all.equal.join_keys.Rd new file mode 100644 index 000000000..efc9fbf37 --- /dev/null +++ b/man/all.equal.join_keys.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys-equal.R +\name{all.equal.join_keys} +\alias{all.equal.join_keys} +\title{Test if Two Objects are (Nearly) Equal} +\usage{ +\method{all}{equal.join_keys}(target, current, ...) +} +\arguments{ +\item{target}{\R object.} + +\item{current}{other \R object, to be compared with \code{target}.} + +\item{...}{further arguments for different methods. Not used with \code{join_keys}.} +} +\description{ +Test if Two Objects are (Nearly) Equal +} diff --git a/tests/testthat/helper-compare.R b/tests/testthat/helper-compare.R deleted file mode 100644 index 4062875f4..000000000 --- a/tests/testthat/helper-compare.R +++ /dev/null @@ -1,37 +0,0 @@ -#' Compare 2 join keys by ordering names and removing NULL elements -#' -#' Code borrowed from waldo. This should be removed in favor of using testthat 3e -#' that has an option to compare lists as maps. -#' -#' `expect_identical(x, y, list_as_map = TRUE)` -#' -#' note: this needs to be located in an environment that contains `testthat` -#' namespace, as it extends a S3 method of that package. -#' -#' @inheritParams testthat::compare -#' -#' @keywords internal -compare.join_keys <- function(x, y, ...) { # nolint: object_name_linter - as_map <- function(x) { - attr(x, "extra_class") <- class(x) - attr(x, "class") <- "list" - - # Remove nulls - is_null <- vapply(x, is.null, logical(1)) - x <- x[!is_null] - - # Sort named components, preserving positions of unnamed - nx <- rlang::names2(x) - is_named <- nx != "" - if (any(is_named)) { - idx <- seq_along(x) - idx[is_named] <- idx[is_named][order(nx[is_named])] - x <- x[idx] - } - - x - } - - compare(as_map(x), as_map(y)) -} -.S3method("compare", "join_keys", compare.join_keys) diff --git a/tests/testthat/test-join_keys-all.equal.R b/tests/testthat/test-join_keys-all.equal.R new file mode 100644 index 000000000..d83734af3 --- /dev/null +++ b/tests/testthat/test-join_keys-all.equal.R @@ -0,0 +1,76 @@ +test_that("all.equal.join_keys identical join_keys without parents are not identical, but treated as equal", { + jk1 <- join_keys( + join_key("d1", "d2", c(a = "b")) + ) + jk2 <- join_keys( + join_key("d2", "d1", c(b = "a")) + ) + + testthat::expect_failure( + testthat::expect_identical( + jk1, + jk2 + ) + ) + + testthat::expect_true( + all.equal.join_keys( + jk1, + jk2 + ) + ) +}) + +test_that("all.equal.join_keys identical join_keys with parents are treated as equal", { + jk1 <- join_keys( + join_key("d1", "d2", c(a = "b")) + ) + parents(jk1) <- list("d2" = "d1") + jk2 <- join_keys( + join_key("d2", "d1", c(b = "a")) + ) + parents(jk2) <- list("d2" = "d1") + + testthat::expect_true( + all.equal.join_keys( + jk1, + jk2 + ) + ) +}) + +test_that("all.equal.join_keys 2 objects with different parents return error", { + jk1 <- join_keys( + join_key("d1", "d2", c(a = "b")) + ) + parents(jk1) <- list("d2" = "d1") + jk2 <- join_keys( + join_key("d2", "d1", c(b = "a")) + ) + + testthat::expect_type( + all.equal.join_keys( + jk1, + jk2 + ), + "character" + ) +}) + +test_that("all.equal.join_keys 2 objects with empty parents (one NULL and another empty list) are treated as equal", { + jk1 <- join_keys( + join_key("d1", "d2", c(a = "b")) + ) + + jk2 <- join_keys( + join_key("d2", "d1", c(b = "a")) + ) + attr(jk2, "__parents__") <- NULL + + testthat::expect_true( + all.equal.join_keys( + jk1, + jk2 + ) + ) +}) From 17e23b862fa0fe1330f8c81f8952ac824342f1c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 18:34:46 +0100 Subject: [PATCH 149/152] fix: add minor restriction to all.equal --- R/join_keys-all.equal.R | 5 ++++- _pkgdown.yml | 1 + man/all.equal.join_keys.Rd | 20 ++++++++++++++++++-- 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/R/join_keys-all.equal.R b/R/join_keys-all.equal.R index 8c7f20c69..6a760aae4 100644 --- a/R/join_keys-all.equal.R +++ b/R/join_keys-all.equal.R @@ -1,7 +1,7 @@ #' Test if Two Objects are (Nearly) Equal #' #' `all.equal(target, current)` is a utility to compare `join_keys` objects target -#' and current testing ‘near equality’. +#' and current testing `near equality`. #' #' If they are different, comparison is still made to some extent, and a report #' of the differences is returned. @@ -18,6 +18,8 @@ #' The list containing all the relationships is treated like a map and ignores #' entries with `NULL` if they exist. #' +#' @seealso [base::all.equal()] +#' #' @export all.equal.join_keys <- function(target, current, ...) { .as_map <- function(.x) { @@ -25,6 +27,7 @@ all.equal.join_keys <- function(target, current, ...) { # Keep only non-list attributes old_attributes[["names"]] <- NULL old_attributes[["class"]] <- NULL + old_attributes[["original_class"]] <- class(.x) old_attributes[["__parents__"]] <- old_attributes[["__parents__"]] %||% list() attr(.x, "class") <- "list" diff --git a/_pkgdown.yml b/_pkgdown.yml index 4f3a40d7e..967f4a8d2 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -107,6 +107,7 @@ reference: - title: Helpers desc: Other useful functions for users and developers. contents: + - all.equal.join_keys - datanames - datanames<- - default_cdisc_join_keys diff --git a/man/all.equal.join_keys.Rd b/man/all.equal.join_keys.Rd index efc9fbf37..9ca736e32 100644 --- a/man/all.equal.join_keys.Rd +++ b/man/all.equal.join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys-equal.R +% Please edit documentation in R/join_keys-all.equal.R \name{all.equal.join_keys} \alias{all.equal.join_keys} \title{Test if Two Objects are (Nearly) Equal} @@ -14,5 +14,21 @@ \item{...}{further arguments for different methods. Not used with \code{join_keys}.} } \description{ -Test if Two Objects are (Nearly) Equal +\code{all.equal(target, current)} is a utility to compare \code{join_keys} objects target +and current testing \verb{near equality}. +} +\details{ +If they are different, comparison is still made to some extent, and a report +of the differences is returned. +Do not use all.equal directly in if expressions—either use isTRUE(all.equal(....)) +or identical if appropriate. + +The parents attribute comparison tolerates \code{NULL} and empty lists and will find +no difference. + +The list containing all the relationships is treated like a map and ignores +entries with \code{NULL} if they exist. +} +\seealso{ +\code{\link[base:all.equal]{base::all.equal()}} } From fc173ceed4bebf719716b9402e79d75ee0fc621f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 18:45:37 +0100 Subject: [PATCH 150/152] fix: add merging of parents and fix test by using equal --- R/join_keys-c.R | 29 +++++- R/join_keys.R | 3 +- man/dot-merge_parents.Rd | 18 ++++ tests/testthat/test-join_keys-c.R | 128 ++++++++++++++++++++++++ tests/testthat/test-join_keys-extract.R | 14 +-- tests/testthat/test-join_keys.R | 3 +- 6 files changed, 184 insertions(+), 11 deletions(-) create mode 100644 man/dot-merge_parents.Rd diff --git a/R/join_keys-c.R b/R/join_keys-c.R index cf4db5323..2ff93e8e7 100644 --- a/R/join_keys-c.R +++ b/R/join_keys-c.R @@ -19,16 +19,23 @@ c.join_keys <- function(...) { checkmate::assert_multi_class(join_keys_obj, classes = c("join_keys", "join_key_set")) checkmate::assert_list(x, types = c("join_keys", "join_key_set")) + # Ensure base object has correct class when called from c.join_key_set + join_keys_obj <- join_keys(join_keys_obj) + x_merged <- Reduce( init = join_keys(), x = x, f = function(.x, .y) { assert_compatible_keys2(.x, .y) - utils::modifyList(.x, .y, keep.null = FALSE) + out <- utils::modifyList(.x, .y, keep.null = FALSE) + attr(out, "__parents__") <- .merge_parents(.x, .y) + out } ) - utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) + out <- utils::modifyList(join_keys_obj, x_merged, keep.null = FALSE) + attr(out, "__parents__") <- .merge_parents(join_keys_obj, x_merged) + out } #' @rdname join_keys @@ -48,3 +55,21 @@ c.join_keys <- function(...) { c.join_key_set <- function(...) { c.join_keys(...) } + +#' Merge parents for 2 `join_keys` object +#' +#' @param x,y (`join_keys`) objects to merge their parents +#' +#' @return a list with parents merged from 2 `join_keys`. Not the object itself. +#' @keywords internal +.merge_parents <- function(x, y) { + x_parent <- list() + y_parent <- list() + if (length(attr(x, "__parents__"))) { + x_parent <- attr(x, "__parents__") + } + if (length(attr(y, "__parents__"))) { + y_parent <- attr(y, "__parents__") + } + utils::modifyList(x_parent, y_parent, keep.null = FALSE) +} diff --git a/R/join_keys.R b/R/join_keys.R index 5df2ab63a..8b962c07e 100644 --- a/R/join_keys.R +++ b/R/join_keys.R @@ -156,6 +156,7 @@ join_keys.TealData <- function(...) { new_join_keys <- function() { structure( list(), - class = c("join_keys", "list") + class = c("join_keys", "list"), + "__parents__" = list() ) } diff --git a/man/dot-merge_parents.Rd b/man/dot-merge_parents.Rd new file mode 100644 index 000000000..f558f28e2 --- /dev/null +++ b/man/dot-merge_parents.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/join_keys-c.R +\name{.merge_parents} +\alias{.merge_parents} +\title{Merge parents for 2 \code{join_keys} object} +\usage{ +.merge_parents(x, y) +} +\arguments{ +\item{x, y}{(\code{join_keys}) objects to merge their parents} +} +\value{ +a list with parents merged from 2 \code{join_keys}. Not the object itself. +} +\description{ +Merge parents for 2 \code{join_keys} object +} +\keyword{internal} diff --git a/tests/testthat/test-join_keys-c.R b/tests/testthat/test-join_keys-c.R index 846be3fce..234a8fe69 100644 --- a/tests/testthat/test-join_keys-c.R +++ b/tests/testthat/test-join_keys-c.R @@ -10,6 +10,19 @@ testthat::test_that("c.join_keys joins join_keys object with join_key objects", ) }) +testthat::test_that("c.join_key_set joins join_key_set object with join_keys objects", { + obj <- join_key("a", "a", "aa") + obj <- c(obj, join_key("b", "b", "bb"), join_key("c", "c", "cc")) + testthat::expect_identical( + obj, + join_keys( + join_key("a", "a", "aa"), + join_key("b", "b", "bb"), + join_key("c", "c", "cc") + ) + ) +}) + testthat::test_that("c.join_keys duplicated keys are ignored", { obj <- join_keys() obj <- c(obj, join_key("a", "a", "aa"), join_key("a", "a", "aa")) @@ -96,3 +109,118 @@ testthat::test_that("c.join_key_set throws on conflicting join_keys_set objects" "cannot specify multiple different join keys between datasets" ) }) + +testthat::test_that("c.join_key_set merges with empty and non-empty parents", { + jk1 <- join_keys( + join_key("d1", "d1", "a") + ) + + jk2 <- join_keys( + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d4", "d3", "cd") + ) + parents(jk2) <- list(d3 = "d4") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d3", "d4", "cd") + ) + parents(expected) <- list(d3 = "d4") + + testthat::expect_identical( + c(jk1, jk2), + expected + ) + + testthat::expect_equal( + c(jk2, jk1), + expected + ) +}) + +testthat::test_that("c.join_key_set merges parents also", { + jk1 <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d1", "d2", "ab") + ) + parents(jk1) <- list(d1 = "d2") + jk2 <- join_key("d3", "d3", "c") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d1", "d2", "ab"), + join_key("d3", "d3", "c") + ) + parents(expected) <- list(d1 = "d2") + + testthat::expect_equal( + c(jk2, jk1), + expected + ) +}) + +testthat::test_that("c.join_keys merges parents also", { + jk1 <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d1", "d2", "ab") + ) + parents(jk1) <- list(d1 = "d2") + jk2 <- join_keys( + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d4", "d3", "cd") + ) + parents(jk2) <- list(d3 = "d4") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d1", "d2", "ab"), + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d3", "d4", "cd") + ) + parents(expected) <- list(d1 = "d2", d3 = "d4") + + testthat::expect_identical( + c(jk1, jk2), + expected + ) +}) + +testthat::test_that("c.join_keys merges existing parents are overwritten", { + jk1 <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d1", "d2", "ab"), + join_key("d4", "d3", "cd") + ) + parents(jk1) <- list(d1 = "d2", d3 = "d4") + + jk2 <- join_keys( + join_key("d2", "d2", "b"), + join_key("d3", "d2", "cb") + ) + parents(jk2) <- list(d3 = "d2") + + expected <- join_keys( + join_key("d1", "d1", "a"), + join_key("d2", "d2", "b"), + join_key("d3", "d3", "c"), + join_key("d4", "d4", "d"), + join_key("d1", "d2", "ab"), + join_key("d4", "d3", "cd"), + join_key("d3", "d2", "cb") + ) + parents(expected) <- list(d1 = "d2", d3 = "d2") + + testthat::expect_identical(c(jk1, jk2), expected) +}) diff --git a/tests/testthat/test-join_keys-extract.R b/tests/testthat/test-join_keys-extract.R index 200dc5146..9f1a3887e 100644 --- a/tests/testthat/test-join_keys-extract.R +++ b/tests/testthat/test-join_keys-extract.R @@ -20,7 +20,7 @@ testthat::test_that("join_keys[i] subsets join_keys object to specific datasets" join_key("d2", "d2", "b"), join_key("d3", "d3", "c") ) - testthat::expect_identical( + testthat::expect_equal( my_keys[c("d1", "d2")], join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) @@ -32,7 +32,7 @@ testthat::test_that("join_keys[i] returns join_keys object with keys for given i join_key("d2", "d2", "b"), join_key("d3", "d3", "c") ) - testthat::expect_identical( + testthat::expect_equal( my_keys[c(1, 2)], join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) @@ -44,7 +44,7 @@ testthat::test_that("join_keys[-i] drops keys for given index", { join_key("d2", "d2", "b"), join_key("d3", "d3", "c") ) - testthat::expect_identical( + testthat::expect_equal( my_keys[-3], join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) @@ -101,7 +101,7 @@ testthat::test_that("join_keys[i] ignores duplicate indexes - return only first join_key("d2", "d2", "b"), join_key("d3", "d2", "b") ) - testthat::expect_identical( + testthat::expect_equal( jk[c("d1", "d2", "d1")], join_keys(join_key("d1", "d1", "a"), join_key("d2", "d2", "b")) ) @@ -304,7 +304,7 @@ testthat::test_that("[[<-.join_keys doesn't accepts other list than named contai testthat::test_that("[[<-.join_keys adds join_keys specified as named list to the list of keys", { jk <- join_keys() jk[["d1"]] <- list(d1 = "a") - testthat::expect_identical(jk, join_keys(join_key("d1", "d1", "a"))) + testthat::expect_equal(jk, join_keys(join_key("d1", "d1", "a"))) }) testthat::test_that("[[<-.join_keys assigning NULL drops a key", { @@ -317,7 +317,7 @@ testthat::test_that("[[<-.join_keys adds symmetrical change to the foreign datas jk <- join_keys() jk[["d1"]][["d2"]] <- c("A" = "B", "C" = "C") - testthat::expect_identical( + testthat::expect_equal( jk, join_keys( join_key("d1", "d2", c("A" = "B", "C" = "C")), @@ -422,5 +422,5 @@ testthat::test_that("[[<-.join_keys fails when provided foreign key pairs for sa testthat::test_that("[[<-.join_keys allows when provided foreign key pairs for same datasets and same keys", { jk <- join_keys() testthat::expect_silent(jk[["ds1"]] <- list(ds2 = "new", ds2 = c("new" = "new"))) - testthat::expect_identical(jk, join_keys(join_key("ds1", "ds2", "new"))) + testthat::expect_equal(jk, join_keys(join_key("ds1", "ds2", "new"))) }) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 0b303ba2a..7e8639e42 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -22,7 +22,8 @@ testthat::test_that("join_keys is a collection of join_key, ie named list with n jk, structure(c(key1, key2), class = c("join_keys", "list")) ) - testthat::expect_identical( + + testthat::expect_equal( jk, structure( list( From b3c25eb97f826f13b864ec2741ac803fa641f9fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Fri, 17 Nov 2023 21:29:17 +0100 Subject: [PATCH 151/152] docs: fix unquoted code --- R/join_keys-all.equal.R | 2 +- man/all.equal.join_keys.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/join_keys-all.equal.R b/R/join_keys-all.equal.R index 6a760aae4..0a7bc6c0b 100644 --- a/R/join_keys-all.equal.R +++ b/R/join_keys-all.equal.R @@ -5,7 +5,7 @@ #' #' If they are different, comparison is still made to some extent, and a report #' of the differences is returned. -#' Do not use all.equal directly in if expressions—either use isTRUE(all.equal(....)) +#' Do not use all.equal directly in if expressions—either use `isTRUE(all.equal(....))` #' or identical if appropriate. #' #' @inheritParams base::all.equal diff --git a/man/all.equal.join_keys.Rd b/man/all.equal.join_keys.Rd index 9ca736e32..9fe9bb80c 100644 --- a/man/all.equal.join_keys.Rd +++ b/man/all.equal.join_keys.Rd @@ -20,7 +20,7 @@ and current testing \verb{near equality}. \details{ If they are different, comparison is still made to some extent, and a report of the differences is returned. -Do not use all.equal directly in if expressions—either use isTRUE(all.equal(....)) +Do not use all.equal directly in if expressions—either use \code{isTRUE(all.equal(....))} or identical if appropriate. The parents attribute comparison tolerates \code{NULL} and empty lists and will find From cd4b2ca22d240bd8b5d4cf62fe58b92aa47f2c41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andr=C3=A9=20Ver=C3=ADssimo?= <211358+averissimo@users.noreply.github.com> Date: Sun, 19 Nov 2023 23:40:26 +0100 Subject: [PATCH 152/152] fix: brings all.equal back to being private --- NAMESPACE | 1 - R/join_keys-all.equal.R | 53 ---------------- R/testhat-helpers.R | 56 +++++++++++++++++ _pkgdown.yml | 1 - man/all.equal.join_keys.Rd | 3 +- tests/testthat/helper-all.equal.R | 2 + tests/testthat/test-join_keys-all.equal.R | 76 ----------------------- tests/testthat/test-join_keys-parents.R | 11 ++++ tests/testthat/test-join_keys.R | 15 ++++- 9 files changed, 85 insertions(+), 133 deletions(-) delete mode 100644 R/join_keys-all.equal.R create mode 100644 tests/testthat/helper-all.equal.R delete mode 100644 tests/testthat/test-join_keys-all.equal.R diff --git a/NAMESPACE b/NAMESPACE index 68ca66642..b3c2deb23 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,7 +8,6 @@ S3method("join_keys<-",teal_data) S3method("names<-",join_keys) S3method("parents<-",join_keys) S3method("parents<-",teal_data) -S3method(all,equal.join_keys) S3method(as_cdisc,TealDataset) S3method(as_cdisc,TealDatasetConnector) S3method(c,join_key_set) diff --git a/R/join_keys-all.equal.R b/R/join_keys-all.equal.R deleted file mode 100644 index 0a7bc6c0b..000000000 --- a/R/join_keys-all.equal.R +++ /dev/null @@ -1,53 +0,0 @@ -#' Test if Two Objects are (Nearly) Equal -#' -#' `all.equal(target, current)` is a utility to compare `join_keys` objects target -#' and current testing `near equality`. -#' -#' If they are different, comparison is still made to some extent, and a report -#' of the differences is returned. -#' Do not use all.equal directly in if expressions—either use `isTRUE(all.equal(....))` -#' or identical if appropriate. -#' -#' @inheritParams base::all.equal -#' @param ... further arguments for different methods. Not used with `join_keys`. -#' -#' @details -#' The parents attribute comparison tolerates `NULL` and empty lists and will find -#' no difference. -#' -#' The list containing all the relationships is treated like a map and ignores -#' entries with `NULL` if they exist. -#' -#' @seealso [base::all.equal()] -#' -#' @export -all.equal.join_keys <- function(target, current, ...) { - .as_map <- function(.x) { - old_attributes <- attributes(.x) - # Keep only non-list attributes - old_attributes[["names"]] <- NULL - old_attributes[["class"]] <- NULL - old_attributes[["original_class"]] <- class(.x) - old_attributes[["__parents__"]] <- old_attributes[["__parents__"]] %||% list() - - attr(.x, "class") <- "list" - - # Remove nulls - is_null <- vapply(.x, is.null, logical(1)) - .x <- .x[!is_null] - - # Sort named components, preserving positions of unnamed - nx <- rlang::names2(.x) - is_named <- nx != "" - if (any(is_named)) { - idx <- seq_along(.x) - idx[is_named] <- idx[is_named][order(nx[is_named])] - .x <- .x[idx] - } - attributes(.x) <- utils::modifyList(old_attributes, attributes(.x) %||% list()) - .x - } - x <- .as_map(target) - y <- .as_map(current) - all.equal(x, y) -} diff --git a/R/testhat-helpers.R b/R/testhat-helpers.R index 701f295d1..efc7746fd 100644 --- a/R/testhat-helpers.R +++ b/R/testhat-helpers.R @@ -38,3 +38,59 @@ local_cdisc_data_mixed_call <- function(check = TRUE, join_keys1 = join_keys()) cdisc_data(adsl, adtte, adae_rdc, check = check, join_keys = join_keys1) } + +#' Test if Two Objects are (Nearly) Equal +#' +#' `all.equal(target, current)` is a utility to compare `join_keys` objects target +#' and current testing `near equality`. +#' +#' If they are different, comparison is still made to some extent, and a report +#' of the differences is returned. +#' Do not use all.equal directly in if expressions—either use `isTRUE(all.equal(....))` +#' or identical if appropriate. +#' +#' @inheritParams base::all.equal +#' @param ... further arguments for different methods. Not used with `join_keys`. +#' +#' @details +#' The parents attribute comparison tolerates `NULL` and empty lists and will find +#' no difference. +#' +#' The list containing all the relationships is treated like a map and ignores +#' entries with `NULL` if they exist. +#' +#' @seealso [base::all.equal()] +#' @keywords internal +all.equal.join_keys <- function(target, current, ...) { + .as_map <- function(.x) { + old_attributes <- attributes(.x) + # Keep only non-list attributes + old_attributes[["names"]] <- NULL + old_attributes[["original_class"]] <- old_attributes[["class"]] + old_attributes[["class"]] <- NULL + old_attributes[["__parents__"]] <- if (!length(old_attributes[["__parents__"]])) { + list() + } else { + old_attributes[["__parents__"]][order(names(old_attributes[["__parents__"]]))] + } + attr(.x, "class") <- "list" + + # Remove nulls + .x <- Filter(Negate(is.null), .x) + + # Sort named components, preserving positions of unnamed + nx <- rlang::names2(.x) + is_named <- nx != "" + if (any(is_named)) { + idx <- seq_along(.x) + idx[is_named] <- idx[is_named][order(nx[is_named])] + .x <- .x[idx] + } + attributes(.x) <- utils::modifyList(old_attributes, attributes(.x) %||% list()) + .x + } + x <- .as_map(target) + y <- .as_map(current) + print("inner") + all.equal(x, y) +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 967f4a8d2..4f3a40d7e 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -107,7 +107,6 @@ reference: - title: Helpers desc: Other useful functions for users and developers. contents: - - all.equal.join_keys - datanames - datanames<- - default_cdisc_join_keys diff --git a/man/all.equal.join_keys.Rd b/man/all.equal.join_keys.Rd index 9fe9bb80c..fb68b3941 100644 --- a/man/all.equal.join_keys.Rd +++ b/man/all.equal.join_keys.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/join_keys-all.equal.R +% Please edit documentation in R/testhat-helpers.R \name{all.equal.join_keys} \alias{all.equal.join_keys} \title{Test if Two Objects are (Nearly) Equal} @@ -32,3 +32,4 @@ entries with \code{NULL} if they exist. \seealso{ \code{\link[base:all.equal]{base::all.equal()}} } +\keyword{internal} diff --git a/tests/testthat/helper-all.equal.R b/tests/testthat/helper-all.equal.R new file mode 100644 index 000000000..556f4c29d --- /dev/null +++ b/tests/testthat/helper-all.equal.R @@ -0,0 +1,2 @@ +# covr package doesn't detect the .S3method if it is declared within R/ folder +.S3method("all.equal", "join_keys", all.equal.join_keys) diff --git a/tests/testthat/test-join_keys-all.equal.R b/tests/testthat/test-join_keys-all.equal.R deleted file mode 100644 index d83734af3..000000000 --- a/tests/testthat/test-join_keys-all.equal.R +++ /dev/null @@ -1,76 +0,0 @@ -test_that("all.equal.join_keys identical join_keys without parents are not identical, but treated as equal", { - jk1 <- join_keys( - join_key("d1", "d2", c(a = "b")) - ) - jk2 <- join_keys( - join_key("d2", "d1", c(b = "a")) - ) - - testthat::expect_failure( - testthat::expect_identical( - jk1, - jk2 - ) - ) - - testthat::expect_true( - all.equal.join_keys( - jk1, - jk2 - ) - ) -}) - -test_that("all.equal.join_keys identical join_keys with parents are treated as equal", { - jk1 <- join_keys( - join_key("d1", "d2", c(a = "b")) - ) - parents(jk1) <- list("d2" = "d1") - jk2 <- join_keys( - join_key("d2", "d1", c(b = "a")) - ) - parents(jk2) <- list("d2" = "d1") - - testthat::expect_true( - all.equal.join_keys( - jk1, - jk2 - ) - ) -}) - -test_that("all.equal.join_keys 2 objects with different parents return error", { - jk1 <- join_keys( - join_key("d1", "d2", c(a = "b")) - ) - parents(jk1) <- list("d2" = "d1") - jk2 <- join_keys( - join_key("d2", "d1", c(b = "a")) - ) - - testthat::expect_type( - all.equal.join_keys( - jk1, - jk2 - ), - "character" - ) -}) - -test_that("all.equal.join_keys 2 objects with empty parents (one NULL and another empty list) are treated as equal", { - jk1 <- join_keys( - join_key("d1", "d2", c(a = "b")) - ) - - jk2 <- join_keys( - join_key("d2", "d1", c(b = "a")) - ) - attr(jk2, "__parents__") <- NULL - - testthat::expect_true( - all.equal.join_keys( - jk1, - jk2 - ) - ) -}) diff --git a/tests/testthat/test-join_keys-parents.R b/tests/testthat/test-join_keys-parents.R index 3244d60b1..8c8a44502 100644 --- a/tests/testthat/test-join_keys-parents.R +++ b/tests/testthat/test-join_keys-parents.R @@ -90,3 +90,14 @@ testthat::test_that("parents<- sets parent datasets to join_keys kept in teal_da parents(td) <- list(b = "a") testthat::expect_identical(parents(td), list(b = "a")) }) + +testthat::test_that("parents<- setting parents changes join_keys object", { + jk <- join_keys(join_key("a", "b", "ab")) + jk2 <- jk + parents <- list(b = "a") + parents(jk) <- parents + + testthat::expect_failure(testthat::expect_identical(jk, jk2)) + # Relaxed comparison also fails + testthat::expect_failure(testthat::expect_equal(jk, jk2)) +}) diff --git a/tests/testthat/test-join_keys.R b/tests/testthat/test-join_keys.R index 7e8639e42..2bf831b51 100644 --- a/tests/testthat/test-join_keys.R +++ b/tests/testthat/test-join_keys.R @@ -23,13 +23,26 @@ testthat::test_that("join_keys is a collection of join_key, ie named list with n structure(c(key1, key2), class = c("join_keys", "list")) ) - testthat::expect_equal( + testthat::expect_identical( jk, structure( list( d1 = list(d1 = c(test = "test")), d2 = list(d2 = c(test = "test")) ), + class = c("join_keys", "list"), + "__parents__" = list() + ) + ) + + # Relaxed comparison (not ordered and without need of empty attributes) + testthat::expect_equal( + jk, + structure( + list( + d2 = list(d2 = c(test = "test")), + d1 = list(d1 = c(test = "test")) + ), class = c("join_keys", "list") ) )