| 1 |
- #' @rdname join_keys+ #' Test if two objects are (nearly) equal |
||
| 2 |
- #' @order 2+ #' |
||
| 3 |
- #'+ #' `all.equal(target, current)` is a utility to compare `join_keys` objects target |
||
| 4 |
- #' @section Functions:+ #' and current testing `near equality`. |
||
| 5 |
- #' - `x[datanames]`: Returns a subset of the `join_keys` object for+ #' |
||
| 6 |
- #' given `datanames`, including parent `datanames` and symmetric mirror keys between+ #' If they are different, comparison is still made to some extent, and a report |
||
| 7 |
- #' `datanames` in the result.+ #' of the differences is returned. |
||
| 8 |
- #' - `x[i, j]`: Returns join keys between datasets `i` and `j`,+ #' Do not use `all.equal` directly in if expressions—either use `isTRUE(all.equal(....))` |
||
| 9 |
- #' including implicit keys inferred from their relationship with a parent.+ #' or identical if appropriate. |
||
| 11 |
- #' @param i,j indices specifying elements to extract or replace. Index should be a+ #' The parents attribute comparison tolerates `NULL` and empty lists and will find |
||
| 12 |
- #' a character vector, but it can also take numeric, logical, `NULL` or missing.+ #' no difference. |
||
| 14 |
- #' @export+ #' The list containing all the relationships is treated like a map and ignores |
||
| 15 |
- #'+ #' entries with `NULL` if they exist. |
||
| 16 |
- #' @examples+ #' |
||
| 17 |
- #' # Getter for join_keys ---+ #' @inheritParams base::all.equal |
||
| 18 |
- #'+ #' @param ... further arguments for different methods. Not used with `join_keys`. |
||
| 19 |
- #' jk["ds1", "ds2"]+ #' |
||
| 20 |
- #'+ #' @seealso [base::all.equal()] |
||
| 21 |
- #' # Subsetting join_keys ----+ #' @keywords internal |
||
| 23 |
- #' jk["ds1"]+ all.equal.join_keys <- function(target, current, ...) {
|
||
| 24 | -+ | 21x |
- #' jk[1:2]+ .as_map <- function(.x) {
|
| 25 | -+ | 42x |
- #' jk[c("ds1", "ds2")]
+ old_attributes <- attributes(.x) |
| 26 |
- #'+ # Keep only non-list attributes |
||
| 27 | -+ | 42x |
- `[.join_keys` <- function(x, i, j) {
+ old_attributes[["names"]] <- NULL |
| 28 | -35x | +42x |
- if (missing(i) && missing(j)) {
+ old_attributes[["original_class"]] <- old_attributes[["class"]] |
| 29 | -+ | 42x |
- # because:+ old_attributes[["class"]] <- NULL |
| 30 | -+ | 42x |
- # - list(a = 1)[] returns list(a = 1)+ old_attributes[["parents"]] <- if (!length(old_attributes[["parents"]])) {
|
| 31 | -+ | 18x |
- # - data.frame(a = 1)[] returns data.frame(a = 1)+ list() |
| 32 | -1x | +
- return(x)+ } else {
|
|
| 33 | -34x | +24x |
- } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) {
+ old_attributes[["parents"]][order(names(old_attributes[["parents"]]))] |
| 34 |
- # because list(a = 1)[NULL] returns NULL+ } |
||
| 35 | -+ | 42x |
- # data.frame(a = 1)[NULL, NULL] returns data.frame(+ attr(.x, "class") <- "list" |
| 36 | -2x | +
- return(join_keys())+ |
|
| 37 | -32x | +
- } else if (!missing(i) && !missing(j)) {
+ # Remove nulls |
|
| 38 | -+ | 42x |
- if (+ .x <- Filter(Negate(is.null), .x) |
| 39 | -8x | +
- !any(+ |
|
| 40 | -8x | +
- checkmate::test_string(i),+ # Sort named components, preserving positions of unnamed |
|
| 41 | -8x | +42x |
- checkmate::test_number(i),+ nx <- rlang::names2(.x) |
| 42 | -8x | +42x |
- checkmate::test_logical(i, len = length(x)) && sum(j) == 1+ is_named <- nx != "" |
| 43 | -+ | 42x |
- ) ||+ if (any(is_named)) {
|
| 44 | -8x | +42x |
- !any(+ idx <- seq_along(.x) |
| 45 | -8x | +42x |
- checkmate::test_string(j),+ idx[is_named] <- idx[is_named][order(nx[is_named])] |
| 46 | -8x | +42x |
- checkmate::test_number(j),+ .x <- .x[idx] |
| 47 | -8x | +
- checkmate::test_logical(j, len = length(x)) && sum(j) == 1+ } |
|
| 48 | -+ | 42x |
- )+ new_attributes <- if (is.null(attributes(.x))) list() else attributes(.x) |
| 49 | -+ | 42x |
- ) {
+ attributes(.x) <- utils::modifyList(old_attributes, new_attributes) |
| 50 | -1x | +42x |
- stop(+ .x |
| 51 | -1x | +
- "join_keys[i, j] - Can't extract keys for multiple pairs.",+ } |
|
| 52 | -1x | +21x |
- "When specifying a pair [i, j], both indices must point to a single key pair.\n",+ x <- .as_map(target) |
| 53 | -1x | +21x |
- call. = FALSE+ y <- .as_map(current) |
| 54 | -+ | 21x |
- )+ all.equal(x, y) |
| 55 |
- }+ } |
||
| 56 | -1x | +
| 1 | +
- if (is.numeric(i)) i <- names(x)[i]+ #' Get and set parents in `join_keys` object |
|||
| 57 | -1x | +|||
| 2 | +
- if (is.numeric(j)) j <- names(x)[j]+ #' |
|||
| 58 | +3 |
-
+ #' `parents()` facilitates the creation of dependencies between datasets by |
||
| 59 | -7x | +|||
| 4 | +
- subset_x <- update_keys_given_parents(x[union(i, j)])+ #' assigning a parent-child relationship. |
|||
| 60 | -7x | +|||
| 5 | +
- return(subset_x[[i]][[j]])+ #' |
|||
| 61 | -24x | +|||
| 6 | +
- } else if (!missing(j)) {
+ #' Each element is defined by a `list` element, where `list("child" = "parent")`.
|
|||
| 62 | +7 |
- # ie. select all keys which have j as dataset_2+ #' |
||
| 63 | +8 |
- # since list is symmetrical it is equivalent to selecting by i+ #' @param x (`join_keys` or `teal_data`) object that contains "parents" information |
||
| 64 | -1x | +|||
| 9 | +
- i <- j+ #' to retrieve or manipulate. |
|||
| 65 | +10 |
- }+ #' |
||
| 66 | +11 |
-
+ #' @return a `list` of `character` representing the parents. |
||
| 67 | -24x | +|||
| 12 | +
- checkmate::assert(+ #' |
|||
| 68 | -24x | +|||
| 13 | +
- combine = "or",+ #' @export |
|||
| 69 | -24x | +|||
| 14 | +
- checkmate::check_character(i),+ #' @seealso [join_keys()] |
|||
| 70 | -24x | +|||
| 15 | +
- checkmate::check_numeric(i),+ parents <- function(x) {
|
|||
| 71 | -24x | +16 | +692x |
- checkmate::check_logical(i)+ UseMethod("parents", x)
|
| 72 | +17 |
- )+ } |
||
| 73 | +18 | |||
| 74 | +19 |
-
+ #' @describeIn parents Retrieves parents of `join_keys` object. |
||
| 75 | +20 |
- # Convert integer/logical index to named index+ #' @export |
||
| 76 | -24x | +|||
| 21 | +
- if (checkmate::test_numeric(i) || checkmate::test_logical(i)) {
+ #' @examples |
|||
| 77 | -2x | +|||
| 22 | +
- i <- names(x)[i]+ #' # Get parents of join_keys --- |
|||
| 78 | +23 |
- }+ #' |
||
| 79 | +24 |
-
+ #' jk <- default_cdisc_join_keys["ADEX"] |
||
| 80 | +25 |
- # When retrieving a relationship pair, it will also return the symmetric key+ #' parents(jk) |
||
| 81 | -24x | +|||
| 26 | +
- new_jk <- new_join_keys()+ parents.join_keys <- function(x) {
|
|||
| 82 | -24x | +27 | +1x |
- queue <- unique(i)+ if (is.null(attr(x, "parents"))) list() else attr(x, "parents") |
| 83 | -24x | +|||
| 28 | +
- bin <- character(0)+ } |
|||
| 84 | +29 | |||
| 85 | +30 |
- # Need to iterate on a mutating queue if subset of a dataset will also+ #' @describeIn parents Retrieves parents of `join_keys` inside `teal_data` object. |
||
| 86 | +31 |
- # select its parent as that parent might have relationships with others+ #' @export |
||
| 87 | +32 |
- # already selected.- |
- ||
| 88 | -24x | -
- while (length(queue) > 0) {
+ #' @examples |
||
| 89 | -53x | +|||
| 33 | +
- ix <- queue[1]+ #' # Get parents of join_keys inside teal_data object --- |
|||
| 90 | -53x | +|||
| 34 | +
- queue <- queue[-1]+ #' |
|||
| 91 | -53x | +|||
| 35 | +
- bin <- c(bin, ix)+ #' td <- teal_data( |
|||
| 92 | +36 |
-
+ #' ADSL = rADSL, |
||
| 93 | -53x | +|||
| 37 | +
- ix_parent <- parent(x, ix)+ #' ADTTE = rADTTE, |
|||
| 94 | +38 |
-
+ #' ADRS = rADRS, |
||
| 95 | -53x | +|||
| 39 | +
- if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) {
+ #' join_keys = default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS")]
|
|||
| 96 | -10x | +|||
| 40 | +
- queue <- c(queue, ix_parent)+ #' ) |
|||
| 97 | +41 |
- }+ #' parents(td) |
||
| 98 | +42 |
-
+ parents.teal_data <- function(x) {
|
||
| 99 | -53x | +43 | +1x |
- ix_valid_names <- names(x[[ix]]) %in% c(queue, bin)+ parents(x@join_keys) |
| 100 | +44 | - - | -||
| 101 | -53x | -
- new_jk[[ix]] <- x[[ix]][ix_valid_names]+ } |
||
| 102 | +45 | |||
| 103 | +46 |
- # Add primary key of parent+ #' @describeIn parents Assignment of parents in `join_keys` object. |
||
| 104 | -53x | +|||
| 47 | +
- if (length(ix_parent) > 0) {
+ #' |
|||
| 105 | -20x | +|||
| 48 | +
- new_jk[[ix_parent]][[ix_parent]] <- x[[ix_parent]][[ix_parent]]+ #' @param value (`named list`) of `character` vectors. |
|||
| 106 | +49 |
- }+ #' |
||
| 107 | +50 |
- }+ #' @export |
||
| 108 | +51 | - - | -||
| 109 | -24x | -
- common_parents_ix <- names(parents(x)) %in% names(new_jk) &+ `parents<-` <- function(x, value) {
|
||
| 110 | -24x | +52 | +438x |
- parents(x) %in% names(new_jk)+ UseMethod("parents<-", x)
|
| 111 | +53 | - - | -||
| 112 | -13x | -
- if (any(common_parents_ix)) parents(new_jk) <- parents(x)[common_parents_ix]+ } |
||
| 113 | +54 | |||
| 114 | -24x | -
- new_jk- |
- ||
| 115 | +55 |
- }+ #' @describeIn parents Assignment of parents of `join_keys` object. |
||
| 116 | +56 |
-
+ #' @export |
||
| 117 | +57 |
- #' @rdname join_keys+ #' @examples |
||
| 118 | +58 |
- #' @order 2+ #' # Assignment of parents --- |
||
| 119 | +59 |
#' |
||
| 120 | +60 |
- #' @param directed (`logical(1)`) Flag that indicates whether it should create+ #' jk <- join_keys( |
||
| 121 | +61 |
- #' a parent-child relationship between the datasets.+ #' join_key("ds1", "ds2", "id"),
|
||
| 122 | +62 |
- #' - `TRUE` (default) `dataset_1` is the parent of `dataset_2`;+ #' join_key("ds5", "ds6", "id"),
|
||
| 123 | +63 |
- #' - `FALSE` when the relationship is undirected.+ #' join_key("ds7", "ds6", "id")
|
||
| 124 | +64 |
- #' @section Functions:+ #' ) |
||
| 125 | +65 |
- #' - `x[i, j] <- value`: Assignment of a key to pair `(i, j)`.+ #' |
||
| 126 | +66 |
- #' - `x[i] <- value`: This (without `j` parameter) **is not** a supported+ #' parents(jk) <- list(ds2 = "ds1") |
||
| 127 | +67 |
- #' operation for `join_keys`.+ #' |
||
| 128 | +68 |
- #' - `join_keys(x)[i, j] <- value`: Assignment to `join_keys` object stored in `x`,+ #' # Setting individual parent-child relationship |
||
| 129 | +69 |
- #' such as a `teal_data` object or `join_keys` object itself.+ #' |
||
| 130 | +70 |
- #'+ #' parents(jk)["ds6"] <- "ds5" |
||
| 131 | +71 |
- #' @export+ #' parents(jk)["ds7"] <- "ds6" |
||
| 132 | +72 |
- #' @examples+ `parents<-.join_keys` <- function(x, value) {
|
||
| 133 | -+ | |||
| 73 | +437x |
- #' # Setting a new primary key ---+ checkmate::assert_list(value, types = "character", names = "named") |
||
| 134 | +74 |
- #'+ |
||
| 135 | -+ | |||
| 75 | +434x |
- #' jk["ds4", "ds4"] <- "pk4"+ new_parents <- list() |
||
| 136 | +76 |
- #' jk["ds5", "ds5"] <- "pk5"+ |
||
| 137 | -+ | |||
| 77 | +434x |
- #'+ for (dataset in names(value)) {
|
||
| 138 | +78 |
- #' # Setting a single relationship pair ---+ # Custom .var.name so it is verbose and helpful for users |
||
| 139 | -+ | |||
| 79 | +168x |
- #'+ checkmate::assert_string(value[[dataset]], .var.name = sprintf("value[[\"%s\"]]", dataset))
|
||
| 140 | +80 |
- #' jk["ds1", "ds4"] <- c("pk1" = "pk4")
+
|
||
| 141 | -+ | |||
| 81 | +167x |
- #'+ parent <- new_parents[[dataset]] |
||
| 142 | -+ | |||
| 82 | +167x |
- #' # Removing a key ---+ checkmate::assert( |
||
| 143 | -+ | |||
| 83 | +167x |
- #'+ checkmate::check_null(parent), |
||
| 144 | -+ | |||
| 84 | +167x |
- #' jk["ds5", "ds5"] <- NULL+ checkmate::check_true( |
||
| 145 | -+ | |||
| 85 | +167x |
- `[<-.join_keys` <- function(x, i, j, directed = TRUE, value) {
+ length(parent) == 0 && |
||
| 146 | -11x | +86 | +167x |
- checkmate::assert_flag(directed)+ length(value[[dataset]]) == 0 |
| 147 | -11x | +|||
| 87 | +
- if (missing(i) || missing(j)) {
+ ), |
|||
| 148 | -4x | +88 | +167x |
- stop("join_keys[i, j] specify both indices to set a key pair.")
+ checkmate::check_true(parent == value[[dataset]]), |
| 149 | -7x | +89 | +167x |
- } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) {
+ "Please check the difference between provided datasets parents and provided join_keys parents.", |
| 150 | -2x | +90 | +167x |
- stop("join_keys[i, j] neither i nor j can be NULL.")
+ .var.name = "value" |
| 151 | +91 |
- } else if (+ ) |
||
| 152 | -5x | +92 | +167x |
- !any(+ if (is.null(parent)) {
|
| 153 | -5x | +93 | +167x |
- checkmate::test_string(i),+ new_parents[[dataset]] <- value[[dataset]] |
| 154 | -5x | +|||
| 94 | +
- checkmate::test_number(i),+ } |
|||
| 155 | -5x | +|||
| 95 | +
- checkmate::test_logical(i, len = length(x)) && sum(j) == 1+ } |
|||
| 156 | +96 |
- ) ||+ |
||
| 157 | -5x | +97 | +433x |
- !any(+ if (is_dag(new_parents)) {
|
| 158 | -5x | +98 | +4x |
- checkmate::test_string(j),+ stop("Cycle detected in a parent and child dataset graph.")
|
| 159 | -5x | +|||
| 99 | +
- checkmate::test_number(j),+ } |
|||
| 160 | -5x | +|||
| 100 | +
- checkmate::test_logical(j, len = length(x)) && sum(j) == 1+ |
|||
| 161 | -+ | |||
| 101 | +429x |
- )+ attr(x, "parents") <- new_parents |
||
| 162 | +102 |
- ) {
+
|
||
| 163 | -2x | +103 | +429x |
- stop(+ assert_parent_child(x) |
| 164 | -2x | +104 | +428x |
- "join_keys[i, j] <- Can't set keys to specified indices.\n",+ x |
| 165 | -2x | +|||
| 105 | +
- "When setting pair [i, j], both indices must point to a single key pair.\n",+ } |
|||
| 166 | -2x | +|||
| 106 | +
- call. = FALSE+ |
|||
| 167 | +107 |
- )+ #' @describeIn parents Assignment of parents of `join_keys` inside `teal_data` object. |
||
| 168 | +108 |
- }+ #' @export |
||
| 169 | +109 |
-
+ #' @examples |
||
| 170 | +110 |
- # Handle join key removal separately+ #' # Assignment of parents of join_keys inside teal_data object --- |
||
| 171 | -3x | +|||
| 111 | +
- if (is.null(value)) {
+ #' |
|||
| 172 | -1x | +|||
| 112 | +
- x[[i]][[j]] <- NULL+ #' parents(td) <- list("ADTTE" = "ADSL") # replace existing
|
|||
| 173 | -1x | +|||
| 113 | +
- return(x)+ #' parents(td)["ADRS"] <- "ADSL" # add new parent |
|||
| 174 | +114 |
- }+ `parents<-.teal_data` <- function(x, value) {
|
||
| 175 | -+ | |||
| 115 | +1x |
-
+ parents(x@join_keys) <- value |
||
| 176 | -2x | +116 | +1x |
- c(x, join_key(i, j, value, directed))+ x |
| 177 | +117 |
} |
||
| 178 | +118 | |||
| 179 | +119 |
- #' @rdname join_keys+ #' @describeIn parents Getter for individual parent. |
||
| 180 | +120 |
#' |
||
| 181 | +121 |
- #' @order 1000+ #' @param dataset_name (`character(1)`) Name of dataset to query on their parent. |
||
| 182 | +122 |
- #' @usage ## Preferred method is x[i, j] <- value+ #' |
||
| 183 | +123 |
- #' x[[i]][[j]] <- value+ #' @return For `parent(x, dataset_name)` returns `NULL` if parent does not exist. |
||
| 184 | +124 |
#' |
||
| 185 | +125 |
- #' @section Functions:+ #' @export |
||
| 186 | +126 |
- #' - `x[[i]][[j]] <- value`: It is equivalent as `x[i, j] <- value`.+ #' |
||
| 187 | +127 |
- #'+ #' @examples |
||
| 188 | +128 |
- #' @export+ #' # Get individual parent --- |
||
| 189 | +129 |
- #' @examples+ #' |
||
| 190 | +130 |
- #' # Setting via x[[i]] <- value ---+ #' parent(jk, "ds2") |
||
| 191 | +131 |
- #'+ #' parent(td, "ADTTE") |
||
| 192 | +132 |
- #' jk <- join_keys()+ parent <- function(x, dataset_name) {
+ |
+ ||
| 133 | +169x | +
+ checkmate::assert_string(dataset_name) |
||
| 193 | +134 |
- #' jk[["ds6"]][["ds6"]] <- "pk6"+ # assert x is performed by parents()+ |
+ ||
| 135 | +169x | +
+ parents(x)[[dataset_name]] |
||
| 194 | +136 |
- #' jk[["ds7"]] <- list(ds7 = "pk7", ds6 = c(pk7 = "pk6"))+ } |
| 195 | +1 |
- #' jk[["ds7"]][["ds7"]] <- NULL # removes key+ #' Deprecated `TealData` class and related functions |
|
| 196 | +2 |
#' |
|
| 197 | +3 |
- #' jk+ #' @description |
|
| 198 | +4 |
- #'+ #' `r lifecycle::badge("deprecated")`
|
|
| 199 | +5 |
- #' @noRd+ #' |
|
| 200 | +6 |
- `[[<-.join_keys` <- function(x, i, value) {
+ #' The `TealData` class and associated functions have been deprecated. Use [teal_data()] instead. |
|
| 201 | -397x | +||
| 7 | +
- checkmate::assert(+ #' See the [Migration guide](https://github.com/insightsengineering/teal/discussions/945) for details. |
||
| 202 | -397x | +||
| 8 | +
- combine = "or",+ #' |
||
| 203 | -397x | -
- checkmate::check_string(i),- |
- |
| 204 | -397x | -
- checkmate::check_number(i),- |
- |
| 205 | -397x | -
- checkmate::check_logical(i, len = length(x))- |
- |
| 206 | -- |
- )- |
- |
| 207 | -397x | -
- checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE)- |
- |
| 208 | -390x | -
- if (checkmate::test_numeric(i) || checkmate::test_logical(i)) {
- |
- |
| 209 | -1x | -
- i <- names(x)[[i]]- |
- |
| 210 | -- |
- }- |
- |
| 211 | -- | - - | -|
| 212 | -- |
- # Normalize values- |
- |
| 213 | -390x | -
- norm_value <- lapply(seq_along(value), function(.x) {
- |
- |
| 214 | -551x | -
- join_key(i, names(value)[.x], value[[.x]])- |
- |
| 215 | -- |
- })- |
- |
| 216 | -390x | -
- names(norm_value) <- names(value)- |
- |
| 217 | -- | - - | -|
| 218 | -- |
- # Check if multiple modifications don't have a conflict- |
- |
| 219 | -390x | -
- repeated_value_ix <- names(value) %in% names(value)[duplicated(names(value))]- |
- |
| 220 | -390x | -
- repeated <- norm_value[repeated_value_ix]- |
- |
| 221 | -390x | -
- vapply(- |
- |
| 222 | -390x | -
- seq_along(repeated),- |
- |
| 223 | -390x | -
- function(.ix, .x_value = repeated[[.ix]], .x_name = names(.x_value[[1]])) {
- |
- |
| 224 | -3x | -
- assert_compatible_keys2(- |
- |
| 225 | -3x | -
- .x_value,- |
- |
| 226 | -3x | -
- unlist(unname(- |
- |
| 227 | -3x | -
- repeated[-.ix][names(repeated[-.ix]) == .x_name]- |
- |
| 228 | -3x | -
- ), recursive = FALSE)- |
- |
| 229 | -- |
- )- |
- |
| 230 | -- |
- },- |
- |
| 231 | -390x | -
- logical(1)- |
- |
| 232 | -- |
- )- |
- |
| 233 | -- | - - | -|
| 234 | -389x | -
- norm_value <- lapply(norm_value, function(x) x[[1]][[1]])- |
- |
| 235 | -389x | -
- names(norm_value) <- names(value)- |
- |
| 236 | -- | - - | -|
| 237 | -- |
- # Safe to do as duplicated are the same- |
- |
| 238 | -389x | -
- norm_value[duplicated(names(norm_value))] <- NULL- |
- |
| 239 | -- | - - | -|
| 240 | -- |
- # Keep only elements with length > 0L- |
- |
| 241 | -389x | -
- norm_value <- Filter(length, norm_value)- |
- |
| 242 | -- | - - | -|
| 243 | -- |
- # Remove classes to use list-based get/assign operations- |
- |
| 244 | -389x | -
- new_x <- unclass(x)- |
- |
| 245 | -- | - - | -|
| 246 | -- |
- # In case a pair is removed, also remove the symmetric pair and update parents- |
- |
| 247 | -389x | -
- removed_names <- setdiff(names(new_x[[i]]), names(norm_value))- |
- |
| 248 | -389x | -
- for (.x in removed_names) {
- |
- |
| 249 | -2x | -
- if (identical(parent(x, .x), i)) attr(new_x, "parents")[[.x]] <- NULL- |
- |
| 250 | -1x | -
- if (identical(parent(x, i), .x)) attr(new_x, "parents")[[i]] <- NULL- |
- |
| 251 | -- | - - | -|
| 252 | -5x | -
- new_x[[.x]][[i]] <- NULL- |
- |
| 253 | -- |
- }- |
- |
| 254 | -- | - - | -|
| 255 | -389x | -
- new_x[[i]] <- norm_value- |
- |
| 256 | -- | - - | -|
| 257 | -- |
- # Iterate on all new values to create symmetrical pair- |
- |
| 258 | -389x | -
- for (ds2 in names(norm_value)) {
- |
- |
| 259 | -310x | -
- if (ds2 == i) next- |
- |
| 260 | -- | - - | -|
| 261 | -237x | -
- keep_value <- if (is.null(x)) list() else new_x[[ds2]]- |
- |
| 262 | -- | - - | -|
| 263 | -- |
- # Invert key- |
- |
| 264 | -237x | -
- new_value <- stats::setNames(names(norm_value[[ds2]]), norm_value[[ds2]])- |
- |
| 265 | -237x | -
- keep_value[[i]] <- new_value- |
- |
| 266 | -- | - - | -|
| 267 | -- |
- # Assign symmetrical- |
- |
| 268 | -237x | -
- new_x[[ds2]] <- keep_value- |
- |
| 269 | -- |
- }- |
- |
| 270 | -- | - - | -|
| 271 | -389x | -
- preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"]- |
- |
| 272 | -- |
- # Remove NULL or empty keys- |
- |
| 273 | -389x | -
- new_x <- Filter(function(x) length(x) != 0L, new_x)- |
- |
| 274 | -389x | -
- attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr)- |
- |
| 275 | -- | - - | -|
| 276 | -- |
- #- |
- |
| 277 | -- |
- # restore class- |
- |
| 278 | -389x | -
- class(new_x) <- class(x)- |
- |
| 279 | -389x | -
- new_x- |
- |
| 280 | -- |
- }- |
-
| 1 | -- |
- #' Comprehensive data integration function for `teal` applications- |
-
| 2 | -- |
- #'- |
-
| 3 | -- |
- #' @description- |
-
| 4 | -- |
- #' `r lifecycle::badge("stable")`
- |
-
| 5 | -- |
- #'- |
-
| 6 | -- |
- #' Universal function to pass data to teal application.- |
-
| 7 | -- |
- #'- |
-
| 8 | -- |
- #' @param ... any number of objects (presumably data objects) provided as `name = value` pairs.- |
-
| 9 | -- |
- #'- |
-
| 10 | -- |
- #' @param join_keys (`join_keys` or single `join_key_set`)- |
-
| 11 | -- |
- #' optional object with datasets column names used for joining.- |
-
| 12 | -- |
- #' If empty then no joins between pairs of objects.- |
-
| 13 | -- |
- #'- |
-
| 14 | -- |
- #' @param code (`character`, `language`) optional code to reproduce the datasets provided in `...`.- |
-
| 15 | -- |
- #' Note this code is not executed and the `teal_data` may not be reproducible- |
-
| 16 | -- |
- #'- |
-
| 17 | -- |
- #' @param check (`logical`) `r lifecycle::badge("deprecated")`
- |
-
| 18 | -- |
- #' Use [verify()] to verify code reproducibility .- |
-
| 19 | -- |
- #'- |
-
| 20 | -- |
- #' @return A `teal_data` object.- |
-
| 21 | -- |
- #'- |
-
| 22 | -- |
- #' @export- |
-
| 23 | -- |
- #'- |
-
| 24 | -- |
- #' @examples- |
-
| 25 | -- |
- #' teal_data(x1 = iris, x2 = mtcars)- |
-
| 26 | -- |
- #'- |
-
| 27 | -- |
- teal_data <- function(...,- |
-
| 28 | -- |
- join_keys = teal.data::join_keys(),- |
-
| 29 | -- |
- code = character(0),- |
-
| 30 | -- |
- check) {
- |
-
| 31 | -97x | -
- data_objects <- rlang::list2(...)- |
-
| 32 | -97x | -
- if (inherits(join_keys, "join_key_set")) {
- |
-
| 33 | -! | -
- join_keys <- teal.data::join_keys(join_keys)- |
-
| 34 | -- |
- }- |
-
| 35 | -97x | -
- if (!missing(check)) {
- |
-
| 36 | -! | -
- lifecycle::deprecate_stop(- |
-
| 37 | -! | -
- when = "0.4.0",- |
-
| 38 | -! | -
- "teal_data(- |
-
| 39 | -! | -
- check = 'check argument is deprecated. Use `verify()` to verify code reproducibility.- |
-
| 40 | -! | -
- Find more information on https://github.com/insightsengineering/teal/discussions/945'- |
-
| 41 | -- |
- )"- |
-
| 42 | -- |
- )- |
-
| 43 | -- |
- }- |
-
| 44 | -- | - - | -
| 45 | -- |
- if (- |
-
| 46 | -97x | -
- checkmate::test_list(- |
-
| 47 | -97x | -
- data_objects,- |
-
| 48 | -97x | -
- types = c("TealDataConnector", "TealDataset", "TealDatasetConnector"),
- |
-
| 49 | -97x | -
- min.len = 1- |
-
| 50 | -- |
- )- |
-
| 51 | -- |
- ) {
- |
-
| 52 | -! | -
- lifecycle::deprecate_stop(- |
-
| 53 | -! | -
- when = "0.4.0",- |
-
| 54 | -! | -
- "teal_data(- |
-
| 55 | -! | -
- data_objects = 'should use data directly. Using TealDatasetConnector and TealDataset is deprecated.- |
-
| 56 | -! | -
- Find more information on https://github.com/insightsengineering/teal/discussions/945'- |
-
| 57 | -- |
- )"- |
-
| 58 | -- |
- )- |
-
| 59 | -- |
- } else {
- |
-
| 60 | -97x | -
- if (length(data_objects) > 0 && !checkmate::test_names(names(data_objects), type = "named")) {
- |
-
| 61 | -! | -
- stop("Dot (`...`) arguments on `teal_data()` must be named.")
- |
-
| 62 | -- |
- }- |
-
| 63 | -97x | -
- new_teal_data(- |
-
| 64 | -97x | -
- data = data_objects,- |
-
| 65 | -97x | -
- code = code,- |
-
| 66 | -97x | -
- join_keys = join_keys- |
-
| 67 | -- |
- )- |
-
| 68 | -- |
- }- |
-
| 69 | -- |
- }- |
-
| 1 | -- |
- #' Create a relationship between a pair of datasets- |
-
| 2 | -- |
- #'- |
-
| 3 | -- |
- #' @description- |
-
| 4 | -- |
- #' `r lifecycle::badge("stable")`
- |
-
| 5 | -- |
- #'- |
-
| 6 | -- |
- #' Create a relationship between two datasets, `dataset_1` and `dataset_2`.- |
-
| 7 | -- |
- #' By default, this function establishes a directed relationship with `dataset_1` as the parent.- |
-
| 8 | -- |
- #' If `dataset_2` is not specified, the function creates a primary key for `dataset_1`.- |
-
| 9 | -- |
- #'- |
-
| 10 | -- |
- #' @param dataset_1,dataset_2 (`character(1)`) Dataset names. When `dataset_2` is omitted,- |
-
| 11 | -- |
- #' a primary key for `dataset_1` is created.- |
-
| 12 | -- |
- #' @param keys (optionally named `character`) Column mapping between the datasets,- |
-
| 13 | -- |
- #' where `names(keys)` maps columns in `dataset_1` corresponding to columns of- |
-
| 14 | -- |
- #' `dataset_2` given by the elements of `keys`.- |
-
| 15 | -- |
- #' - If unnamed, the same column names are used for both datasets.- |
-
| 16 | -- |
- #' - If any element of the `keys` vector is empty with a non-empty name, then the name is- |
-
| 17 | -- |
- #' used for both datasets.- |
-
| 18 | -- |
- #' @param directed (`logical(1)`) Flag that indicates whether it should create- |
-
| 19 | -- |
- #' a parent-child relationship between the datasets.- |
-
| 20 | -- |
- #' - `TRUE` (default) `dataset_1` is the parent of `dataset_2`;- |
-
| 21 | -- |
- #' - `FALSE` when the relationship is undirected.- |
-
| 22 | -- |
- #'- |
-
| 23 | -- |
- #' @return object of class `join_key_set` to be passed into `join_keys` function.- |
-
| 24 | -- |
- #'- |
-
| 25 | -- |
- #' @examples- |
-
| 26 | -- |
- #' join_key("d1", "d2", c("A"))
- |
-
| 27 | -- |
- #' join_key("d1", "d2", c("A" = "B"))
- |
-
| 28 | -- |
- #' join_key("d1", "d2", c("A" = "B", "C"))
- |
-
| 29 | -- |
- #'- |
-
| 30 | -- |
- #' @export- |
-
| 31 | -- |
- #' @seealso [join_keys()], [parents()]- |
-
| 32 | -- |
- #'- |
-
| 33 | -- |
- join_key <- function(dataset_1, dataset_2 = dataset_1, keys, directed = TRUE) {
- |
-
| 34 | -1103x | -
- checkmate::assert_string(dataset_1)- |
-
| 35 | -1103x | -
- checkmate::assert_string(dataset_2)- |
-
| 36 | -1100x | -
- checkmate::assert_character(keys, any.missing = FALSE)- |
-
| 37 | -1095x | -
- checkmate::assert_flag(directed)- |
-
| 38 | -- | - - | -
| 39 | -1095x | -
- if (length(keys) > 0) {
- |
-
| 40 | -1093x | -
- if (is.null(names(keys))) {
- |
-
| 41 | -526x | -
- names(keys) <- keys- |
-
| 42 | -- |
- }- |
-
| 43 | -- | - - | -
| 44 | -1093x | -
- keys <- trimws(keys)- |
-
| 45 | -1093x | -
- names(keys) <- trimws(names(keys))- |
-
| 46 | -- | - - | -
| 47 | -- |
- # Remove keys with empty value and without name- |
-
| 48 | -1093x | -
- if (any(keys == "" & names(keys) == "")) {
- |
-
| 49 | -6x | -
- message("Key with an empty value and name are ignored.")
- |
-
| 50 | -6x | -
- keys <- keys[keys != "" & names(keys) != ""]- |
-
| 51 | -- |
- }- |
-
| 52 | -- | - - | -
| 53 | -- |
- # Set name of keys without one: c("A") -> c("A" = "A")
- |
-
| 54 | -1093x | -
- if (any(names(keys) == "")) {
- |
-
| 55 | -4x | -
- names(keys)[names(keys) == ""] <- keys[names(keys) == ""]- |
-
| 56 | -- |
- }- |
-
| 57 | -- | - - | -
| 58 | -- |
- # Set value of keys with empty string, but non-empty name: c("A" = "") -> c("A" = "A")
- |
-
| 59 | -1093x | -
- if (any(keys == "")) {
- |
-
| 60 | -4x | -
- keys[keys == ""] <- names(keys[keys == ""])- |
-
| 61 | -- |
- }- |
-
| 62 | -- | - - | -
| 63 | -1093x | -
- stopifnot(!is.null(names(keys)))- |
-
| 64 | -1093x | -
- stopifnot(!anyDuplicated(keys))- |
-
| 65 | -1092x | -
- stopifnot(!anyDuplicated(names(keys)))- |
-
| 66 | -- | - - | -
| 67 | -1091x | -
- if (dataset_1 == dataset_2 && any(names(keys) != keys)) {
- |
-
| 68 | -2x | -
- stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed")
- |
-
| 69 | -- |
- }- |
-
| 70 | -- |
- } else {
- |
-
| 71 | -2x | -
- keys <- NULL- |
-
| 72 | -- |
- }- |
-
| 73 | -- | - - | -
| 74 | -1091x | -
- parents <- if (directed && dataset_1 != dataset_2) {
- |
-
| 75 | -413x | -
- stats::setNames(list(dataset_1), dataset_2)- |
-
| 76 | -- |
- } else {
- |
-
| 77 | -678x | -
- list()- |
-
| 78 | -- |
- }- |
-
| 79 | -- | - - | -
| 80 | -1091x | -
- structure(- |
-
| 81 | -1091x | -
- list(- |
-
| 82 | -1091x | -
- structure(- |
-
| 83 | -1091x | -
- list(keys),- |
-
| 84 | -1091x | -
- names = dataset_2- |
-
| 85 | -- |
- )- |
-
| 86 | -- |
- ),- |
-
| 87 | -1091x | -
- names = dataset_1,- |
-
| 88 | -1091x | -
- class = "join_key_set",- |
-
| 89 | -1091x | -
- parents = parents- |
-
| 90 | -- |
- )- |
-
| 91 | -- |
- }- |
-
| 1 | -- |
- setOldClass("join_keys")
- |
-
| 2 | -- | - - | -
| 3 | -- |
- #' Reproducible data- |
-
| 4 | -- |
- #'- |
-
| 5 | -- |
- #' Reproducible data container class. Inherits code tracking behavior from [`teal.code::qenv-class`].- |
-
| 6 | -- |
- #'- |
-
| 7 | -- |
- #' This class provides an isolated environment in which to store and process data with all code being recorded.- |
-
| 8 | -- |
- #' The environment, code, data set names, and data joining keys are stored in their respective slots.- |
-
| 9 | -- |
- #' These slots should never be accessed directly, use the provided get/set functions.- |
-
| 10 | -- |
- #'- |
-
| 11 | -- |
- #' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots.- |
-
| 12 | -- |
- #' If errors are raised, a `qenv.error` object is returned.- |
-
| 13 | -- |
- #'- |
-
| 14 | -- |
- #' @name teal_data-class- |
-
| 15 | -- |
- #' @rdname teal_data-class- |
-
| 16 | -- |
- #'- |
-
| 17 | -- |
- #' @slot env (`environment`) environment containing data sets and possibly auxiliary variables.- |
-
| 18 | -- |
- #' Access variables with [get_var()] or [`[[`].- |
-
| 19 | -- |
- #' No setter provided. Evaluate code to add variables into `@env`.- |
-
| 20 | -- |
- #' @slot code (`character`) vector representing code necessary to reproduce the contents of `@env`.- |
-
| 21 | -- |
- #' Access with [get_code()].- |
-
| 22 | -- |
- #' No setter provided. Evaluate code to append code to the slot.- |
-
| 23 | -- |
- #' @slot id (`integer`) random identifier assigned to each element of `@code`. Used internally.- |
-
| 24 | -- |
- #' @slot warnings (`character`) vector of warnings raised when evaluating code.- |
-
| 25 | -- |
- #' Access with [get_warnings()].- |
-
| 26 | -- |
- #' @slot messages (`character`) vector of messages raised when evaluating code.- |
-
| 27 | -- |
- #' @slot join_keys (`join_keys`) object specifying joining keys for data sets in `@env`.- |
-
| 28 | -- |
- #' Access or modify with [join_keys()].- |
-
| 29 | -- |
- #' @slot datanames (`character`) vector of names of data sets in `@env`.- |
-
| 30 | -- |
- #' Used internally to distinguish them from auxiliary variables.- |
-
| 31 | -- |
- #' Access or modify with [datanames()].- |
-
| 32 | -- |
- #' @slot verified (`logical(1)`) flag signifying that code in `@code` has been proven to yield contents of `@env`.- |
-
| 33 | -- |
- #' Used internally. See [`verify()`] for more details.- |
-
| 34 | -- |
- #'- |
-
| 35 | -- |
- #' @import teal.code- |
-
| 36 | -- |
- #' @keywords internal- |
-
| 37 | -- |
- setClass(- |
-
| 38 | -- |
- Class = "teal_data",- |
-
| 39 | -- |
- contains = "qenv",- |
-
| 40 | -- |
- slots = c(join_keys = "join_keys", datanames = "character", verified = "logical"),- |
-
| 41 | -- |
- prototype = list(- |
-
| 42 | -- |
- join_keys = join_keys(),- |
-
| 43 | -- |
- datanames = character(0),- |
-
| 44 | -- |
- verified = logical(0)- |
-
| 45 | -- |
- )- |
-
| 46 | -- |
- )- |
-
| 47 | -- | - - | -
| 48 | -- |
- #' Initialize `teal_data` object- |
-
| 49 | -- |
- #'- |
-
| 50 | -- |
- #' @name new_teal_data- |
-
| 51 | -- |
- #'- |
-
| 52 | -- |
- #' @param data (`named list`) of data objects.- |
-
| 53 | -- |
- #' @param code (`character` or `language`) code to reproduce the `data`.- |
-
| 54 | -- |
- #' Accepts and stores comments also.- |
-
| 55 | -- |
- #' @param join_keys (`join_keys`) object- |
-
| 56 | -- |
- #' @param datanames (`character`) names of datasets passed to `data`.- |
-
| 57 | -- |
- #' Needed when non-dataset objects are needed in the `env` slot.- |
-
| 58 | -- |
- #' @rdname new_teal_data- |
-
| 59 | -- |
- #' @keywords internal- |
-
| 60 | -- |
- new_teal_data <- function(data,- |
-
| 61 | -- |
- code = character(0),- |
-
| 62 | -- |
- join_keys = join_keys(),- |
-
| 63 | -- |
- datanames = names(data)) {
- |
-
| 64 | -97x | -
- checkmate::assert_list(data)- |
-
| 65 | -97x | -
- checkmate::assert_class(join_keys, "join_keys")- |
-
| 66 | -64x | -
- if (is.null(datanames)) datanames <- character(0) # todo: allow to specify- |
-
| 67 | -97x | -
- checkmate::assert_character(datanames)- |
-
| 68 | -97x | -
- if (!any(is.language(code), is.character(code))) {
- |
-
| 69 | -! | -
- stop("`code` must be a character or language object.")
- |
-
| 70 | -- |
- }- |
-
| 71 | -- | - - | -
| 72 | -97x | -
- if (is.language(code)) {
- |
-
| 73 | -2x | -
- code <- paste(lang2calls(code), collapse = "\n")- |
-
| 74 | -- |
- }- |
-
| 75 | -97x | -
- if (length(code)) {
- |
-
| 76 | -14x | -
- code <- paste(code, collapse = "\n")- |
-
| 77 | -- |
- }- |
-
| 78 | -97x | -
- verified <- (length(code) == 0L && length(data) == 0L)- |
-
| 79 | -- | - - | -
| 80 | -97x | -
- id <- sample.int(.Machine$integer.max, size = length(code))- |
-
| 81 | -- | - - | -
| 82 | -97x | -
- new_env <- rlang::env_clone(list2env(data), parent = parent.env(.GlobalEnv))- |
-
| 83 | -97x | -
- lockEnvironment(new_env, bindings = TRUE)- |
-
| 84 | -- | - - | -
| 85 | -97x | -
- datanames <- .get_sorted_datanames(datanames = datanames, join_keys = join_keys, env = new_env)- |
-
| 86 | -- | - - | -
| 87 | -97x | -
- methods::new(- |
-
| 88 | -97x | -
- "teal_data",- |
-
| 89 | -97x | -
- env = new_env,- |
-
| 90 | -97x | -
- code = code,- |
-
| 91 | -97x | -
- warnings = rep("", length(code)),
- |
-
| 92 | -97x | -
- messages = rep("", length(code)),
- |
-
| 93 | -97x | -
- id = id,- |
-
| 94 | -97x | -
- join_keys = join_keys,- |
-
| 95 | -97x | -
- datanames = datanames,- |
-
| 96 | -97x | -
- verified = verified- |
-
| 97 | -- |
- )- |
-
| 98 | -- |
- }- |
-
| 1 | -- |
- #' Verify code reproducibility- |
-
| 2 | -- |
- #'- |
-
| 3 | -- |
- #' Checks whether code in `teal_data` object reproduces the stored objects.- |
-
| 4 | -- |
- #'- |
-
| 5 | -- |
- #' If objects created by code in the `@code` slot of `x` are `all_equal` to the contents of the `@env` slot,- |
-
| 6 | -- |
- #' the function updates the `@verified` slot to `TRUE` in the returned `teal_data` object.- |
-
| 7 | -- |
- #' Once verified, the slot will always be set to `TRUE`.- |
-
| 8 | -- |
- #' If the `@code` fails to recreate objects in `teal_data@env`, an error is raised.- |
-
| 9 | -- |
- #'- |
-
| 10 | -- |
- #' @return Input `teal_data` object or error.- |
-
| 11 | -- |
- #'- |
-
| 12 | -- |
- #' @param x `teal_data` object- |
-
| 13 | -- |
- #' @examples- |
-
| 14 | -- |
- #' tdata1 <- teal_data()- |
-
| 15 | -- |
- #' tdata1 <- within(tdata1, {
- |
-
| 16 | -- |
- #' a <- 1- |
-
| 17 | -- |
- #' b <- a^5- |
-
| 18 | -- |
- #' c <- list(x = 2)- |
-
| 19 | -- |
- #' })- |
-
| 20 | -- |
- #' verify(tdata1)- |
-
| 21 | -- |
- #'- |
-
| 22 | -- |
- #' tdata2 <- teal_data(x1 = iris, code = "x1 <- iris")- |
-
| 23 | -- |
- #' verify(tdata2)- |
-
| 24 | -- |
- #' verify(tdata2)@verified- |
-
| 25 | -- |
- #' tdata2@verified- |
-
| 26 | -- |
- #'- |
-
| 27 | -- |
- #' tdata3 <- teal_data()- |
-
| 28 | -- |
- #' tdata3 <- within(tdata3, {
- |
-
| 29 | -- |
- #' stop("error")
- |
-
| 30 | -- |
- #' })- |
-
| 31 | -- |
- #' try(verify(tdata3)) # fails- |
-
| 32 | -- |
- #'- |
-
| 33 | -- |
- #'- |
-
| 34 | -- |
- #' a <- 1- |
-
| 35 | -- |
- #' b <- a + 2- |
-
| 36 | -- |
- #' c <- list(x = 2)- |
-
| 37 | -- |
- #' d <- 5- |
-
| 38 | -- |
- #' tdata4 <- teal_data(- |
-
| 39 | -- |
- #' a = a, b = b, c = c, d = d,- |
-
| 40 | -- |
- #' code = "a <- 1- |
-
| 41 | -- |
- #' b <- a- |
-
| 42 | -- |
- #' c <- list(x = 2)- |
-
| 43 | -- |
- #' e <- 1"- |
-
| 44 | -- |
- #' )- |
-
| 45 | -- |
- #' tdata4- |
-
| 46 | -- |
- #' \dontrun{
- |
-
| 47 | -- |
- #' verify(tdata4) # fails- |
-
| 48 | -- |
- #' }- |
-
| 49 | -- |
- #'- |
-
| 50 | -- |
- #' @name verify- |
-
| 51 | -- |
- #' @rdname verify- |
-
| 52 | -- |
- #' @aliases verify,teal_data-method- |
-
| 53 | -- |
- #' @aliases verify,qenv.error-method- |
-
| 54 | -- |
- #'- |
-
| 55 | -- |
- #' @export- |
-
| 56 | -5x | -
- setGeneric("verify", function(x) standardGeneric("verify"))
- |
-
| 57 | -- |
- setMethod("verify", signature = "teal_data", definition = function(x) {
- |
-
| 58 | -4x | -
- if (x@verified) {
- |
-
| 59 | -2x | -
- return(x)- |
-
| 60 | -- |
- }- |
-
| 61 | -2x | -
- x_name <- deparse(substitute(x))- |
-
| 62 | -2x | -
- y <- eval_code(teal_data(), get_code(x))- |
-
| 63 | -- | - - | -
| 64 | -2x | -
- if (inherits(y, "qenv.error")) {
- |
-
| 65 | -! | -
- stop(conditionMessage(y), call. = FALSE)- |
-
| 66 | -- |
- }- |
-
| 67 | -- | - - | -
| 68 | -2x | -
- reproduced <- isTRUE(all.equal(x@env, y@env))- |
-
| 69 | -2x | -
- if (reproduced) {
- |
-
| 70 | -1x | -
- x@verified <- TRUE- |
-
| 71 | -1x | -
- methods::validObject(x)- |
-
| 72 | -1x | -
- x- |
-
| 73 | -- |
- } else {
- |
-
| 74 | -1x | -
- error <- "Code verification failed."- |
-
| 75 | -- | - - | -
| 76 | -1x | -
- objects_diff <- vapply(- |
-
| 77 | -1x | -
- intersect(names(x@env), names(y@env)),- |
-
| 78 | -1x | -
- function(element) {
- |
-
| 79 | -1x | -
- isTRUE(all.equal(x@env[[element]], y@env[[element]]))- |
-
| 80 | -- |
- },- |
-
| 81 | -1x | -
- logical(1)- |
-
| 82 | -- |
- )- |
-
| 83 | -- | - - | -
| 84 | -1x | -
- names_diff_other <- setdiff(names(y@env), names(x@env))- |
-
| 85 | -1x | -
- names_diff_inenv <- setdiff(names(x@env), names(y@env))- |
-
| 86 | -- | - - | -
| 87 | -1x | -
- if (length(objects_diff)) {
- |
-
| 88 | -1x | -
- error <- c(- |
-
| 89 | -1x | -
- error,- |
-
| 90 | -1x | -
- paste0("Object(s) recreated with code that have different structure in ", x_name, ":"),
- |
-
| 91 | -1x | -
- paste0(" \u2022 ", names(which(!objects_diff)))
- |
-
| 92 | -- |
- )- |
-
| 93 | -- |
- }- |
-
| 94 | -1x | -
- if (length(names_diff_inenv)) {
- |
-
| 95 | -! | -
- error <- c(- |
-
| 96 | -! | -
- error,- |
-
| 97 | -! | -
- paste0("Object(s) not created with code that exist in ", x_name, ":"),
- |
-
| 98 | -! | -
- paste0(" \u2022 ", names_diff_inenv)
- |
-
| 99 | -- |
- )- |
-
| 100 | -- |
- }- |
-
| 101 | -1x | -
- if (length(names_diff_other)) {
- |
-
| 102 | -! | -
- error <- c(- |
-
| 103 | -! | -
- error,- |
-
| 104 | -! | -
- paste0("Object(s) created with code that do not exist in ", x_name, ":"),
- |
-
| 105 | -! | -
- paste0(" \u2022 ", names_diff_other)
- |
-
| 106 | -- |
- )- |
-
| 107 | -- |
- }- |
-
| 108 | -- | - - | -
| 109 | -1x | -
- stop(paste(error, collapse = "\n"), call. = FALSE)- |
-
| 110 | -- |
- }- |
-
| 111 | -- |
- })- |
-
| 112 | -- |
- setMethod("verify", signature = "qenv.error", definition = function(x) {
- |
-
| 113 | -1x | -
- stop(conditionMessage(x), call. = FALSE)- |
-
| 114 | -- |
- })- |
-
| 1 | -- |
- #' Deprecated `TealData` class and related functions- |
-
| 2 | -- |
- #'- |
-
| 3 | -- |
- #' @description- |
-
| 4 | -- |
- #' `r lifecycle::badge("deprecated")`
- |
-
| 5 | -- |
- #'- |
-
| 6 | -- |
- #' The `TealData` class and associated functions have been deprecated. Use [teal_data()] instead.- |
-
| 7 | -- |
- #' See the [Migration guide](https://github.com/insightsengineering/teal/discussions/945) for details.- |
-
| 8 | -- |
- #'- |
-
| 9 | -+ | |
| 9 | +
#' @name TealData |
@@ -7127,105 +3882,105 @@
| 1 |
- #' Variable labels+ #' @rdname join_keys |
||
| 2 |
- #'+ #' @order 2 |
||
| 3 |
- #' Get or set variable labels in a `data.frame`.+ #' |
||
| 4 |
- #'+ #' @section Functions: |
||
| 5 |
- #' @details Variable labels can be stored as a `label` attribute set on individual variables.+ #' - `x[datanames]`: Returns a subset of the `join_keys` object for |
||
| 6 |
- #' These functions get or set this attribute, either on all (`col_labels`) or some variables (`col_relabel`).+ #' given `datanames`, including parent `datanames` and symmetric mirror keys between |
||
| 7 |
- #'+ #' `datanames` in the result. |
||
| 8 |
- #' @param x (`data.frame` or `DataFrame`) data object+ #' - `x[i, j]`: Returns join keys between datasets `i` and `j`, |
||
| 9 |
- #' @param fill (`logical(1)`) specifying what to return if variable has no label+ #' including implicit keys inferred from their relationship with a parent. |
||
| 10 |
- #' @param value (`character`) vector of variable labels of length equal to number of columns in `x`;+ #' |
||
| 11 |
- #' if named, names must match variable names in `x` and will be used as key to set labels;+ #' @param i,j indices specifying elements to extract or replace. Index should be a |
||
| 12 |
- #' use `NA` to remove label from variable+ #' a character vector, but it can also take numeric, logical, `NULL` or missing. |
||
| 13 |
- #' @param ... name-value pairs, where name corresponds to a variable name in `x`+ #' |
||
| 14 |
- #' and value is the new variable label; use `NA` to remove label from variable+ #' @export |
||
| 16 |
- #' @return+ #' @examples |
||
| 17 |
- #' For `col_labels`, named character vector of variable labels, the names being the corresponding variable names.+ #' # Getter for join_keys --- |
||
| 18 |
- #' If the `label` attribute is missing, the vector elements will be+ #' |
||
| 19 |
- #' the variable names themselves if `fill = TRUE` and `NA` if `fill = FALSE`.+ #' jk["ds1", "ds2"] |
||
| 21 |
- #' For `col_labels<-` and `col_relabel`, copy of `x` with variable labels modified.+ #' # Subsetting join_keys ---- |
||
| 23 |
- #' @examples+ #' jk["ds1"] |
||
| 24 |
- #' x <- iris+ #' jk[1:2] |
||
| 25 |
- #' col_labels(x)+ #' jk[c("ds1", "ds2")]
|
||
| 26 |
- #' col_labels(x) <- paste("label for", names(iris))
+ #' |
||
| 27 |
- #' col_labels(x)+ `[.join_keys` <- function(x, i, j) {
|
||
| 28 | -+ | 35x |
- #' y <- col_relabel(x, Sepal.Length = "Sepal Length of iris flower")+ if (missing(i) && missing(j)) {
|
| 29 |
- #' col_labels(y)+ # because: |
||
| 30 |
- #'+ # - list(a = 1)[] returns list(a = 1) |
||
| 31 |
- #' @source These functions were taken from+ # - data.frame(a = 1)[] returns data.frame(a = 1) |
||
| 32 | -+ | 1x |
- #' [formatters](https://cran.r-project.org/package=formatters) package, to reduce the complexity of+ return(x) |
| 33 | -+ | 34x |
- #' the dependency tree and rewritten.+ } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) {
|
| 34 |
- #'+ # because list(a = 1)[NULL] returns NULL |
||
| 35 |
- #' @rdname col_labels+ # data.frame(a = 1)[NULL, NULL] returns data.frame( |
||
| 36 | -+ | 2x |
- #' @export+ return(join_keys()) |
| 37 | -+ | 32x |
- #'+ } else if (!missing(i) && !missing(j)) {
|
| 38 |
- col_labels <- function(x, fill = FALSE) {
+ if ( |
||
| 39 | -16x | +8x |
- checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
+ !any( |
| 40 | -16x | +8x |
- checkmate::assert_flag(fill)+ checkmate::test_string(i), |
| 41 | -+ | 8x |
-
+ checkmate::test_number(i), |
| 42 | -16x | +8x |
- if (ncol(x) == 0L) {
+ checkmate::test_logical(i, len = length(x)) && sum(j) == 1 |
| 43 | -2x | +
- return(character(0L))+ ) || |
|
| 44 | -+ | 8x |
- }+ !any( |
| 45 | -+ | 8x |
-
+ checkmate::test_string(j), |
| 46 | -14x | +8x |
- labels <- sapply(x, function(i) as.vector(attr(i, "label", exact = TRUE)), simplify = FALSE, USE.NAMES = TRUE)+ checkmate::test_number(j), |
| 47 | -14x | +8x |
- mapply(+ checkmate::test_logical(j, len = length(x)) && sum(j) == 1 |
| 48 | -14x | +
- function(name, label) {
+ ) |
|
| 49 | -62x | +
- checkmate::assert_string(+ ) {
|
|
| 50 | -62x | +1x |
- label,+ stop( |
| 51 | -62x | +1x |
- .var.name = sprintf("\"label\" attribute of column \"%s\"", name),
+ "join_keys[i, j] - Can't extract keys for multiple pairs.", |
| 52 | -62x | +1x |
- null.ok = TRUE+ "When specifying a pair [i, j], both indices must point to a single key pair.\n", |
| 53 | -+ | 1x |
- )+ call. = FALSE |
| 54 |
- },+ ) |
||
| 55 | -14x | +
- name = names(x),+ } |
|
| 56 | -14x | +1x |
- label = labels+ if (is.numeric(i)) i <- names(x)[i] |
| 57 | -+ | 1x |
- )+ if (is.numeric(j)) j <- names(x)[j] |
| 59 | -12x | +7x |
- nulls <- vapply(labels, is.null, logical(1L))+ subset_x <- update_keys_given_parents(x[union(i, j)]) |
| 60 | -12x | +7x |
- if (any(nulls)) {
+ return(subset_x[[i]][[j]]) |
| 61 | -7x | +24x |
- labels[nulls] <-+ } else if (!missing(j)) {
|
| 62 | -7x | +
- if (fill) {
+ # ie. select all keys which have j as dataset_2 |
|
| 63 | -1x | +
- colnames(x)[nulls]+ # since list is symmetrical it is equivalent to selecting by i |
|
| 64 | -+ | 1x |
- } else {
+ i <- j |
| 65 | -7x | +
- NA_character_+ } |
|
| 66 |
- }+ |
||
| 67 | -+ | 24x |
- }+ checkmate::assert( |
| 68 | -+ | 24x |
-
+ combine = "or", |
| 69 | -12x | +24x |
- unlist(labels)+ checkmate::check_character(i), |
| 70 | -+ | 24x |
- }+ checkmate::check_numeric(i), |
| 71 | -+ | 24x |
-
+ checkmate::check_logical(i) |
| 72 |
- #' @rdname col_labels+ ) |
||
| 73 |
- #' @export+ |
||
| 74 |
- `col_labels<-` <- function(x, value) {
+
|
||
| 75 | -13x | +
- checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
+ # Convert integer/logical index to named index |
|
| 76 | -13x | +24x |
- checkmate::assert_character(value)+ if (checkmate::test_numeric(i) || checkmate::test_logical(i)) {
|
| 77 | -12x | +2x |
- checkmate::assert_true(+ i <- names(x)[i] |
| 78 | -12x | +
- ncol(x) == length(value),+ } |
|
| 79 | -12x | +
- .var.name = "Length of value is equal to the number of columns"+ |
|
| 80 |
- )+ # When retrieving a relationship pair, it will also return the symmetric key |
||
| 81 | -+ | 24x |
-
+ new_jk <- new_join_keys() |
| 82 | -11x | +24x |
- varnames <-+ queue <- unique(i) |
| 83 | -11x | +24x |
- if (is.null(names(value))) {
+ bin <- character(0) |
| 84 | -4x | +
- names(x)+ |
|
| 85 | -11x | +
- } else if (any(names(value) == "")) {
+ # Need to iterate on a mutating queue if subset of a dataset will also |
|
| 86 | -3x | +
- specified_cols <- names(value)[names(value) != ""]+ # select its parent as that parent might have relationships with others |
|
| 87 | -3x | +
- checkmate::assert_subset(specified_cols, names(x), .var.name = "names of value")+ # already selected. |
|
| 88 | -3x | +24x |
- res <- names(value)+ while (length(queue) > 0) {
|
| 89 | -3x | +53x |
- res[res == ""] <- setdiff(names(x), specified_cols)+ ix <- queue[1] |
| 90 | -3x | +53x |
- res+ queue <- queue[-1] |
| 91 | -+ | 53x |
- } else {
+ bin <- c(bin, ix) |
| 92 | -4x | +
- checkmate::assert_set_equal(names(value), names(x), .var.name = "names of value")+ |
|
| 93 | -3x | +53x |
- names(value)+ ix_parent <- parent(x, ix) |
| 94 |
- }+ |
||
| 95 | -+ | 53x |
-
+ if (checkmate::test_string(ix_parent, min.chars = 1) && !ix_parent %in% c(queue, bin)) {
|
| 96 | 10x |
- for (i in seq_along(value)) {
+ queue <- c(queue, ix_parent) |
|
| 97 | -40x | +
- if (is.na(value[i])) {
+ } |
|
| 98 | -2x | +
- attr(x[[varnames[i]]], "label") <- NULL+ |
|
| 99 | -+ | 53x |
- } else {
+ ix_valid_names <- names(x[[ix]]) %in% c(queue, bin) |
| 100 | -38x | +
- attr(x[[varnames[i]]], "label") <- value[[i]]+ |
|
| 101 | -+ | 53x |
- }+ new_jk[[ix]] <- x[[ix]][ix_valid_names] |
| 102 |
- }+ |
||
| 103 | -10x | +
- x+ # Add primary key of parent |
|
| 104 | -+ | 53x |
- }+ if (length(ix_parent) > 0) {
|
| 105 | -+ | 20x |
-
+ new_jk[[ix_parent]][[ix_parent]] <- x[[ix_parent]][[ix_parent]] |
| 106 |
- #' @rdname col_labels+ } |
||
| 107 |
- #' @export+ } |
||
| 108 |
- col_relabel <- function(x, ...) {
+
|
||
| 109 | -4x | +24x |
- checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
+ common_parents_ix <- names(parents(x)) %in% names(new_jk) & |
| 110 | -4x | +24x |
- if (missing(...)) {
+ parents(x) %in% names(new_jk) |
| 111 | -1x | +
- return(x)+ |
|
| 112 | -+ | 13x |
- }+ if (any(common_parents_ix)) parents(new_jk) <- parents(x)[common_parents_ix] |
| 113 | -3x | +
- value <- list(...)+ |
|
| 114 | -3x | +24x |
- varnames <- names(value)+ new_jk |
| 115 |
-
+ } |
||
| 116 | -3x | +
- checkmate::assert_subset(varnames, names(x), .var.name = "names of ...")+ |
|
| 117 | -2x | +
- lapply(value, checkmate::assert_string, .var.name = "element of ...", na.ok = TRUE)+ #' @rdname join_keys |
|
| 118 |
-
+ #' @order 2 |
||
| 119 | -2x | +
- for (i in seq_along(value)) {
+ #' |
|
| 120 | -2x | +
- if (is.na(value[i])) {
+ #' @param directed (`logical(1)`) Flag that indicates whether it should create |
|
| 121 | -1x | +
- attr(x[[varnames[i]]], "label") <- NULL+ #' a parent-child relationship between the datasets. |
|
| 122 |
- } else {
+ #' - `TRUE` (default) `dataset_1` is the parent of `dataset_2`; |
||
| 123 | -1x | +
- attr(x[[varnames[i]]], "label") <- value[[i]]+ #' - `FALSE` when the relationship is undirected. |
|
| 124 |
- }+ #' @section Functions: |
||
| 125 |
- }+ #' - `x[i, j] <- value`: Assignment of a key to pair `(i, j)`. |
||
| 126 | -2x | +
- x+ #' - `x[i] <- value`: This (without `j` parameter) **is not** a supported |
|
| 127 |
- }+ #' operation for `join_keys`. |
| 1 | +128 |
- #' Get code from `teal_data` object+ #' - `join_keys(x)[i, j] <- value`: Assignment to `join_keys` object stored in `x`, |
||
| 2 | +129 |
- #'+ #' such as a `teal_data` object or `join_keys` object itself. |
||
| 3 | +130 |
- #' Retrieve code from `teal_data` object.+ #' |
||
| 4 | +131 |
- #'+ #' @export |
||
| 5 | +132 |
- #' Retrieve code stored in `@code`, which (in principle) can be used to recreate all objects found in `@env`.+ #' @examples |
||
| 6 | +133 |
- #' Use `datanames` to limit the code to one or more of the datasets enumerated in `@datanames`.+ #' # Setting a new primary key --- |
||
| 7 | +134 |
#' |
||
| 8 | +135 |
- #' @section Extracting dataset-specific code:+ #' jk["ds4", "ds4"] <- "pk4" |
||
| 9 | +136 |
- #' When `datanames` is specified, the code returned will be limited to the lines needed to _create_+ #' jk["ds5", "ds5"] <- "pk5" |
||
| 10 | +137 |
- #' the requested datasets. The code stored in the `@code` slot is analyzed statically to determine+ #' |
||
| 11 | +138 |
- #' which lines the datasets of interest depend upon. The analysis works well when objects are created+ #' # Setting a single relationship pair --- |
||
| 12 | +139 |
- #' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations.+ #' |
||
| 13 | +140 |
- #'+ #' jk["ds1", "ds4"] <- c("pk1" = "pk4")
|
||
| 14 | +141 |
- #' Consider the following examples:+ #' |
||
| 15 | +142 |
- #'+ #' # Removing a key --- |
||
| 16 | +143 |
- #' _Case 1: Usual assignments._+ #' |
||
| 17 | +144 |
- #' ```r+ #' jk["ds5", "ds5"] <- NULL |
||
| 18 | +145 |
- #' data <- teal_data() |>+ `[<-.join_keys` <- function(x, i, j, directed = TRUE, value) {
|
||
| 19 | -+ | |||
| 146 | +11x |
- #' within({
+ checkmate::assert_flag(directed) |
||
| 20 | -+ | |||
| 147 | +11x |
- #' foo <- function(x) {
+ if (missing(i) || missing(j)) {
|
||
| 21 | -+ | |||
| 148 | +4x |
- #' x + 1+ stop("join_keys[i, j] specify both indices to set a key pair.")
|
||
| 22 | -+ | |||
| 149 | +7x |
- #' }+ } else if (!missing(i) && is.null(i) || !missing(j) && is.null(j)) {
|
||
| 23 | -+ | |||
| 150 | +2x |
- #' x <- 0+ stop("join_keys[i, j] neither i nor j can be NULL.")
|
||
| 24 | +151 |
- #' y <- foo(x)+ } else if ( |
||
| 25 | -+ | |||
| 152 | +5x |
- #' })+ !any( |
||
| 26 | -+ | |||
| 153 | +5x |
- #' get_code(data, datanames = "y")+ checkmate::test_string(i), |
||
| 27 | -+ | |||
| 154 | +5x |
- #' ```+ checkmate::test_number(i), |
||
| 28 | -+ | |||
| 155 | +5x |
- #' `x` has no dependencies, so `get_code(data, datanames = "x")` will return only the second call.\cr+ checkmate::test_logical(i, len = length(x)) && sum(j) == 1 |
||
| 29 | +156 |
- #' `y` depends on `x` and `foo`, so `get_code(data, datanames = "y")` will contain all three calls.+ ) || |
||
| 30 | -+ | |||
| 157 | +5x |
- #'+ !any( |
||
| 31 | -+ | |||
| 158 | +5x |
- #' _Case 2: Some objects are created by a function's side effects._+ checkmate::test_string(j), |
||
| 32 | -+ | |||
| 159 | +5x |
- #' ```r+ checkmate::test_number(j), |
||
| 33 | -+ | |||
| 160 | +5x |
- #' data <- teal_data() |>+ checkmate::test_logical(j, len = length(x)) && sum(j) == 1 |
||
| 34 | +161 |
- #' within({
+ ) |
||
| 35 | +162 |
- #' foo <- function() {
+ ) {
|
||
| 36 | -+ | |||
| 163 | +2x |
- #' x <<- x + 1+ stop( |
||
| 37 | -+ | |||
| 164 | +2x |
- #' }+ "join_keys[i, j] <- Can't set keys to specified indices.\n", |
||
| 38 | -+ | |||
| 165 | +2x |
- #' x <- 0+ "When setting pair [i, j], both indices must point to a single key pair.\n", |
||
| 39 | -+ | |||
| 166 | +2x |
- #' foo()+ call. = FALSE |
||
| 40 | +167 |
- #' y <- x+ ) |
||
| 41 | +168 |
- #' })+ } |
||
| 42 | +169 |
- #' get_code(data, datanames = "y")+ |
||
| 43 | +170 |
- #' ```+ # Handle join key removal separately |
||
| 44 | -+ | |||
| 171 | +3x |
- #' Here, `y` depends on `x` but `x` is modified by `foo` as a side effect (not by reassignment)+ if (is.null(value)) {
|
||
| 45 | -+ | |||
| 172 | +1x |
- #' and so `get_code(data, datanames = "y")` will not return the `foo()` call.\cr+ x[[i]][[j]] <- NULL |
||
| 46 | -+ | |||
| 173 | +1x |
- #' To overcome this limitation, code dependencies can be specified manually.+ return(x) |
||
| 47 | +174 |
- #' Lines where side effects occur can be flagged by adding "`# @linksto <object name>`" at the end.\cr+ } |
||
| 48 | +175 |
- #' Note that `within` evaluates code passed to `expr` as is and comments are ignored.+ |
||
| 49 | -+ | |||
| 176 | +2x |
- #' In order to include comments in code one must use the `eval_code` function instead.+ c(x, join_key(i, j, value, directed)) |
||
| 50 | +177 |
- #'+ } |
||
| 51 | +178 |
- #' ```r+ |
||
| 52 | +179 |
- #' data <- teal_data() |>+ #' @rdname join_keys |
||
| 53 | +180 |
- #' eval_code("
+ #' |
||
| 54 | +181 |
- #' foo <- function() {
+ #' @order 1000 |
||
| 55 | +182 |
- #' x <<- x + 1+ #' @usage ## Preferred method is x[i, j] <- value |
||
| 56 | +183 |
- #' }+ #' x[[i]][[j]] <- value |
||
| 57 | +184 |
- #' x <- 0+ #' |
||
| 58 | +185 |
- #' foo() # @linksto x+ #' @section Functions: |
||
| 59 | +186 |
- #' y <- x+ #' - `x[[i]][[j]] <- value`: It is equivalent as `x[i, j] <- value`. |
||
| 60 | +187 |
- #' ")+ #' |
||
| 61 | +188 |
- #' get_code(data, datanames = "y")+ #' @export |
||
| 62 | +189 |
- #' ```+ #' @examples |
||
| 63 | +190 |
- #' Now the `foo()` call will be properly included in the code required to recreate `y`.+ #' # Setting via x[[i]] <- value --- |
||
| 64 | +191 |
#' |
||
| 65 | +192 |
- #' Note that two functions that create objects as side effects, `assign` and `data`, are handled automatically.+ #' jk <- join_keys() |
||
| 66 | +193 |
- #'+ #' jk[["ds6"]][["ds6"]] <- "pk6" |
||
| 67 | +194 |
- #' Here are known cases where manual tagging is necessary:+ #' jk[["ds7"]] <- list(ds7 = "pk7", ds6 = c(pk7 = "pk6")) |
||
| 68 | +195 |
- #' - non-standard assignment operators, _e.g._ `%<>%`+ #' jk[["ds7"]][["ds7"]] <- NULL # removes key |
||
| 69 | +196 |
- #' - objects used as conditions in `if` statements: `if (<condition>)`+ #' |
||
| 70 | +197 |
- #' - objects used to iterate over in `for` loops: `for(i in <sequence>)`+ #' jk |
||
| 71 | +198 |
- #' - creating and evaluating language objects, _e.g._ `eval(<call>)`+ #' |
||
| 72 | +199 |
- #'+ #' @noRd |
||
| 73 | +200 |
- #'+ `[[<-.join_keys` <- function(x, i, value) {
|
||
| 74 | -+ | |||
| 201 | +397x |
- #' @param object (`teal_data`)+ checkmate::assert( |
||
| 75 | -+ | |||
| 202 | +397x |
- #' @param datanames `r lifecycle::badge("experimental")` (`character`) vector of dataset names to return the code for.
+ combine = "or", |
||
| 76 | -+ | |||
| 203 | +397x |
- #' For more details see the "Extracting dataset-specific code" section.+ checkmate::check_string(i), |
||
| 77 | -+ | |||
| 204 | +397x |
- #' @param deparse (`logical`) flag specifying whether to return code as `character` (`deparse = TRUE`) or as+ checkmate::check_number(i), |
||
| 78 | -+ | |||
| 205 | +397x |
- #' `expression` (`deparse = FALSE`).+ checkmate::check_logical(i, len = length(x)) |
||
| 79 | +206 |
- #' @param ... Parameters passed to internal methods. Currently, the only supported parameter is `check_names`+ ) |
||
| 80 | -+ | |||
| 207 | +397x |
- #' (`logical(1)`) flag, which is `TRUE` by default. Function warns about missing objects, if they do not exist in+ checkmate::assert_list(value, names = "named", types = "character", null.ok = TRUE) |
||
| 81 | -+ | |||
| 208 | +390x |
- #' `code` but are passed in `datanames`. To remove the warning, set `check_names = FALSE`.+ if (checkmate::test_numeric(i) || checkmate::test_logical(i)) {
|
||
| 82 | -+ | |||
| 209 | +1x |
- #'+ i <- names(x)[[i]] |
||
| 83 | +210 |
- #' @return+ } |
||
| 84 | +211 |
- #' Either a character string or an expression. If `datanames` is used to request a specific dataset,+ |
||
| 85 | +212 |
- #' only code that _creates_ that dataset (not code that uses it) is returned. Otherwise, all contents of `@code`.+ # Normalize values |
||
| 86 | -+ | |||
| 213 | +390x |
- #'+ norm_value <- lapply(seq_along(value), function(.x) {
|
||
| 87 | -+ | |||
| 214 | +551x |
- #' @examples+ join_key(i, names(value)[.x], value[[.x]]) |
||
| 88 | +215 |
- #' tdata1 <- teal_data()+ }) |
||
| 89 | -+ | |||
| 216 | +390x |
- #' tdata1 <- within(tdata1, {
+ names(norm_value) <- names(value) |
||
| 90 | +217 |
- #' a <- 1+ |
||
| 91 | +218 |
- #' b <- a^5+ # Check if multiple modifications don't have a conflict |
||
| 92 | -+ | |||
| 219 | +390x |
- #' c <- list(x = 2)+ repeated_value_ix <- names(value) %in% names(value)[duplicated(names(value))] |
||
| 93 | -+ | |||
| 220 | +390x |
- #' })+ repeated <- norm_value[repeated_value_ix] |
||
| 94 | -+ | |||
| 221 | +390x |
- #' get_code(tdata1)+ vapply( |
||
| 95 | -+ | |||
| 222 | +390x |
- #' get_code(tdata1, datanames = "a")+ seq_along(repeated), |
||
| 96 | -+ | |||
| 223 | +390x |
- #' get_code(tdata1, datanames = "b")+ function(.ix, .x_value = repeated[[.ix]], .x_name = names(.x_value[[1]])) {
|
||
| 97 | -+ | |||
| 224 | +3x |
- #'+ assert_compatible_keys2( |
||
| 98 | -+ | |||
| 225 | +3x |
- #' tdata2 <- teal_data(x1 = iris, code = "x1 <- iris")+ .x_value, |
||
| 99 | -+ | |||
| 226 | +3x |
- #' get_code(tdata2)+ unlist(unname( |
||
| 100 | -+ | |||
| 227 | +3x |
- #' get_code(verify(tdata2))+ repeated[-.ix][names(repeated[-.ix]) == .x_name] |
||
| 101 | -+ | |||
| 228 | +3x |
- #'+ ), recursive = FALSE) |
||
| 102 | +229 |
- #' @rdname get_code+ ) |
||
| 103 | +230 |
- #' @aliases get_code,teal_data-method+ }, |
||
| 104 | -+ | |||
| 231 | +390x |
- #'+ logical(1) |
||
| 105 | +232 |
- #' @export+ ) |
||
| 106 | +233 |
- setMethod("get_code", signature = "teal_data", definition = function(object, deparse = TRUE, datanames = NULL, ...) {
+
|
||
| 107 | -64x | +234 | +389x |
- checkmate::assert_character(datanames, min.len = 1L, null.ok = TRUE)+ norm_value <- lapply(norm_value, function(x) x[[1]][[1]]) |
| 108 | -64x | +235 | +389x |
- checkmate::assert_flag(deparse)+ names(norm_value) <- names(value) |
| 109 | +236 | |||
| 110 | +237 |
- # Normalize in case special it is backticked- |
- ||
| 111 | -64x | -
- if (!is.null(datanames)) {
+ # Safe to do as duplicated are the same |
||
| 112 | -60x | +238 | +389x |
- datanames <- gsub("^`(.*)`$", "\\1", datanames)
+ norm_value[duplicated(names(norm_value))] <- NULL |
| 113 | +239 |
- }+ |
||
| 114 | +240 |
-
+ # Keep only elements with length > 0L |
||
| 115 | -64x | +241 | +389x |
- code <- if (!is.null(datanames)) {
+ norm_value <- Filter(length, norm_value) |
| 116 | -60x | +|||
| 242 | +
- get_code_dependency(object@code, datanames, ...)+ |
|||
| 117 | +243 |
- } else {
+ # Remove classes to use list-based get/assign operations |
||
| 118 | -4x | +244 | +389x |
- object@code+ new_x <- unclass(x) |
| 119 | +245 |
- }+ |
||
| 120 | +246 |
-
+ # In case a pair is removed, also remove the symmetric pair and update parents |
||
| 121 | -64x | +247 | +389x |
- if (deparse) {
+ removed_names <- setdiff(names(new_x[[i]]), names(norm_value)) |
| 122 | -63x | +248 | +389x |
- if (length(code) == 0) {
+ for (.x in removed_names) {
|
| 123 | +249 | 2x |
- code- |
- |
| 124 | -- |
- } else {
+ if (identical(parent(x, .x), i)) attr(new_x, "parents")[[.x]] <- NULL |
||
| 125 | -61x | -
- paste(code, collapse = "\n")- |
- ||
| 126 | -+ | 250 | +1x |
- }+ if (identical(parent(x, i), .x)) attr(new_x, "parents")[[i]] <- NULL |
| 127 | +251 |
- } else {
+
|
||
| 128 | -1x | +252 | +5x |
- parse(text = paste(c("{", code, "}"), collapse = "\n"), keep.source = TRUE)
+ new_x[[.x]][[i]] <- NULL |
| 129 | +253 |
} |
||
| 130 | +254 |
- })+ |
| 1 | -+ | ||
| 255 | +389x |
- # get_code_dependency ----+ new_x[[i]] <- norm_value |
|
| 2 | +256 | ||
| 3 | +257 |
- #' Get code dependency of an object+ # Iterate on all new values to create symmetrical pair |
|
| 4 | -+ | ||
| 258 | +389x |
- #'+ for (ds2 in names(norm_value)) {
|
|
| 5 | -+ | ||
| 259 | +310x |
- #' Extract subset of code required to reproduce specific object(s), including code producing side-effects.+ if (ds2 == i) next |
|
| 6 | +260 |
- #'+ |
|
| 7 | -+ | ||
| 261 | +237x |
- #' Given a character vector with code, this function will extract the part of the code responsible for creating+ keep_value <- if (is.null(x)) list() else new_x[[ds2]] |
|
| 8 | +262 |
- #' the variables specified by `names`.+ |
|
| 9 | +263 |
- #' This includes the final call that creates the variable(s) in question as well as all _parent calls_,+ # Invert key |
|
| 10 | -+ | ||
| 264 | +237x |
- #' _i.e._ calls that create variables used in the final call and their parents, etc.+ new_value <- stats::setNames(names(norm_value[[ds2]]), norm_value[[ds2]]) |
|
| 11 | -+ | ||
| 265 | +237x |
- #' Also included are calls that create side-effects like establishing connections.+ keep_value[[i]] <- new_value |
|
| 12 | +266 |
- #'+ |
|
| 13 | +267 |
- #' It is assumed that object dependency is established by using three assignment operators: `<-`, `=`, and `->` .+ # Assign symmetrical |
|
| 14 | -+ | ||
| 268 | +237x |
- #' Other assignment methods (`assign`, `<<-`) or non-standard-evaluation methods are not supported.+ new_x[[ds2]] <- keep_value |
|
| 15 | +269 |
- #'+ } |
|
| 16 | +270 |
- #' Side-effects are not detected automatically and must be marked in the code.+ |
|
| 17 | -+ | ||
| 271 | +389x |
- #' Add `# @linksto object` at the end of a line where a side-effect occurs to specify that this line is required+ preserve_attr <- attributes(new_x)[!names(attributes(new_x)) %in% "names"] |
|
| 18 | +272 |
- #' to reproduce a variable called `object`.+ # Remove NULL or empty keys |
|
| 19 | -+ | ||
| 273 | +389x |
- #'+ new_x <- Filter(function(x) length(x) != 0L, new_x) |
|
| 20 | -+ | ||
| 274 | +389x |
- #' @param code `character` with the code.+ attributes(new_x) <- utils::modifyList(attributes(new_x), preserve_attr) |
|
| 21 | +275 |
- #' @param names `character` vector of object names.+ |
|
| 22 | +276 |
- #' @param check_names `logical(1)` flag specifying if a warning for non-existing names should be displayed.+ # |
|
| 23 | +277 |
- #'+ # restore class |
|
| 24 | -+ | ||
| 278 | +389x |
- #' @return Character vector, a subset of `code`.+ class(new_x) <- class(x) |
|
| 25 | -+ | ||
| 279 | +389x |
- #' Note that subsetting is actually done on the calls `code`, not necessarily on the elements of the vector.+ new_x |
|
| 26 | +280 |
- #'+ } |
| 27 | +1 |
- #' @keywords internal+ #' Create a relationship between a pair of datasets |
||
| 28 | +2 |
- get_code_dependency <- function(code, names, check_names = TRUE) {
- |
- ||
| 29 | -60x | -
- checkmate::assert_character(code)- |
- ||
| 30 | -60x | -
- checkmate::assert_character(names, any.missing = FALSE)+ #' |
||
| 31 | +3 | - - | -||
| 32 | -60x | -
- if (identical(code, character(0)) || identical(trimws(code), "")) {
+ #' @description |
||
| 33 | -2x | +|||
| 4 | +
- return(code)+ #' `r lifecycle::badge("stable")`
|
|||
| 34 | +5 |
- }+ #' |
||
| 35 | +6 |
-
+ #' Create a relationship between two datasets, `dataset_1` and `dataset_2`. |
||
| 36 | +7 |
- # If code is bound in curly brackets, remove them.+ #' By default, this function establishes a directed relationship with `dataset_1` as the parent. |
- ||
| 37 | -58x | +|||
| 8 | +
- tcode <- trimws(code)+ #' If `dataset_2` is not specified, the function creates a primary key for `dataset_1`. |
|||
| 38 | -58x | +|||
| 9 | +
- if (any(grepl("^\\{.*\\}$", tcode))) {
+ #' |
|||
| 39 | -2x | +|||
| 10 | +
- code <- sub("^\\{(.*)\\}$", "\\1", tcode)
+ #' @param dataset_1,dataset_2 (`character(1)`) Dataset names. When `dataset_2` is omitted, |
|||
| 40 | +11 |
- }+ #' a primary key for `dataset_1` is created. |
||
| 41 | +12 |
-
+ #' @param keys (optionally named `character`) Column mapping between the datasets, |
||
| 42 | +13 |
-
+ #' where `names(keys)` maps columns in `dataset_1` corresponding to columns of |
||
| 43 | -58x | +|||
| 14 | +
- code <- parse(text = code, keep.source = TRUE)+ #' `dataset_2` given by the elements of `keys`. |
|||
| 44 | -58x | +|||
| 15 | +
- pd <- utils::getParseData(code)+ #' - If unnamed, the same column names are used for both datasets. |
|||
| 45 | -58x | +|||
| 16 | +
- pd <- normalize_pd(pd)+ #' - If any element of the `keys` vector is empty with a non-empty name, then the name is |
|||
| 46 | -58x | +|||
| 17 | +
- calls_pd <- extract_calls(pd)+ #' used for both datasets. |
|||
| 47 | +18 |
-
+ #' @param directed (`logical(1)`) Flag that indicates whether it should create |
||
| 48 | +19 |
-
+ #' a parent-child relationship between the datasets. |
||
| 49 | -58x | +|||
| 20 | +
- if (check_names) {
+ #' - `TRUE` (default) `dataset_1` is the parent of `dataset_2`; |
|||
| 50 | +21 |
- # Detect if names are actually in code.+ #' - `FALSE` when the relationship is undirected. |
||
| 51 | -58x | +|||
| 22 | +
- symbols <- unlist(lapply(calls_pd, function(call) call[call$token == "SYMBOL", "text"]))+ #' |
|||
| 52 | -58x | +|||
| 23 | +
- if (any(pd$text == "assign")) {
+ #' @return object of class `join_key_set` to be passed into `join_keys` function. |
|||
| 53 | -4x | +|||
| 24 | +
- assign_calls <- Filter(function(call) find_call(call, "assign"), calls_pd)+ #' |
|||
| 54 | -4x | +|||
| 25 | +
- ass_str <- unlist(lapply(assign_calls, function(call) call[call$token == "STR_CONST", "text"]))+ #' @examples |
|||
| 55 | -4x | +|||
| 26 | +
- ass_str <- gsub("^['\"]|['\"]$", "", ass_str)
+ #' join_key("d1", "d2", c("A"))
|
|||
| 56 | -4x | +|||
| 27 | +
- symbols <- c(ass_str, symbols)+ #' join_key("d1", "d2", c("A" = "B"))
|
|||
| 57 | +28 |
- }+ #' join_key("d1", "d2", c("A" = "B", "C"))
|
||
| 58 | -58x | +|||
| 29 | +
- if (!all(names %in% unique(symbols))) {
+ #' |
|||
| 59 | -1x | +|||
| 30 | +
- warning("Object(s) not found in code: ", toString(setdiff(names, symbols)))
+ #' @export |
|||
| 60 | +31 |
- }+ #' @seealso [join_keys()], [parents()] |
||
| 61 | +32 |
- }+ #' |
||
| 62 | +33 |
-
+ join_key <- function(dataset_1, dataset_2 = dataset_1, keys, directed = TRUE) {
|
||
| 63 | -58x | +34 | +1103x |
- graph <- code_graph(calls_pd)+ checkmate::assert_string(dataset_1) |
| 64 | -58x | +35 | +1103x |
- ind <- unlist(lapply(names, function(x) graph_parser(x, graph)))+ checkmate::assert_string(dataset_2) |
| 65 | -+ | |||
| 36 | +1100x |
-
+ checkmate::assert_character(keys, any.missing = FALSE) |
||
| 66 | -58x | +37 | +1095x |
- lib_ind <- detect_libraries(calls_pd)+ checkmate::assert_flag(directed) |
| 67 | +38 | |||
| 68 | -58x | +39 | +1095x |
- as.character(code[sort(unique(c(lib_ind, ind)))])+ if (length(keys) > 0) {
|
| 69 | -+ | |||
| 40 | +1093x |
- }+ if (is.null(names(keys))) {
|
||
| 70 | -+ | |||
| 41 | +526x |
-
+ names(keys) <- keys |
||
| 71 | +42 |
- #' Locate function call token+ } |
||
| 72 | +43 |
- #'+ |
||
| 73 | -+ | |||
| 44 | +1093x |
- #' Determine which row of parsed data is specific `SYMBOL_FUNCTION_CALL` token.+ keys <- trimws(keys) |
||
| 74 | -+ | |||
| 45 | +1093x |
- #'+ names(keys) <- trimws(names(keys)) |
||
| 75 | +46 |
- #' Useful for determining occurrence of `assign` or `data` functions in an input call.+ |
||
| 76 | +47 |
- #'+ # Remove keys with empty value and without name |
||
| 77 | -+ | |||
| 48 | +1093x |
- #' @param call_pd `data.frame` as returned by `extract_calls()`+ if (any(keys == "" & names(keys) == "")) {
|
||
| 78 | -+ | |||
| 49 | +6x |
- #' @param text `character(1)` to look for in `text` column of `call_pd`+ message("Key with an empty value and name are ignored.")
|
||
| 79 | -+ | |||
| 50 | +6x |
- #'+ keys <- keys[keys != "" & names(keys) != ""] |
||
| 80 | +51 |
- #' @return+ } |
||
| 81 | +52 |
- #' Single integer specifying row in `call_pd` where `token` is `SYMBOL_FUNCTION_CALL` and `text` is `text`.+ |
||
| 82 | +53 |
- #' 0 if not found.+ # Set name of keys without one: c("A") -> c("A" = "A")
|
||
| 83 | -+ | |||
| 54 | +1093x | +
+ if (any(names(keys) == "")) {
+ |
+ ||
| 55 | +4x |
- #'+ names(keys)[names(keys) == ""] <- keys[names(keys) == ""] |
||
| 84 | +56 |
- #' @keywords internal+ } |
||
| 85 | +57 |
- #' @noRd+ |
||
| 86 | +58 |
- find_call <- function(call_pd, text) {
+ # Set value of keys with empty string, but non-empty name: c("A" = "") -> c("A" = "A")
|
||
| 87 | -405x | +59 | +1093x |
- checkmate::check_data_frame(call_pd)+ if (any(keys == "")) {
|
| 88 | -405x | +60 | +4x |
- checkmate::check_names(call_pd, must.include = c("token", "text"))
+ keys[keys == ""] <- names(keys[keys == ""]) |
| 89 | -405x | +|||
| 61 | +
- checkmate::check_string(text)+ } |
|||
| 90 | +62 | |||
| 91 | -405x | +63 | +1093x |
- ans <- which(call_pd$token == "SYMBOL_FUNCTION_CALL" & call_pd$text == text)+ stopifnot(!is.null(names(keys))) |
| 92 | -405x | +64 | +1093x |
- if (length(ans)) {
+ stopifnot(!anyDuplicated(keys)) |
| 93 | -25x | +65 | +1092x |
- ans+ stopifnot(!anyDuplicated(names(keys))) |
| 94 | +66 |
- } else {
+
|
||
| 95 | -380x | -
- 0L- |
- ||
| 96 | -- |
- }- |
- ||
| 97 | -- |
- }- |
- ||
| 98 | -+ | 67 | +1091x |
-
+ if (dataset_1 == dataset_2 && any(names(keys) != keys)) {
|
| 99 | -+ | |||
| 68 | +2x |
- #' Split the result of `utils::getParseData()` into separate calls+ stop("Keys within a dataset must match exactly: keys = c('A' = 'B') are not allowed")
|
||
| 100 | +69 |
- #'+ } |
||
| 101 | +70 |
- #' @param pd (`data.frame`) A result of `utils::getParseData()`.+ } else {
|
||
| 102 | -+ | |||
| 71 | +2x |
- #'+ keys <- NULL |
||
| 103 | +72 |
- #' @return+ } |
||
| 104 | +73 |
- #' A `list` of `data.frame`s.+ |
||
| 105 | -+ | |||
| 74 | +1091x |
- #' Each element is a subset of `pd` corresponding to one call in the original code from which `pd` was obtained.+ parents <- if (directed && dataset_1 != dataset_2) {
|
||
| 106 | -+ | |||
| 75 | +413x |
- #' Only four columns (`"token"`, `"text"`, `"id"`, `"parent"`) are kept, the rest is discarded.+ stats::setNames(list(dataset_1), dataset_2) |
||
| 107 | +76 |
- #'+ } else {
|
||
| 108 | -+ | |||
| 77 | +678x |
- #' @keywords internal+ list() |
||
| 109 | +78 |
- #' @noRd+ } |
||
| 110 | +79 |
- extract_calls <- function(pd) {
- |
- ||
| 111 | -58x | -
- calls <- lapply(+ |
||
| 112 | -58x | +80 | +1091x |
- pd[pd$parent == 0, "id"],+ structure( |
| 113 | -58x | +81 | +1091x |
- function(parent) {
+ list( |
| 114 | -194x | +82 | +1091x |
- rbind(+ structure( |
| 115 | -194x | +83 | +1091x |
- pd[pd$id == parent, c("token", "text", "id", "parent")],
+ list(keys), |
| 116 | -194x | +84 | +1091x |
- get_children(pd = pd, parent = parent)+ names = dataset_2 |
| 117 | +85 |
) |
||
| 118 | -- |
- }- |
- ||
| 119 | +86 |
- )+ ), |
||
| 120 | -58x | +87 | +1091x |
- calls <- Filter(function(call) !(nrow(call) == 1 && call$token == "';'"), calls)+ names = dataset_1, |
| 121 | -58x | +88 | +1091x |
- calls <- Filter(Negate(is.null), calls)+ class = "join_key_set", |
| 122 | -58x | +89 | +1091x |
- calls <- fix_shifted_comments(calls)+ parents = parents |
| 123 | -58x | +|||
| 90 | +
- fix_arrows(calls)+ ) |
|||
| 124 | +91 |
} |
| 125 | +1 |
-
+ setOldClass("join_keys")
|
||
| 126 | +2 |
- #' @keywords internal+ |
||
| 127 | +3 |
- #' @noRd+ #' Reproducible data |
||
| 128 | +4 |
- get_children <- function(pd, parent) {
- |
- ||
| 129 | -2657x | -
- idx_children <- abs(pd$parent) == parent- |
- ||
| 130 | -2657x | -
- children <- pd[idx_children, c("token", "text", "id", "parent")]
- |
- ||
| 131 | -2657x | -
- if (nrow(children) == 0) {
- |
- ||
| 132 | -1588x | -
- return(NULL)+ #' |
||
| 133 | +5 |
- }+ #' Reproducible data container class. Inherits code tracking behavior from [`teal.code::qenv-class`]. |
||
| 134 | +6 | - - | -||
| 135 | -1069x | -
- if (parent > 0) {
+ #' |
||
| 136 | -1069x | +|||
| 7 | +
- do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd)))+ #' This class provides an isolated environment in which to store and process data with all code being recorded. |
|||
| 137 | +8 |
- }+ #' The environment, code, data set names, and data joining keys are stored in their respective slots. |
||
| 138 | +9 |
- }+ #' These slots should never be accessed directly, use the provided get/set functions. |
||
| 139 | +10 |
-
+ #' |
||
| 140 | +11 |
- #' Fixes edge case of comments being shifted to the next call.+ #' As code is evaluated in `teal_data`, messages and warnings are stored in their respective slots. |
||
| 141 | +12 |
- #' @keywords internal+ #' If errors are raised, a `qenv.error` object is returned. |
||
| 142 | +13 |
- #' @noRd+ #' |
||
| 143 | +14 |
- fix_shifted_comments <- function(calls) {
+ #' @name teal_data-class |
||
| 144 | +15 |
- # If the first or the second token is a @linksto COMMENT,+ #' @rdname teal_data-class |
||
| 145 | +16 |
- # then it belongs to the previous call.+ #' |
||
| 146 | -58x | +|||
| 17 | +
- if (length(calls) >= 2) {
+ #' @slot env (`environment`) environment containing data sets and possibly auxiliary variables. |
|||
| 147 | -56x | +|||
| 18 | +
- for (i in 2:length(calls)) {
+ #' Access variables with [get_var()] or [`[[`]. |
|||
| 148 | -134x | +|||
| 19 | +
- comment_idx <- grep("@linksto", calls[[i]][, "text"])
+ #' No setter provided. Evaluate code to add variables into `@env`. |
|||
| 149 | -134x | +|||
| 20 | +
- if (isTRUE(comment_idx[1] <= 2)) {
+ #' @slot code (`character`) vector representing code necessary to reproduce the contents of `@env`. |
|||
| 150 | -4x | +|||
| 21 | +
- calls[[i - 1]] <- rbind(+ #' Access with [get_code()]. |
|||
| 151 | -4x | +|||
| 22 | +
- calls[[i - 1]],+ #' No setter provided. Evaluate code to append code to the slot. |
|||
| 152 | -4x | +|||
| 23 | +
- calls[[i]][seq_len(comment_idx[1]), ]+ #' @slot id (`integer`) random identifier assigned to each element of `@code`. Used internally. |
|||
| 153 | +24 |
- )+ #' @slot warnings (`character`) vector of warnings raised when evaluating code. |
||
| 154 | -4x | +|||
| 25 | +
- calls[[i]] <- calls[[i]][-seq_len(comment_idx[1]), ]+ #' Access with [get_warnings()]. |
|||
| 155 | +26 |
- }+ #' @slot messages (`character`) vector of messages raised when evaluating code. |
||
| 156 | +27 |
- }+ #' @slot join_keys (`join_keys`) object specifying joining keys for data sets in `@env`. |
||
| 157 | +28 |
- }+ #' Access or modify with [join_keys()]. |
||
| 158 | -58x | +|||
| 29 | +
- Filter(nrow, calls)+ #' @slot datanames (`character`) vector of names of data sets in `@env`. |
|||
| 159 | +30 |
- }+ #' Used internally to distinguish them from auxiliary variables. |
||
| 160 | +31 |
-
+ #' Access or modify with [datanames()]. |
||
| 161 | +32 |
- #' Fixes edge case of `<-` assignment operator being called as function,+ #' @slot verified (`logical(1)`) flag signifying that code in `@code` has been proven to yield contents of `@env`. |
||
| 162 | +33 |
- #' which is \code{`<-`(y,x)} instead of traditional `y <- x`.
+ #' Used internally. See [`verify()`] for more details. |
||
| 163 | +34 |
- #' @keywords internal+ #' |
||
| 164 | +35 |
- #' @noRd+ #' @import teal.code |
||
| 165 | +36 |
- fix_arrows <- function(calls) {
+ #' @keywords internal |
||
| 166 | -58x | +|||
| 37 | +
- checkmate::assert_list(calls)+ setClass( |
|||
| 167 | -58x | +|||
| 38 | +
- lapply(calls, function(call) {
+ Class = "teal_data", |
|||
| 168 | -191x | +|||
| 39 | +
- sym_fun <- call$token == "SYMBOL_FUNCTION_CALL"+ contains = "qenv", |
|||
| 169 | -191x | +|||
| 40 | +
- call[sym_fun, ] <- sub_arrows(call[sym_fun, ])+ slots = c(join_keys = "join_keys", datanames = "character", verified = "logical"), |
|||
| 170 | -191x | +|||
| 41 | +
- call+ prototype = list( |
|||
| 171 | +42 |
- })+ join_keys = join_keys(), |
||
| 172 | +43 |
- }+ datanames = character(0), |
||
| 173 | +44 |
-
+ verified = logical(0) |
||
| 174 | +45 |
- #' Execution of assignment operator substitutions for a call.+ ) |
||
| 175 | +46 |
- #' @keywords internal+ ) |
||
| 176 | +47 |
- #' @noRd+ |
||
| 177 | +48 |
- sub_arrows <- function(call) {
+ #' Initialize `teal_data` object |
||
| 178 | -191x | +|||
| 49 | +
- checkmate::assert_data_frame(call)+ #' |
|||
| 179 | -191x | +|||
| 50 | +
- map <- data.frame(+ #' @name new_teal_data |
|||
| 180 | -191x | +|||
| 51 | +
- row.names = c("<-", "<<-", "="),
+ #' |
|||
| 181 | -191x | +|||
| 52 | +
- token = rep("LEFT_ASSIGN", 3),
+ #' @param data (`named list`) of data objects. |
|||
| 182 | -191x | +|||
| 53 | +
- text = rep("<-", 3)
+ #' @param code (`character` or `language`) code to reproduce the `data`. |
|||
| 183 | +54 |
- )+ #' Accepts and stores comments also. |
||
| 184 | -191x | +|||
| 55 | +
- sub_ids <- call$text %in% rownames(map)+ #' @param join_keys (`join_keys`) object |
|||
| 185 | -191x | +|||
| 56 | +
- call[sub_ids, c("token", "text")] <- map[call$text[sub_ids], ]
+ #' @param datanames (`character`) names of datasets passed to `data`. |
|||
| 186 | -191x | +|||
| 57 | +
- call+ #' Needed when non-dataset objects are needed in the `env` slot. |
|||
| 187 | +58 |
- }+ #' @rdname new_teal_data |
||
| 188 | +59 |
-
+ #' @keywords internal |
||
| 189 | +60 |
- # code_graph ----+ new_teal_data <- function(data, |
||
| 190 | +61 |
-
+ code = character(0), |
||
| 191 | +62 |
- #' Create object dependencies graph within parsed code+ join_keys = join_keys(), |
||
| 192 | +63 |
- #'+ datanames = names(data)) {
+ |
+ ||
| 64 | +48x | +
+ checkmate::assert_list(data) |
||
| 193 | -+ | |||
| 65 | +48x |
- #' Builds dependency graph that identifies dependencies between objects in parsed code.+ checkmate::assert_class(join_keys, "join_keys") |
||
| 194 | -+ | |||
| 66 | +23x |
- #' Helps understand which objects depend on which.+ if (is.null(datanames)) datanames <- character(0) # todo: allow to specify |
||
| 195 | -+ | |||
| 67 | +48x |
- #'+ checkmate::assert_character(datanames) |
||
| 196 | -+ | |||
| 68 | +48x |
- #' @param calls_pd `list` of `data.frame`s;+ if (!any(is.language(code), is.character(code))) {
|
||
| 197 | -+ | |||
| 69 | +! |
- #' result of `utils::getParseData()` split into subsets representing individual calls;+ stop("`code` must be a character or language object.")
|
||
| 198 | +70 |
- #' created by `extract_calls()` function+ } |
||
| 199 | +71 |
- #'+ |
||
| 200 | -+ | |||
| 72 | +48x |
- #' @return+ if (is.language(code)) {
|
||
| 201 | -+ | |||
| 73 | +2x |
- #' A list (of length of input `calls_pd`) where each element represents one call.+ code <- paste(lang2calls(code), collapse = "\n") |
||
| 202 | +74 |
- #' Each element is a character vector listing names of objects that depend on this call+ } |
||
| 203 | -+ | |||
| 75 | +48x |
- #' and names of objects that this call depends on.+ if (length(code)) {
|
||
| 204 | -+ | |||
| 76 | +6x |
- #' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
+ code <- paste(code, collapse = "\n") |
||
| 205 | +77 |
- #' depends on objects `b` and `c`.+ } |
||
| 206 | -+ | |||
| 78 | +48x |
- #' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.+ verified <- (length(code) == 0L && length(data) == 0L) |
||
| 207 | +79 |
- #'+ |
||
| 208 | -+ | |||
| 80 | +48x |
- #' @keywords internal+ id <- sample.int(.Machine$integer.max, size = length(code)) |
||
| 209 | +81 |
- #' @noRd+ |
||
| 210 | -+ | |||
| 82 | +48x |
- code_graph <- function(calls_pd) {
+ new_env <- rlang::env_clone(list2env(data), parent = parent.env(.GlobalEnv)) |
||
| 211 | -58x | +83 | +48x |
- cooccurrence <- extract_occurrence(calls_pd)+ lockEnvironment(new_env, bindings = TRUE) |
| 212 | +84 | |||
| 213 | -58x | +85 | +48x |
- side_effects <- extract_side_effects(calls_pd)+ datanames <- .get_sorted_datanames(datanames = datanames, join_keys = join_keys, env = new_env) |
| 214 | +86 | |||
| 215 | -58x | +87 | +48x |
- mapply(c, side_effects, cooccurrence, SIMPLIFY = FALSE)+ methods::new( |
| 216 | -+ | |||
| 88 | +48x |
- }+ "teal_data", |
||
| 217 | -+ | |||
| 89 | +48x |
-
+ env = new_env, |
||
| 218 | -+ | |||
| 90 | +48x |
- #' Extract object occurrence+ code = code, |
||
| 219 | -+ | |||
| 91 | +48x |
- #'+ warnings = rep("", length(code)),
|
||
| 220 | -+ | |||
| 92 | +48x |
- #' Extracts objects occurrence within calls passed by `calls_pd`.+ messages = rep("", length(code)),
|
||
| 221 | -+ | |||
| 93 | +48x |
- #' Also detects which objects depend on which within a call.+ id = id, |
||
| 222 | -+ | |||
| 94 | +48x |
- #'+ join_keys = join_keys, |
||
| 223 | -+ | |||
| 95 | +48x |
- #' @param calls_pd `list` of `data.frame`s;+ datanames = datanames, |
||
| 224 | -+ | |||
| 96 | +48x |
- #' result of `utils::getParseData()` split into subsets representing individual calls;+ verified = verified |
||
| 225 | +97 |
- #' created by `extract_calls()` function+ ) |
||
| 226 | +98 |
- #'+ } |
| 227 | +1 |
- #' @return+ #' @rdname join_keys |
||
| 228 | +2 |
- #' A list (of length of input `calls_pd`) where each element represents one call.+ #' @order 7 |
||
| 229 | +3 |
- #' Each element is a character vector listing names of objects that depend on this call+ #' @export |
||
| 230 | +4 |
- #' and names of objects that this call depends on.+ format.join_keys <- function(x, ...) {
|
||
| 231 | -+ | |||
| 5 | +6x |
- #' Dependencies are listed after the `"<-"` string, e.g. `c("a", "<-", "b", "c")` means that in this call object `a`
+ if (length(x) > 0) {
|
||
| 232 | -+ | |||
| 6 | +5x |
- #' depends on objects `b` and `c`.+ my_parents <- parents(x) |
||
| 233 | -+ | |||
| 7 | +5x |
- #' If a call is tagged with `@linksto a`, then object `a` is understood to depend on that call.+ names_sorted <- topological_sort(my_parents) |
||
| 234 | -+ | |||
| 8 | +5x |
- #'+ names <- union(names_sorted, names(x)) |
||
| 235 | -+ | |||
| 9 | +5x |
- #' @keywords internal+ x_implicit <- update_keys_given_parents(x) |
||
| 236 | -+ | |||
| 10 | +5x |
- #' @noRd+ out <- lapply(names, function(i) {
|
||
| 237 | -+ | |||
| 11 | +15x |
- extract_occurrence <- function(calls_pd) {
+ out_i <- lapply(union(i, names(x[[i]])), function(j) {
|
||
| 238 | -58x | +12 | +35x |
- is_in_function <- function(x) {
+ direction <- if (identical(my_parents[[j]], i)) {
|
| 239 | +13 |
- # If an object is a function parameter,+ " <-- " |
||
| 240 | -+ | |||
| 14 | +35x |
- # then in calls_pd there is a `SYMBOL_FORMALS` entry for that object.+ } else if (identical(my_parents[[i]], j)) {
|
||
| 241 | -177x | +|||
| 15 | +
- function_id <- x[x$token == "FUNCTION", "parent"]+ " --> " |
|||
| 242 | -177x | +16 | +35x |
- if (length(function_id)) {
+ } else if (!identical(i, j)) {
|
| 243 | -22x | +|||
| 17 | +
- x$id %in% get_children(x, function_id[1])$id+ " <-> " |
|||
| 244 | +18 |
- } else {
+ } else {
|
||
| 245 | -155x | +|||
| 19 | +
- rep(FALSE, nrow(x))+ "" |
|||
| 246 | +20 |
- }+ } |
||
| 247 | +21 |
- }+ |
||
| 248 | -58x | +22 | +35x |
- in_parenthesis <- function(x) {
+ keys <- x[[i]][[j]] |
| 249 | -154x | +23 | +35x |
- if (any(x$token %in% c("LBB", "'['"))) {
+ sprintf( |
| 250 | -5x | +24 | +35x |
- id_start <- min(x$id[x$token %in% c("LBB", "'['")])
+ "%s%s: [%s]", |
| 251 | -5x | +25 | +35x |
- id_end <- min(x$id[x$token == "']'"])+ direction, j, |
| 252 | -5x | +26 | +35x |
- x$text[x$token == "SYMBOL" & x$id > id_start & x$id < id_end]+ if (length(keys) == 0) "no primary keys" else toString(keys) |
| 253 | +27 |
- }+ ) |
||
| 254 | +28 |
- }+ }) |
||
| 255 | -58x | +|||
| 29 | +
- lapply(+ |
|||
| 256 | -58x | +30 | +15x |
- calls_pd,+ implicit_datasets <- setdiff(names(x_implicit[[i]]), names(x[[i]])) |
| 257 | -58x | +31 | +15x |
- function(call_pd) {
+ if (length(implicit_datasets) > 0) {
|
| 258 | -+ | |||
| 32 | +2x |
- # Handle data(object)/data("object")/data(object, envir = ) independently.
+ out_i <- c( |
||
| 259 | -191x | +33 | +2x |
- data_call <- find_call(call_pd, "data")+ out_i, |
| 260 | -191x | +34 | +2x |
- if (data_call) {
+ paste0( |
| 261 | -3x | +35 | +2x |
- sym <- call_pd[data_call + 1, "text"]+ " --* (implicit via parent with): ", |
| 262 | -3x | +36 | +2x |
- return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
+ paste(implicit_datasets, collapse = ", ") |
| 263 | +37 |
- }+ ) |
||
| 264 | +38 |
- # Handle assign(x = ).+ ) |
||
| 265 | -188x | +|||
| 39 | ++ |
+ }+ |
+ ||
| 40 | +
- assign_call <- find_call(call_pd, "assign")+ |
|||
| 266 | -188x | +41 | +15x |
- if (assign_call) {
+ paste(out_i, collapse = "\n") |
| 267 | +42 |
- # Check if parameters were named.+ }) |
||
| 268 | -+ | |||
| 43 | +5x |
- # "','" is for unnamed parameters, where "SYMBOL_SUB" is for named.+ paste( |
||
| 269 | -+ | |||
| 44 | +5x |
- # "EQ_SUB" is for `=` appearing after the name of the named parameter.+ c( |
||
| 270 | -11x | +45 | +5x |
- if (any(call_pd$token == "SYMBOL_SUB")) {
+ sprintf("A join_keys object containing foreign keys between %s datasets:", length(x)),
|
| 271 | -8x | +46 | +5x |
- params <- call_pd[call_pd$token %in% c("SYMBOL_SUB", "','", "EQ_SUB"), "text"]
+ out |
| 272 | +47 |
- # Remove sequence of "=", ",".+ ), |
||
| 273 | -8x | +48 | +5x |
- if (length(params > 1)) {
+ collapse = "\n" |
| 274 | -8x | +|||
| 49 | +
- remove <- integer(0)+ ) |
|||
| 275 | -8x | +|||
| 50 | +
- for (i in 2:length(params)) {
+ } else {
|
|||
| 276 | -36x | +51 | +1x |
- if (params[i - 1] == "=" & params[i] == ",") {
+ "An empty join_keys object." |
| 277 | -8x | +|||
| 52 | +
- remove <- c(remove, i - 1, i)+ } |
|||
| 278 | +53 |
- }+ } |
||
| 279 | +54 |
- }+ |
||
| 280 | -7x | +|||
| 55 | +
- if (length(remove)) params <- params[-remove]+ #' @rdname join_keys |
|||
| 281 | +56 | ++ |
+ #' @order 7+ |
+ |
| 57 | ++ |
+ #' @export+ |
+ ||
| 58 |
- }+ print.join_keys <- function(x, ...) {
|
|||
| 282 | -8x | +59 | +1x |
- pos <- match("x", setdiff(params, ","), nomatch = match(",", params, nomatch = 0))
+ cat(format(x, ...), "\n") |
| 283 | -8x | +60 | +1x |
- if (!pos) {
+ invisible(x) |
| 284 | -! | +|||
| 61 | +
- return(character(0L))+ } |
| 285 | +1 |
- }+ #' Variable labels |
||
| 286 | +2 |
- # pos is indicator of the place of 'x'+ #' |
||
| 287 | +3 |
- # 1. All parameters are named, but none is 'x' - return(character(0L))+ #' Get or set variable labels in a `data.frame`. |
||
| 288 | +4 |
- # 2. Some parameters are named, 'x' is in named parameters: match("x", setdiff(params, ","))
+ #' |
||
| 289 | +5 |
- # - check "x" in params being just a vector of named parameters.+ #' @details Variable labels can be stored as a `label` attribute set on individual variables. |
||
| 290 | +6 |
- # 3. Some parameters are named, 'x' is not in named parameters+ #' These functions get or set this attribute, either on all (`col_labels`) or some variables (`col_relabel`). |
||
| 291 | +7 |
- # - check first appearance of "," (unnamed parameter) in vector parameters.+ #' |
||
| 292 | +8 |
- } else {
+ #' @param x (`data.frame` or `DataFrame`) data object |
||
| 293 | +9 |
- # Object is the first entry after 'assign'.- |
- ||
| 294 | -3x | -
- pos <- 1+ #' @param fill (`logical(1)`) specifying what to return if variable has no label |
||
| 295 | +10 |
- }- |
- ||
| 296 | -11x | -
- sym <- call_pd[assign_call + pos, "text"]- |
- ||
| 297 | -11x | -
- return(c(gsub("^['\"]|['\"]$", "", sym), "<-"))
+ #' @param value (`character`) vector of variable labels of length equal to number of columns in `x`; |
||
| 298 | +11 |
- }+ #' if named, names must match variable names in `x` and will be used as key to set labels; |
||
| 299 | +12 |
-
+ #' use `NA` to remove label from variable |
||
| 300 | +13 |
- # What occurs in a function body is not tracked.- |
- ||
| 301 | -177x | -
- x <- call_pd[!is_in_function(call_pd), ]+ #' @param ... name-value pairs, where name corresponds to a variable name in `x` |
||
| 302 | -177x | +|||
| 14 | +
- sym_cond <- which(x$token %in% c("SPECIAL", "SYMBOL", "SYMBOL_FUNCTION_CALL"))
+ #' and value is the new variable label; use `NA` to remove label from variable |
|||
| 303 | +15 |
-
+ #' |
||
| 304 | -177x | +|||
| 16 | +
- if (length(sym_cond) == 0) {
+ #' @return |
|||
| 305 | -4x | +|||
| 17 | +
- return(character(0L))+ #' For `col_labels`, named character vector of variable labels, the names being the corresponding variable names. |
|||
| 306 | +18 |
- }+ #' If the `label` attribute is missing, the vector elements will be |
||
| 307 | +19 |
- # Watch out for SYMBOLS after $ and @. For x$a x@a: x is object, a is not.+ #' the variable names themselves if `fill = TRUE` and `NA` if `fill = FALSE`. |
||
| 308 | +20 |
- # For x$a, a's ID is $'s ID-2 so we need to remove all IDs that have ID = $ID - 2.+ #' |
||
| 309 | -173x | +|||
| 21 | +
- dollar_ids <- x[x$token %in% c("'$'", "'@'"), "id"]
+ #' For `col_labels<-` and `col_relabel`, copy of `x` with variable labels modified. |
|||
| 310 | -173x | +|||
| 22 | +
- if (length(dollar_ids)) {
+ #' |
|||
| 311 | -12x | +|||
| 23 | +
- object_ids <- x[sym_cond, "id"]+ #' @examples |
|||
| 312 | -12x | +|||
| 24 | +
- after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids]+ #' x <- iris |
|||
| 313 | -12x | +|||
| 25 | +
- sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar))+ #' col_labels(x) |
|||
| 314 | +26 |
- }+ #' col_labels(x) <- paste("label for", names(iris))
|
||
| 315 | +27 |
-
+ #' col_labels(x) |
||
| 316 | -173x | +|||
| 28 | +
- ass_cond <- grep("ASSIGN", x$token)
+ #' y <- col_relabel(x, Sepal.Length = "Sepal Length of iris flower") |
|||
| 317 | -173x | +|||
| 29 | +
- if (!length(ass_cond)) {
+ #' col_labels(y) |
|||
| 318 | -19x | +|||
| 30 | +
- return(c("<-", unique(x[sym_cond, "text"])))
+ #' |
|||
| 319 | +31 |
- }+ #' @source These functions were taken from |
||
| 320 | +32 |
-
+ #' [formatters](https://cran.r-project.org/package=formatters) package, to reduce the complexity of |
||
| 321 | -154x | +|||
| 33 | +
- sym_cond <- sym_cond[sym_cond > ass_cond] # NOTE 1+ #' the dependency tree and rewritten. |
|||
| 322 | +34 |
- # If there was an assignment operation detect direction of it.+ #' |
||
| 323 | -154x | +|||
| 35 | +
- if (unique(x$text[ass_cond]) == "->") { # NOTE 2
+ #' @rdname col_labels |
|||
| 324 | -1x | +|||
| 36 | +
- sym_cond <- rev(sym_cond)+ #' @export |
|||
| 325 | +37 |
- }+ #' |
||
| 326 | +38 |
-
+ col_labels <- function(x, fill = FALSE) {
|
||
| 327 | -154x | +39 | +16x |
- after <- match(min(x$id[ass_cond]), sort(x$id[c(min(ass_cond), sym_cond)])) - 1+ checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
|
| 328 | -154x | +40 | +16x |
- ans <- append(x[sym_cond, "text"], "<-", after = max(1, after))+ checkmate::assert_flag(fill) |
| 329 | -154x | +|||
| 41 | +
- roll <- in_parenthesis(call_pd)+ |
|||
| 330 | -154x | +42 | +16x |
- if (length(roll)) {
+ if (ncol(x) == 0L) {
|
| 331 | +43 | 2x |
- c(setdiff(ans, roll), roll)+ return(character(0L)) |
|
| 332 | +44 |
- } else {
+ } |
||
| 333 | -152x | +|||
| 45 | +
- ans+ |
|||
| 334 | -+ | |||
| 46 | +14x |
- }+ labels <- sapply(x, function(i) as.vector(attr(i, "label", exact = TRUE)), simplify = FALSE, USE.NAMES = TRUE) |
||
| 335 | -+ | |||
| 47 | +14x |
-
+ mapply( |
||
| 336 | -+ | |||
| 48 | +14x |
- ### NOTE 2: What if there are 2 assignments: e.g. a <- b -> c.+ function(name, label) {
|
||
| 337 | -+ | |||
| 49 | +62x |
- ### NOTE 1: For cases like 'eval(expression(b <- b + 2))' removes 'eval(expression('.
+ checkmate::assert_string( |
||
| 338 | -+ | |||
| 50 | +62x |
- }+ label, |
||
| 339 | -+ | |||
| 51 | +62x |
- )+ .var.name = sprintf("\"label\" attribute of column \"%s\"", name),
|
||
| 340 | -+ | |||
| 52 | +62x |
- }+ null.ok = TRUE |
||
| 341 | +53 |
-
+ ) |
||
| 342 | +54 |
- #' Extract side effects+ }, |
||
| 343 | -+ | |||
| 55 | +14x |
- #'+ name = names(x), |
||
| 344 | -+ | |||
| 56 | +14x |
- #' Extracts all object names from the code that are marked with `@linksto` tag.+ label = labels |
||
| 345 | +57 |
- #'+ ) |
||
| 346 | +58 |
- #' The code may contain functions calls that create side effects, e.g. modify the environment.+ |
||
| 347 | -+ | |||
| 59 | +12x |
- #' Static code analysis may be insufficient to determine which objects are created or modified by such a function call.+ nulls <- vapply(labels, is.null, logical(1L)) |
||
| 348 | -+ | |||
| 60 | +12x |
- #' The `@linksto` comment tag is introduced to mark a call as having a (side) effect on one or more objects.+ if (any(nulls)) {
|
||
| 349 | -+ | |||
| 61 | +7x |
- #' With this tag a complete object dependency structure can be established.+ labels[nulls] <- |
||
| 350 | -+ | |||
| 62 | +7x |
- #' Read more about side effects and the usage of `@linksto` tag in [`get_code_dependencies()`] function.+ if (fill) {
|
||
| 351 | -+ | |||
| 63 | +1x |
- #'+ colnames(x)[nulls] |
||
| 352 | +64 |
- #' @param calls_pd `list` of `data.frame`s;+ } else {
|
||
| 353 | -+ | |||
| 65 | +7x |
- #' result of `utils::getParseData()` split into subsets representing individual calls;+ NA_character_ |
||
| 354 | +66 |
- #' created by `extract_calls()` function+ } |
||
| 355 | +67 |
- #'+ } |
||
| 356 | +68 |
- #' @return+ |
||
| 357 | -+ | |||
| 69 | +12x |
- #' A list of length equal to that of `calls_pd`, where each element is a character vector of names of objects+ unlist(labels) |
||
| 358 | +70 |
- #' depending a call tagged with `@linksto` in a corresponding element of `calls_pd`.+ } |
||
| 359 | +71 |
- #'+ |
||
| 360 | +72 |
- #' @keywords internal+ #' @rdname col_labels |
||
| 361 | +73 |
- #' @noRd+ #' @export |
||
| 362 | +74 |
- extract_side_effects <- function(calls_pd) {
+ `col_labels<-` <- function(x, value) {
|
||
| 363 | -58x | +75 | +13x |
- lapply(+ checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
|
| 364 | -58x | +76 | +13x |
- calls_pd,+ checkmate::assert_character(value) |
| 365 | -58x | +77 | +12x |
- function(x) {
+ checkmate::assert_true( |
| 366 | -191x | +78 | +12x |
- linksto <- grep("@linksto", x[x$token == "COMMENT", "text"], value = TRUE)
+ ncol(x) == length(value), |
| 367 | -191x | -
- unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", linksto), "\\s+"))
- |
- ||
| 368 | -+ | 79 | +12x |
- }+ .var.name = "Length of value is equal to the number of columns" |
| 369 | +80 |
) |
||
| 370 | +81 |
- }+ |
||
| 371 | -+ | |||
| 82 | +11x |
-
+ varnames <- |
||
| 372 | -+ | |||
| 83 | +11x |
- # graph_parser ----+ if (is.null(names(value))) {
|
||
| 373 | -+ | |||
| 84 | +4x |
-
+ names(x) |
||
| 374 | -+ | |||
| 85 | +11x |
- #' Return the indices of calls needed to reproduce an object+ } else if (any(names(value) == "")) {
|
||
| 375 | -+ | |||
| 86 | +3x |
- #'+ specified_cols <- names(value)[names(value) != ""] |
||
| 376 | -+ | |||
| 87 | +3x |
- #' @param x The name of the object to return code for.+ checkmate::assert_subset(specified_cols, names(x), .var.name = "names of value") |
||
| 377 | -+ | |||
| 88 | +3x |
- #' @param graph A result of `code_graph()`.+ res <- names(value) |
||
| 378 | -+ | |||
| 89 | +3x |
- #'+ res[res == ""] <- setdiff(names(x), specified_cols) |
||
| 379 | -+ | |||
| 90 | +3x |
- #' @return+ res |
||
| 380 | +91 |
- #' Integer vector of indices that can be applied to `graph` to obtain all calls required to reproduce object `x`.+ } else {
|
||
| 381 | -+ | |||
| 92 | +4x |
- #'+ checkmate::assert_set_equal(names(value), names(x), .var.name = "names of value") |
||
| 382 | -+ | |||
| 93 | +3x |
- #' @keywords internal+ names(value) |
||
| 383 | +94 |
- #' @noRd+ } |
||
| 384 | +95 |
- graph_parser <- function(x, graph) {
- |
- ||
| 385 | -244x | -
- occurrence <- vapply(- |
- ||
| 386 | -244x | -
- graph,- |
- ||
| 387 | -244x | -
- function(call) {
+
|
||
| 388 | -652x | +96 | +10x |
- ind <- match("<-", call, nomatch = length(call) + 1L)
+ for (i in seq_along(value)) {
|
| 389 | -652x | -
- x %in% call[seq_len(ind - 1L)]- |
- ||
| 390 | -+ | 97 | +40x |
- },+ if (is.na(value[i])) {
|
| 391 | -244x | -
- logical(1)- |
- ||
| 392 | -+ | 98 | +2x |
- )+ attr(x[[varnames[i]]], "label") <- NULL |
| 393 | +99 | - - | -||
| 394 | -244x | -
- dependencies <- lapply(graph[occurrence], function(call) {
+ } else {
|
||
| 395 | -122x | +100 | +38x |
- ind <- match("<-", call, nomatch = 0L)
+ attr(x[[varnames[i]]], "label") <- value[[i]] |
| 396 | -122x | +|||
| 101 | +
- call[(ind + 1L):length(call)]+ } |
|||
| 397 | +102 |
- })+ } |
||
| 398 | -244x | +103 | +10x |
- dependencies <- setdiff(unlist(dependencies), x)+ x |
| 399 | +104 |
-
+ } |
||
| 400 | -244x | +|||
| 105 | +
- if (length(dependencies) && any(occurrence)) {
+
|
|||
| 401 | -91x | +|||
| 106 | +
- dependency_ids <- lapply(dependencies, function(dependency) {
+ #' @rdname col_labels |
|||
| 402 | -185x | +|||
| 107 | +
- graph_parser(dependency, graph[1:max(which(occurrence))])+ #' @export |
|||
| 403 | +108 |
- })+ col_relabel <- function(x, ...) {
|
||
| 404 | -91x | +109 | +4x |
- sort(unique(c(which(occurrence), unlist(dependency_ids))))+ checkmate::test_multi_class(x, c("data.frame", "DataFrame"))
|
| 405 | -+ | |||
| 110 | +4x |
- } else {
+ if (missing(...)) {
|
||
| 406 | -153x | +111 | +1x |
- which(occurrence)+ return(x) |
| 407 | +112 |
} |
||
| 408 | -+ | |||
| 113 | +3x |
- }+ value <- list(...) |
||
| 409 | -+ | |||
| 114 | +3x |
-
+ varnames <- names(value) |
||
| 410 | +115 | |||
| 411 | -+ | |||
| 116 | +3x |
- # default_side_effects --------------------------------------------------------------------------------------------+ checkmate::assert_subset(varnames, names(x), .var.name = "names of ...") |
||
| 412 | -+ | |||
| 117 | +2x |
-
+ lapply(value, checkmate::assert_string, .var.name = "element of ...", na.ok = TRUE) |
||
| 413 | +118 |
- #' Detect library calls+ |
||
| 414 | -+ | |||
| 119 | +2x |
- #'+ for (i in seq_along(value)) {
|
||
| 415 | -+ | |||
| 120 | +2x |
- #' Detects `library()` and `require()` function calls.+ if (is.na(value[i])) {
|
||
| 416 | -+ | |||
| 121 | +1x |
- #'+ attr(x[[varnames[i]]], "label") <- NULL |
||
| 417 | +122 |
- #' @param calls_pd `list` of `data.frame`s;+ } else {
|
||
| 418 | -+ | |||
| 123 | +1x |
- #' result of `utils::getParseData()` split into subsets representing individual calls;+ attr(x[[varnames[i]]], "label") <- value[[i]] |
||
| 419 | +124 |
- #' created by `extract_calls()` function+ } |
||
| 420 | +125 |
- #'+ } |
||
| 421 | -+ | |||
| 126 | +2x |
- #' @return+ x |
||
| 422 | +127 |
- #' Integer vector of indices that can be applied to `graph` (result of `code_graph()`) to obtain all calls containing+ } |
| 423 | +1 |
- #' `library()` or `require()` calls that are always returned for reproducibility.+ #' The names of a `join_keys` object |
||
| 424 | +2 |
#' |
||
| 425 | +3 |
- #' @keywords internal+ #' @inheritParams base::`names<-` |
||
| 426 | +4 |
- #' @noRd+ #' @export |
||
| 427 | +5 |
- detect_libraries <- function(calls_pd) {
+ `names<-.join_keys` <- function(x, value) {
|
||
| 428 | -58x | +6 | +2x |
- defaults <- c("library", "require")
+ new_x <- unclass(x) |
| 429 | -+ | |||
| 7 | +2x |
-
+ parent_list <- parents(x) |
||
| 430 | -58x | +|||
| 8 | +
- which(+ # Update inner keys |
|||
| 431 | -58x | +9 | +2x |
- vapply(+ for (old_name in setdiff(names(new_x), value)) {
|
| 432 | -58x | +10 | +3x |
- calls_pd,+ old_entry <- new_x[[old_name]] |
| 433 | -58x | +11 | +3x |
- function(call) {
+ new_name <- value[names(new_x) == old_name] |
| 434 | -191x | +|||
| 12 | +
- any(call$token == "SYMBOL_FUNCTION_CALL" & call$text %in% defaults)+ |
|||
| 435 | +13 |
- },+ # Change 2nd-tier first |
||
| 436 | -58x | +14 | +3x |
- logical(1)+ for (sub_name in names(old_entry)) {
|
| 437 | -+ | |||
| 15 | +7x |
- )+ names(new_x[[sub_name]])[names(new_x[[sub_name]]) == old_name] <- new_name |
||
| 438 | +16 |
- )+ } |
||
| 439 | +17 |
- }+ |
||
| 440 | +18 |
-
+ # Change in first tier |
||
| 441 | -+ | |||
| 19 | +3x |
- #' Normalize parsed data removing backticks from symbols+ names(new_x)[names(new_x) == old_name] <- new_name |
||
| 442 | +20 |
- #'+ |
||
| 443 | +21 |
- #' @param pd `data.frame` resulting from `utils::getParseData()` call.+ # changing name in the parents |
||
| 444 | -+ | |||
| 22 | +3x |
- #'+ if (length(parent_list)) {
|
||
| 445 | -+ | |||
| 23 | +3x |
- #' @return `data.frame` with backticks removed from `text` column for `SYMBOL` tokens.+ names(parent_list)[names(parent_list) == old_name] <- new_name |
||
| 446 | -+ | |||
| 24 | +3x |
- #'+ ind <- vapply(parent_list, identical, logical(1), old_name) |
||
| 447 | -+ | |||
| 25 | +3x |
- #' @keywords internal+ parent_list[ind] <- new_name |
||
| 448 | -+ | |||
| 26 | +3x |
- #' @noRd+ attr(new_x, "parents") <- parent_list |
||
| 449 | +27 |
- normalize_pd <- function(pd) {
+ } |
||
| 450 | +28 |
- # Remove backticks from SYMBOL tokens- |
- ||
| 451 | -58x | -
- symbol_index <- grepl("^SYMBOL.*$", pd$token)
- |
- ||
| 452 | -58x | -
- pd[symbol_index, "text"] <- gsub("^`(.*)`$", "\\1", pd[symbol_index, "text"])
+ } |
||
| 453 | +29 | |||
| 454 | -58x | +30 | +2x | +
+ class(new_x) <- c("join_keys", "list")
+ |
+
| 31 | +2x |
- pd+ new_x |
||
| 455 | +32 |
}@@ -12129,14 +8741,14 @@ teal.data coverage - 89.08% |
| 1 |
- #' Test if two objects are (nearly) equal+ #' Topological graph sort |
|||
| 3 |
- #' `all.equal(target, current)` is a utility to compare `join_keys` objects target+ #' Graph is a `list` which for each node contains a vector of child nodes |
|||
| 4 |
- #' and current testing `near equality`.+ #' in the returned list, parents appear before their children. |
|||
| 6 |
- #' If they are different, comparison is still made to some extent, and a report+ #' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements. |
|||
| 7 |
- #' of the differences is returned.+ #' |
|||
| 8 |
- #' Do not use `all.equal` directly in if expressions—either use `isTRUE(all.equal(....))`+ #' @param graph (`named list`) with node vector elements |
|||
| 9 |
- #' or identical if appropriate.+ #' @keywords internal |
|||
| 10 |
- #'+ topological_sort <- function(graph) {
|
|||
| 11 |
- #' The parents attribute comparison tolerates `NULL` and empty lists and will find+ # compute in-degrees |
|||
| 12 | -+ | 498x |
- #' no difference.+ in_degrees <- list() |
|
| 13 | -+ | 498x |
- #'+ for (node in names(graph)) {
|
|
| 14 | -+ | 231x |
- #' The list containing all the relationships is treated like a map and ignores+ in_degrees[[node]] <- 0 |
|
| 15 | -+ | 231x |
- #' entries with `NULL` if they exist.+ for (to_edge in graph[[node]]) {
|
|
| 16 | -+ | 184x |
- #'+ in_degrees[[to_edge]] <- 0 |
|
| 17 |
- #' @inheritParams base::all.equal+ } |
|||
| 18 |
- #' @param ... further arguments for different methods. Not used with `join_keys`.+ } |
|||
| 19 |
- #'+ |
|||
| 20 | -+ | 498x |
- #' @seealso [base::all.equal()]+ for (node in graph) {
|
|
| 21 | -+ | 231x |
- #' @keywords internal+ for (to_edge in node) {
|
|
| 22 | -+ | 184x |
- #'+ in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1 |
|
| 23 |
- all.equal.join_keys <- function(target, current, ...) {
+ } |
|||
| 24 | -21x | +
- .as_map <- function(.x) {
+ } |
||
| 25 | -42x | +
- old_attributes <- attributes(.x)+ |
||
| 26 |
- # Keep only non-list attributes+ # sort |
|||
| 27 | -42x | +498x |
- old_attributes[["names"]] <- NULL+ visited <- 0 |
|
| 28 | -42x | +498x |
- old_attributes[["original_class"]] <- old_attributes[["class"]]+ sorted <- list() |
|
| 29 | -42x | +498x |
- old_attributes[["class"]] <- NULL+ zero_in <- list() |
|
| 30 | -42x | +498x |
- old_attributes[["parents"]] <- if (!length(old_attributes[["parents"]])) {
+ for (node in names(in_degrees)) {
|
|
| 31 | -18x | +200x |
- list()+ if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node) |
|
| 32 |
- } else {
+ } |
|||
| 33 | -24x | +498x |
- old_attributes[["parents"]][order(names(old_attributes[["parents"]]))]+ zero_in <- rev(zero_in) |
|
| 34 |
- }+ |
|||
| 35 | -42x | +498x |
- attr(.x, "class") <- "list"+ while (length(zero_in) != 0) {
|
|
| 36 | -+ | 357x |
-
+ visited <- visited + 1 |
|
| 37 | -+ | 357x |
- # Remove nulls+ sorted <- c(zero_in[[1]], sorted) |
|
| 38 | -42x | +357x |
- .x <- Filter(Negate(is.null), .x)+ for (edge_to in graph[[zero_in[[1]]]]) {
|
|
| 39 | -+ | 176x |
-
+ in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1 |
|
| 40 | -+ | 176x |
- # Sort named components, preserving positions of unnamed+ if (in_degrees[[edge_to]] == 0) {
|
|
| 41 | -42x | +157x |
- nx <- rlang::names2(.x)+ zero_in <- append(zero_in, edge_to, 1) |
|
| 42 | -42x | +
- is_named <- nx != ""+ } |
||
| 43 | -42x | +
- if (any(is_named)) {
+ } |
||
| 44 | -42x | +357x |
- idx <- seq_along(.x)+ zero_in[[1]] <- NULL |
|
| 45 | -42x | +
- idx[is_named] <- idx[is_named][order(nx[is_named])]+ } |
||
| 46 | -42x | +
- .x <- .x[idx]+ |
||
| 47 | -+ | 498x |
- }+ if (visited != length(in_degrees)) {
|
|
| 48 | -42x | +4x |
- new_attributes <- if (is.null(attributes(.x))) list() else attributes(.x)+ stop( |
|
| 49 | -42x | +4x |
- attributes(.x) <- utils::modifyList(old_attributes, new_attributes)+ "Graph is not a directed acyclic graph. Cycles involving nodes: ", |
|
| 50 | -42x | +4x |
- .x+ paste0(setdiff(names(in_degrees), sorted), collapse = " ") |
|
| 51 |
- }+ )+ |
+ |||
| 52 | ++ |
+ } else {
+ |
+ ||
| 53 | +494x | +
+ return(sorted)+ |
+ ||
| 54 | ++ |
+ }+ |
+ ||
| 55 | ++ |
+ }+ |
+ ||
| 56 | ++ | + + | +||
| 57 | ++ |
+ #' Checks whether a graph is a `Directed Acyclic Graph (DAG)`+ |
+ ||
| 58 | ++ |
+ #'+ |
+ ||
| 59 | ++ |
+ #' @inheritParams topological_sort+ |
+ ||
| 60 | ++ |
+ #' @return `logical(1)` `TRUE` if the graph is a `DAG`; `FALSE` otherwise |
||
| 52 | -21x | +|||
| 61 | +
- x <- .as_map(target)+ #' @keywords internal |
|||
| 53 | -21x | +|||
| 62 | +
- y <- .as_map(current)+ is_dag <- function(graph) {
|
|||
| 54 | -21x | +63 | +433x |
- all.equal(x, y)+ inherits(try(topological_sort(graph), silent = TRUE), "try-error") |
| 55 | +64 |
}@@ -12520,1942 +9195,1958 @@ teal.data coverage - 89.08% |
| 1 |
- #' The names of a `join_keys` object+ #' Manage relationships between datasets using `join_keys` |
||
| 2 |
- #'+ #' @order 1 |
||
| 3 |
- #' @inheritParams base::`names<-`+ #' @name join_keys |
||
| 4 |
- #' @export+ #' |
||
| 5 |
- `names<-.join_keys` <- function(x, value) {
+ #' @usage ## Constructor, getter and setter |
||
| 6 | -2x | +
- new_x <- unclass(x)+ #' join_keys(...) |
|
| 7 | -2x | +
- parent_list <- parents(x)+ #' |
|
| 8 |
- # Update inner keys+ #' @description |
||
| 9 | -2x | +
- for (old_name in setdiff(names(new_x), value)) {
+ #' Facilitates the creation and retrieval of relationships between datasets. |
|
| 10 | -3x | +
- old_entry <- new_x[[old_name]]+ #' `join_keys` class extends `list` and contains keys connecting pairs of datasets. |
|
| 11 | -3x | +
- new_name <- value[names(new_x) == old_name]+ #' Each element of the list contains keys for specific dataset. |
|
| 12 |
-
+ #' Each dataset can have a relationship with itself (primary key) and with other datasets. |
||
| 13 |
- # Change 2nd-tier first+ #' |
||
| 14 | -3x | +
- for (sub_name in names(old_entry)) {
+ #' Note that `join_keys` list is symmetrical and assumes a default direction, that is: |
|
| 15 | -7x | +
- names(new_x[[sub_name]])[names(new_x[[sub_name]]) == old_name] <- new_name+ #' when keys are set between `ds1` and `ds2`, it defines `ds1` as the parent |
|
| 16 |
- }+ #' in a parent-child relationship and the mapping is automatically mirrored between |
||
| 17 |
-
+ #' `ds2` and `ds1`. |
||
| 18 |
- # Change in first tier+ #' |
||
| 19 | -3x | +
- names(new_x)[names(new_x) == old_name] <- new_name+ #' @section Methods (by class): |
|
| 20 |
-
+ #' - `join_keys()`: Returns an empty `join_keys` object when called without arguments. |
||
| 21 |
- # changing name in the parents+ #' - `join_keys(join_keys)`: Returns itself. |
||
| 22 | -3x | +
- if (length(parent_list)) {
+ #' - `join_keys(teal_data)`: Returns the `join_keys` object contained in `teal_data` object. |
|
| 23 | -3x | +
- names(parent_list)[names(parent_list) == old_name] <- new_name+ #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters. |
|
| 24 | -3x | +
- ind <- vapply(parent_list, identical, logical(1), old_name)+ #' |
|
| 25 | -3x | +
- parent_list[ind] <- new_name+ #' @param ... optional, |
|
| 26 | -3x | +
- attr(new_x, "parents") <- parent_list+ #' - either `teal_data` or `join_keys` object to extract `join_keys` |
|
| 27 |
- }+ #' - or any number of `join_key_set` objects to create `join_keys` |
||
| 28 |
- }+ #' - or nothing to create an empty `join_keys` |
||
| 29 |
-
+ #' @param value For `x[i, j, directed = TRUE)] <- value` (named/unnamed `character`) |
||
| 30 | -2x | +
- class(new_x) <- c("join_keys", "list")
+ #' Column mapping between datasets. |
|
| 31 | -2x | +
- new_x+ #' |
|
| 32 |
- }+ #' For `join_keys(x) <- value`: (`join_key_set` or list of `join_key_set`) relationship |
| 1 | +33 |
- #' Topological graph sort+ #' pairs to add to `join_keys` list. |
||
| 2 | +34 |
#' |
||
| 3 | +35 |
- #' Graph is a `list` which for each node contains a vector of child nodes+ #' |
||
| 4 | +36 |
- #' in the returned list, parents appear before their children.+ #' @return `join_keys` object. |
||
| 5 | +37 |
#' |
||
| 6 | +38 |
- #' Implementation of `Kahn` algorithm with a modification to maintain the order of input elements.+ #' @examples |
||
| 7 | +39 |
- #'+ #' # Creating a new join keys ---- |
||
| 8 | +40 |
- #' @param graph (`named list`) with node vector elements+ #' |
||
| 9 | +41 |
- #' @keywords internal+ #' jk <- join_keys( |
||
| 10 | +42 |
- topological_sort <- function(graph) {
+ #' join_key("ds1", "ds1", "pk1"),
|
||
| 11 | +43 |
- # compute in-degrees+ #' join_key("ds2", "ds2", "pk2"),
|
||
| 12 | -547x | +|||
| 44 | +
- in_degrees <- list()+ #' join_key("ds3", "ds3", "pk3"),
|
|||
| 13 | -547x | +|||
| 45 | +
- for (node in names(graph)) {
+ #' join_key("ds1", "ds2", c(pk1 = "pk2")),
|
|||
| 14 | -241x | +|||
| 46 | +
- in_degrees[[node]] <- 0+ #' join_key("ds1", "ds3", c(pk1 = "pk3"))
|
|||
| 15 | -241x | +|||
| 47 | +
- for (to_edge in graph[[node]]) {
+ #' ) |
|||
| 16 | -184x | +|||
| 48 | +
- in_degrees[[to_edge]] <- 0+ #' |
|||
| 17 | +49 |
- }+ #' jk |
||
| 18 | +50 |
- }+ #' |
||
| 19 | +51 |
-
+ #' @export |
||
| 20 | -547x | +|||
| 52 | +
- for (node in graph) {
+ #' |
|||
| 21 | -241x | +|||
| 53 | +
- for (to_edge in node) {
+ #' @seealso [join_key()] for creating `join_keys_set`, |
|||
| 22 | -184x | +|||
| 54 | +
- in_degrees[[to_edge]] <- in_degrees[[to_edge]] + 1+ #' [parents()] for parent operations, |
|||
| 23 | +55 |
- }+ #' [teal_data()] for `teal_data` constructor _and_ |
||
| 24 | +56 |
- }+ #' [default_cdisc_join_keys] for default CDISC keys. |
||
| 25 | +57 |
-
+ #' |
||
| 26 | +58 |
- # sort+ join_keys <- function(...) {
|
||
| 27 | -547x | +59 | +771x |
- visited <- 0+ if (missing(...)) {
|
| 28 | -547x | +60 | +196x |
- sorted <- list()+ return(new_join_keys())+ |
+
| 61 | ++ |
+ } |
||
| 29 | -547x | +62 | +575x |
- zero_in <- list()+ x <- rlang::list2(...) |
| 30 | -547x | +63 | +575x |
- for (node in names(in_degrees)) {
+ if (length(x) == 1L) {
|
| 31 | -210x | +64 | +510x |
- if (in_degrees[[node]] == 0) zero_in <- append(zero_in, node)+ UseMethod("join_keys", x[[1]])
|
| 32 | +65 |
- }+ } else {
|
||
| 33 | -547x | +66 | +65x |
- zero_in <- rev(zero_in)+ join_keys.default(...) |
| 34 | +67 |
-
+ } |
||
| 35 | -547x | +|||
| 68 | +
- while (length(zero_in) != 0) {
+ } |
|||
| 36 | -367x | +|||
| 69 | +
- visited <- visited + 1+ |
|||
| 37 | -367x | +|||
| 70 | +
- sorted <- c(zero_in[[1]], sorted)+ #' @rdname join_keys |
|||
| 38 | -367x | +|||
| 71 | +
- for (edge_to in graph[[zero_in[[1]]]]) {
+ #' @order 1 |
|||
| 39 | -176x | +|||
| 72 | +
- in_degrees[[edge_to]] <- in_degrees[[edge_to]] - 1+ #' @export |
|||
| 40 | -176x | +|||
| 73 | +
- if (in_degrees[[edge_to]] == 0) {
+ join_keys.default <- function(...) {
|
|||
| 41 | -157x | +74 | +113x |
- zero_in <- append(zero_in, edge_to, 1)+ c(new_join_keys(), ...) |
| 42 | +75 |
- }+ } |
||
| 43 | +76 |
- }+ |
||
| 44 | -367x | +|||
| 77 | +
- zero_in[[1]] <- NULL+ #' @rdname join_keys |
|||
| 45 | +78 |
- }+ #' @order 1 |
||
| 46 | +79 |
-
+ #' @export |
||
| 47 | -547x | +|||
| 80 | +
- if (visited != length(in_degrees)) {
+ join_keys.join_keys <- function(...) {
|
|||
| 48 | -4x | +81 | +457x |
- stop(+ x <- rlang::list2(...) |
| 49 | -4x | +82 | +457x |
- "Graph is not a directed acyclic graph. Cycles involving nodes: ",+ x[[1]] |
| 50 | -4x | +|||
| 83 | +
- paste0(setdiff(names(in_degrees), sorted), collapse = " ")+ } |
|||
| 51 | +84 |
- )+ |
||
| 52 | +85 |
- } else {
+ #' @rdname join_keys |
||
| 53 | -543x | +|||
| 86 | +
- return(sorted)+ #' @order 1 |
|||
| 54 | +87 |
- }+ #' @export |
||
| 55 | +88 |
- }+ join_keys.teal_data <- function(...) {
+ |
+ ||
| 89 | +5x | +
+ x <- rlang::list2(...)+ |
+ ||
| 90 | +5x | +
+ x[[1]]@join_keys |
||
| 56 | +91 |
-
+ } |
||
| 57 | +92 |
- #' Checks whether a graph is a `Directed Acyclic Graph (DAG)`+ |
||
| 58 | +93 |
- #'+ #' @rdname join_keys |
||
| 59 | +94 |
- #' @inheritParams topological_sort+ #' @order 5 |
||
| 60 | +95 |
- #' @return `logical(1)` `TRUE` if the graph is a `DAG`; `FALSE` otherwise+ #' |
||
| 61 | +96 |
- #' @keywords internal+ #' @section Functions: |
||
| 62 | +97 |
- is_dag <- function(graph) {
+ #' - `join_keys(x) <- value`: Assignment of the `join_keys` in object with `value`. |
||
| 63 | -433x | +|||
| 98 | +
- inherits(try(topological_sort(graph), silent = TRUE), "try-error")+ #' `value` needs to be an object of class `join_keys` or `join_key_set`. |
|||
| 64 | +99 |
- }+ #' |
-
| 1 | +100 |
- #' Show `teal_data` object+ #' @param x (`join_keys`) empty object to set the new relationship pairs. |
|
| 2 | +101 |
- #'+ #' `x` is typically an object of `join_keys` class. When called with the `join_keys(x)` |
|
| 3 | +102 |
- #' Prints `teal_data` object.+ #' or `join_keys(x) <- value` then it can also take a supported class (`teal_data`, `join_keys`) |
|
| 4 | +103 |
#' |
|
| 5 | +104 |
- #' @param object (`teal_data`)+ #' @export |
|
| 6 | +105 |
- #' @return Input `teal_data` object.+ `join_keys<-` <- function(x, value) {
|
|
| 7 | -+ | ||
| 106 | +16x |
- #' @importFrom methods show+ checkmate::assert_class(value, classes = c("join_keys", "list"))
+ |
+ |
| 107 | +16x | +
+ UseMethod("join_keys<-", x)
|
|
| 8 | +108 |
- #' @examples+ } |
|
| 9 | +109 |
- #' teal_data()+ |
|
| 10 | +110 |
- #' teal_data(x = iris, code = "x = iris")+ #' @rdname join_keys |
|
| 11 | +111 |
- #' verify(teal_data(x = iris, code = "x = iris"))+ #' @order 5 |
|
| 12 | +112 |
#' @export |
|
| 13 | +113 |
- setMethod("show", signature = "teal_data", function(object) {
+ #' @examples |
|
| 14 | -! | +||
| 114 | +
- if (object@verified) {
+ #' # Assigning keys via join_keys(x)[i, j] <- value ---- |
||
| 15 | -! | +||
| 115 | +
- cat("\u2705\ufe0e", "verified teal_data object\n")
+ #' |
||
| 16 | +116 |
- } else {
+ #' obj <- join_keys() |
|
| 17 | -! | +||
| 117 | +
- cat("\u2716", "unverified teal_data object\n")
+ #' # or |
||
| 18 | +118 |
- }+ #' obj <- teal_data() |
|
| 19 | -! | +||
| 119 | +
- rlang::env_print(object@env)+ #' |
||
| 20 | +120 |
- })+ #' join_keys(obj)["ds1", "ds1"] <- "pk1" |
| 1 | +121 |
- #' Check Compatibility of keys+ #' join_keys(obj)["ds2", "ds2"] <- "pk2" |
||
| 2 | +122 |
- #'+ #' join_keys(obj)["ds3", "ds3"] <- "pk3" |
||
| 3 | +123 |
- #' Helper function to assert if two key sets contain incompatible keys.+ #' join_keys(obj)["ds1", "ds2"] <- c(pk1 = "pk2") |
||
| 4 | +124 |
- #'+ #' join_keys(obj)["ds1", "ds3"] <- c(pk1 = "pk3") |
||
| 5 | +125 |
- #' @return Returns `TRUE` if successful, otherwise raises error.+ #' |
||
| 6 | +126 |
- #' @keywords internal+ #' identical(jk, join_keys(obj)) |
||
| 7 | +127 |
- assert_compatible_keys <- function(join_key_1, join_key_2) {
+ `join_keys<-.join_keys` <- function(x, value) {
|
||
| 8 | -3x | +128 | +10x |
- stop_message <- function(dataset_1, dataset_2) {
+ value |
| 9 | -1x | +|||
| 129 | +
- stop(+ } |
|||
| 10 | -1x | +|||
| 130 | +
- paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2)
+
|
|||
| 11 | +131 |
- )+ #' @rdname join_keys |
||
| 12 | +132 |
- }+ #' @order 5 |
||
| 13 | +133 |
-
+ #' @export |
||
| 14 | -3x | +|||
| 134 | +
- dataset_1_one <- names(join_key_1)+ #' @examples |
|||
| 15 | -3x | +|||
| 135 | +
- dataset_2_one <- names(join_key_1[[1]])+ #' # Setter for join_keys within teal_data ---- |
|||
| 16 | -3x | +|||
| 136 | +
- keys_one <- join_key_1[[1]][[1]]+ #' |
|||
| 17 | +137 |
-
+ #' td <- teal_data() |
||
| 18 | -3x | +|||
| 138 | +
- dataset_1_two <- names(join_key_2)+ #' join_keys(td) <- jk |
|||
| 19 | -3x | +|||
| 139 | +
- dataset_2_two <- names(join_key_2[[1]])+ #' |
|||
| 20 | -3x | +|||
| 140 | +
- keys_two <- join_key_2[[1]][[1]]+ #' join_keys(td)["ds1", "ds2"] <- "new_key" |
|||
| 21 | +141 |
-
+ #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3")))
|
||
| 22 | +142 |
- # if first datasets and the second datasets match and keys+ #' join_keys(td) |
||
| 23 | +143 |
- # must contain the same named elements+ `join_keys<-.teal_data` <- function(x, value) {
|
||
| 24 | -3x | +144 | +6x |
- if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) {
+ join_keys(x@join_keys) <- value+ |
+
| 145 | +6x | +
+ datanames(x) <- x@datanames # datanames fun manages some exceptions+ |
+ ||
| 146 | +6x | +
+ x |
||
| 25 | -3x | +|||
| 147 | +
- if (!identical(sort(keys_one), sort(keys_two))) {
+ } |
|||
| 26 | -1x | +|||
| 148 | +
- stop_message(dataset_1_one, dataset_2_one)+ |
|||
| 27 | +149 |
- }+ #' Internal constructor |
||
| 28 | +150 |
- }+ #' |
||
| 29 | +151 |
-
+ #' @return an empty `join_keys` list |
||
| 30 | +152 |
- # if first dataset of join_key_1 matches second dataset of join_key_2+ #' |
||
| 31 | +153 |
- # and the first dataset of join_key_2 must match second dataset of join_key_1+ #' @keywords internal |
||
| 32 | +154 |
- # and keys must contain the same elements but with names and values swapped+ new_join_keys <- function() {
|
||
| 33 | -2x | +155 | +333x |
- if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) {
+ structure( |
| 34 | -+ | |||
| 156 | +333x |
- if (+ list(), |
||
| 35 | -! | +|||
| 157 | +333x |
- xor(length(keys_one) == 0, length(keys_two) == 0) ||+ class = c("join_keys", "list"),
|
||
| 36 | -! | +|||
| 158 | +333x |
- !identical(sort(keys_one), sort(stats::setNames(names(keys_two), keys_two)))+ "parents" = list() |
||
| 37 | +159 |
- ) {
+ ) |
||
| 38 | -! | +|||
| 160 | +
- stop_message(dataset_1_one, dataset_2_one)+ } |
| 39 | +1 |
- }+ #' Verify code reproducibility |
||
| 40 | +2 |
- }+ #' |
||
| 41 | +3 |
-
+ #' Checks whether code in `teal_data` object reproduces the stored objects. |
||
| 42 | +4 |
- # otherwise they are compatible+ #' |
||
| 43 | -2x | +|||
| 5 | +
- return(TRUE)+ #' If objects created by code in the `@code` slot of `x` are `all_equal` to the contents of the `@env` slot, |
|||
| 44 | +6 |
- }+ #' the function updates the `@verified` slot to `TRUE` in the returned `teal_data` object. |
||
| 45 | +7 |
-
+ #' Once verified, the slot will always be set to `TRUE`. |
||
| 46 | +8 |
- #' Validate parent-child key+ #' If the `@code` fails to recreate objects in `teal_data@env`, an error is raised. |
||
| 47 | +9 |
#' |
||
| 48 | +10 |
- #' Helper function checks the parent-child relations are valid.+ #' @return Input `teal_data` object or error. |
||
| 49 | +11 |
#' |
||
| 50 | +12 |
- #' @param x (`join_keys`) object to assert validity of relations+ #' @param x `teal_data` object |
||
| 51 | +13 |
- #'+ #' @examples |
||
| 52 | +14 |
- #' @return `join_keys` invisibly+ #' tdata1 <- teal_data() |
||
| 53 | +15 |
- #'+ #' tdata1 <- within(tdata1, {
|
||
| 54 | +16 |
- #' @keywords internal+ #' a <- 1 |
||
| 55 | +17 |
- assert_parent_child <- function(x) {
+ #' b <- a^5 |
||
| 56 | -441x | +|||
| 18 | +
- jk <- join_keys(x)+ #' c <- list(x = 2) |
|||
| 57 | -441x | +|||
| 19 | +
- jk_parents <- parents(jk)+ #' }) |
|||
| 58 | +20 |
-
+ #' verify(tdata1) |
||
| 59 | -441x | +|||
| 21 | +
- checkmate::assert_class(jk, c("join_keys", "list"))
+ #' |
|||
| 60 | +22 |
-
+ #' tdata2 <- teal_data(x1 = iris, code = "x1 <- iris") |
||
| 61 | -441x | +|||
| 23 | +
- if (!is.null(jk_parents)) {
+ #' verify(tdata2) |
|||
| 62 | -441x | +|||
| 24 | +
- for (idx1 in seq_along(jk_parents)) {
+ #' verify(tdata2)@verified |
|||
| 63 | -177x | +|||
| 25 | +
- name_from <- names(jk_parents)[[idx1]]+ #' tdata2@verified |
|||
| 64 | -177x | +|||
| 26 | +
- for (idx2 in seq_along(jk_parents[[idx1]])) {
+ #' |
|||
| 65 | -177x | +|||
| 27 | +
- name_to <- jk_parents[[idx1]][[idx2]]+ #' tdata3 <- teal_data() |
|||
| 66 | -177x | +|||
| 28 | +
- keys_from <- jk[[name_from]][[name_to]]+ #' tdata3 <- within(tdata3, {
|
|||
| 67 | -177x | +|||
| 29 | +
- keys_to <- jk[[name_to]][[name_from]]+ #' stop("error")
|
|||
| 68 | -177x | +|||
| 30 | +
- if (length(keys_from) == 0 && length(keys_to) == 0) {
+ #' }) |
|||
| 69 | -1x | +|||
| 31 | ++ |
+ #' try(verify(tdata3)) # fails+ |
+ ||
| 32 | +
- stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to))
+ #' |
|||
| 70 | +33 |
- }+ #' |
||
| 71 | +34 |
- }+ #' a <- 1 |
||
| 72 | +35 |
- }+ #' b <- a + 2 |
||
| 73 | +36 |
- }+ #' c <- list(x = 2) |
||
| 74 | -440x | +|||
| 37 | +
- invisible(x)+ #' d <- 5 |
|||
| 75 | +38 |
- }+ #' tdata4 <- teal_data( |
||
| 76 | +39 |
-
+ #' a = a, b = b, c = c, d = d, |
||
| 77 | +40 |
- #' Verify key set compatibility+ #' code = "a <- 1 |
||
| 78 | +41 |
- #'+ #' b <- a |
||
| 79 | +42 |
- #' Helper function to ensuring compatibility between two sets of keys+ #' c <- list(x = 2) |
||
| 80 | +43 |
- #'+ #' e <- 1" |
||
| 81 | +44 |
- #' @return Returns `TRUE` if successful, otherwise raises error.+ #' ) |
||
| 82 | +45 |
- #' @keywords internal+ #' tdata4 |
||
| 83 | +46 |
- assert_compatible_keys2 <- function(x, y) {
+ #' \dontrun{
|
||
| 84 | +47 |
- # Helper to flatten join_keys / join_key_set+ #' verify(tdata4) # fails |
||
| 85 | -3x | +|||
| 48 | +
- flatten_join_key_sets <- function(value) {
+ #' } |
|||
| 86 | -6x | +|||
| 49 | +
- value <- unclass(value)+ #' |
|||
| 87 | -6x | +|||
| 50 | +
- Reduce(+ #' @name verify |
|||
| 88 | -6x | +|||
| 51 | +
- init = list(),+ #' @rdname verify |
|||
| 89 | -6x | +|||
| 52 | +
- f = function(u, v, ...) {
+ #' @aliases verify,teal_data-method |
|||
| 90 | -6x | +|||
| 53 | +
- el <- value[v][[1]]+ #' @aliases verify,qenv.error-method |
|||
| 91 | -6x | +|||
| 54 | +
- res <- lapply(seq_along(el), function(ix) el[ix])+ #' |
|||
| 92 | -6x | +|||
| 55 | +
- names(res) <- rep(v, length(res))+ #' @export |
|||
| 93 | -6x | +56 | +5x |
- append(u, res)+ setGeneric("verify", function(x) standardGeneric("verify"))
|
| 94 | +57 |
- },+ setMethod("verify", signature = "teal_data", definition = function(x) {
|
||
| 95 | -6x | +58 | +4x |
- x = names(value)+ if (x@verified) {
|
| 96 | -+ | |||
| 59 | +2x |
- )+ return(x) |
||
| 97 | +60 |
} |
||
| 98 | -- | - - | -||
| 99 | -3x | +61 | +2x |
- x <- flatten_join_key_sets(x)+ x_name <- deparse(substitute(x)) |
| 100 | -3x | +62 | +2x |
- y <- flatten_join_key_sets(y)+ y <- eval_code(teal_data(), get_code(x)) |
| 101 | +63 | |||
| 102 | -3x | -
- for (idx_1 in seq_along(x)) {
- |
- ||
| 103 | -3x | +64 | +2x |
- for (idx_2 in seq_along(y)) {
+ if (inherits(y, "qenv.error")) {
|
| 104 | -3x | +|||
| 65 | +! |
- assert_compatible_keys(x[idx_1], y[idx_2])+ stop(conditionMessage(y), call. = FALSE) |
||
| 105 | +66 |
- }+ } |
||
| 106 | +67 |
- }+ |
||
| 107 | +68 | 2x |
- TRUE+ reproduced <- isTRUE(all.equal(x@env, y@env)) |
|
| 108 | -+ | |||
| 69 | +2x |
- }+ if (reproduced) {
|
||
| 109 | -+ | |||
| 70 | +1x |
-
+ x@verified <- TRUE |
||
| 110 | -+ | |||
| 71 | +1x |
- #' Updates the keys of the datasets based on the parents+ methods::validObject(x) |
||
| 111 | -+ | |||
| 72 | +1x |
- #'+ x |
||
| 112 | +73 |
- #' @param x (`join_keys`) object to update the keys.- |
- ||
| 113 | -+ | |||
| 74 | +1x |
- #'+ error <- "Code verification failed." |
||
| 114 | +75 |
- #' @return (`self`) invisibly for chaining+ |
||
| 115 | -+ | |||
| 76 | +1x |
- #'+ objects_diff <- vapply( |
||
| 116 | -+ | |||
| 77 | +1x |
- #' @keywords internal+ intersect(names(x@env), names(y@env)), |
||
| 117 | -+ | |||
| 78 | +1x |
- update_keys_given_parents <- function(x) {
+ function(element) {
|
||
| 118 | -12x | +79 | +1x |
- jk <- join_keys(x)+ isTRUE(all.equal(x@env[[element]], y@env[[element]])) |
| 119 | +80 |
-
+ }, |
||
| 120 | -12x | +81 | +1x |
- checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(x))+ logical(1) |
| 121 | +82 |
-
+ ) |
||
| 122 | -12x | +|||
| 83 | +
- datanames <- names(jk)+ |
|||
| 123 | -12x | +84 | +1x |
- for (d1_ix in seq_along(datanames)) {
+ names_diff_other <- setdiff(names(y@env), names(x@env)) |
| 124 | -34x | +85 | +1x |
- d1 <- datanames[[d1_ix]]+ names_diff_inenv <- setdiff(names(x@env), names(y@env)) |
| 125 | -34x | +|||
| 86 | +
- d1_parent <- parent(jk, d1)+ |
|||
| 126 | -34x | +87 | +1x |
- for (d2 in datanames[-1 * seq.int(d1_ix)]) {
+ if (length(objects_diff)) {
|
| 127 | -38x | +88 | +1x |
- if (length(jk[[d1]][[d2]]) == 0) {
+ error <- c( |
| 128 | -16x | +89 | +1x |
- d2_parent <- parent(jk, d2)+ error, |
| 129 | -+ | |||
| 90 | +1x |
-
+ paste0("Object(s) recreated with code that have different structure in ", x_name, ":"),
|
||
| 130 | -12x | +91 | +1x |
- if (!identical(d1_parent, d2_parent) || length(d1_parent) == 0) next+ paste0(" \u2022 ", names(which(!objects_diff)))
|
| 131 | +92 |
-
+ ) |
||
| 132 | +93 |
- # both has the same parent -> common keys to parent+ } |
||
| 133 | -4x | +94 | +1x |
- keys_d1_parent <- sort(jk[[d1]][[d1_parent]])+ if (length(names_diff_inenv)) {
|
| 134 | -4x | +|||
| 95 | +! |
- keys_d2_parent <- sort(jk[[d2]][[d2_parent]])+ error <- c( |
||
| 135 | -+ | |||
| 96 | +! |
-
+ error, |
||
| 136 | -4x | +|||
| 97 | +! |
- common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent)+ paste0("Object(s) not created with code that exist in ", x_name, ":"),
|
||
| 137 | -4x | +|||
| 98 | +! |
- common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent)+ paste0(" \u2022 ", names_diff_inenv)
|
||
| 138 | +99 |
-
+ ) |
||
| 139 | +100 |
- # No common keys between datasets - leave empty+ } |
||
| 140 | +101 | 1x |
- if (all(!common_ix_1)) next+ if (length(names_diff_other)) {
|
|
| 141 | -+ | |||
| 102 | +! |
-
+ error <- c( |
||
| 142 | -3x | +|||
| 103 | +! |
- fk <- structure(+ error, |
||
| 143 | -3x | +|||
| 104 | +! |
- names(keys_d2_parent)[common_ix_2],+ paste0("Object(s) created with code that do not exist in ", x_name, ":"),
|
||
| 144 | -3x | +|||
| 105 | +! |
- names = names(keys_d1_parent)[common_ix_1]+ paste0(" \u2022 ", names_diff_other)
|
||
| 145 | +106 |
- )+ ) |
||
| 146 | -3x | +|||
| 107 | +
- jk[[d1]][[d2]] <- fk # mutate join key+ } |
|||
| 147 | +108 |
- }+ |
||
| 148 | -+ | |||
| 109 | +1x |
- }+ stop(paste(error, collapse = "\n"), call. = FALSE) |
||
| 149 | +110 |
} |
||
| 150 | +111 |
- # check parent child relation- |
- ||
| 151 | -12x | -
- assert_parent_child(x = jk)+ }) |
||
| 152 | +112 |
-
+ setMethod("verify", signature = "qenv.error", definition = function(x) {
|
||
| 153 | -12x | +113 | +1x |
- jk+ stop(conditionMessage(x), call. = FALSE) |
| 154 | +114 |
- }+ }) |
| 1 |
- #' Manage relationships between datasets using `join_keys`+ #' Check Compatibility of keys |
|||
| 2 |
- #' @order 1+ #' |
|||
| 3 |
- #' @name join_keys+ #' Helper function to assert if two key sets contain incompatible keys. |
|||
| 5 |
- #' @usage ## Constructor, getter and setter+ #' @return Returns `TRUE` if successful, otherwise raises error. |
|||
| 6 |
- #' join_keys(...)+ #' @keywords internal |
|||
| 7 |
- #'+ assert_compatible_keys <- function(join_key_1, join_key_2) {
|
|||
| 8 | -+ | 3x |
- #' @description+ stop_message <- function(dataset_1, dataset_2) {
|
|
| 9 | -+ | 1x |
- #' Facilitates the creation and retrieval of relationships between datasets.+ stop( |
|
| 10 | -+ | 1x |
- #' `join_keys` class extends `list` and contains keys connecting pairs of datasets.+ paste("cannot specify multiple different join keys between datasets:", dataset_1, "and", dataset_2)
|
|
| 11 |
- #' Each element of the list contains keys for specific dataset.+ ) |
|||
| 12 |
- #' Each dataset can have a relationship with itself (primary key) and with other datasets.+ } |
|||
| 13 |
- #'+ |
|||
| 14 | -+ | 3x |
- #' Note that `join_keys` list is symmetrical and assumes a default direction, that is:+ dataset_1_one <- names(join_key_1) |
|
| 15 | -+ | 3x |
- #' when keys are set between `ds1` and `ds2`, it defines `ds1` as the parent+ dataset_2_one <- names(join_key_1[[1]]) |
|
| 16 | -+ | 3x |
- #' in a parent-child relationship and the mapping is automatically mirrored between+ keys_one <- join_key_1[[1]][[1]] |
|
| 17 |
- #' `ds2` and `ds1`.+ |
|||
| 18 | -+ | 3x |
- #'+ dataset_1_two <- names(join_key_2) |
|
| 19 | -+ | 3x |
- #' @section Methods (by class):+ dataset_2_two <- names(join_key_2[[1]]) |
|
| 20 | -+ | 3x |
- #' - `join_keys()`: Returns an empty `join_keys` object when called without arguments.+ keys_two <- join_key_2[[1]][[1]] |
|
| 21 |
- #' - `join_keys(join_keys)`: Returns itself.+ |
|||
| 22 |
- #' - `join_keys(teal_data)`: Returns the `join_keys` object contained in `teal_data` object.+ # if first datasets and the second datasets match and keys |
|||
| 23 |
- #' - `join_keys(...)`: Creates a new object with one or more `join_key_set` parameters.+ # must contain the same named elements |
|||
| 24 | -+ | 3x |
- #'+ if (dataset_1_one == dataset_1_two && dataset_2_one == dataset_2_two) {
|
|
| 25 | -+ | 3x |
- #' @param ... optional,+ if (!identical(sort(keys_one), sort(keys_two))) {
|
|
| 26 | -+ | 1x |
- #' - either `teal_data` or `join_keys` object to extract `join_keys`+ stop_message(dataset_1_one, dataset_2_one) |
|
| 27 |
- #' - or any number of `join_key_set` objects to create `join_keys`+ } |
|||
| 28 |
- #' - or nothing to create an empty `join_keys`+ } |
|||
| 29 |
- #' @param value For `x[i, j, directed = TRUE)] <- value` (named/unnamed `character`)+ |
|||
| 30 |
- #' Column mapping between datasets.+ # if first dataset of join_key_1 matches second dataset of join_key_2 |
|||
| 31 |
- #'+ # and the first dataset of join_key_2 must match second dataset of join_key_1 |
|||
| 32 |
- #' For `join_keys(x) <- value`: (`join_key_set` or list of `join_key_set`) relationship+ # and keys must contain the same elements but with names and values swapped |
|||
| 33 | -+ | 2x |
- #' pairs to add to `join_keys` list.+ if (dataset_1_one == dataset_2_two && dataset_2_one == dataset_1_two) {
|
|
| 34 |
- #'+ if ( |
|||
| 35 | -+ | ! |
- #'+ xor(length(keys_one) == 0, length(keys_two) == 0) || |
|
| 36 | -+ | ! |
- #' @return `join_keys` object.+ !identical(sort(keys_one), sort(stats::setNames(names(keys_two), keys_two))) |
|
| 37 |
- #'+ ) {
|
|||
| 38 | -+ | ! |
- #' @examples+ stop_message(dataset_1_one, dataset_2_one) |
|
| 39 |
- #' # Creating a new join keys ----+ } |
|||
| 40 |
- #'+ } |
|||
| 41 |
- #' jk <- join_keys(+ |
|||
| 42 |
- #' join_key("ds1", "ds1", "pk1"),
+ # otherwise they are compatible |
|||
| 43 | -+ | 2x |
- #' join_key("ds2", "ds2", "pk2"),
+ return(TRUE) |
|
| 44 |
- #' join_key("ds3", "ds3", "pk3"),
+ } |
|||
| 45 |
- #' join_key("ds1", "ds2", c(pk1 = "pk2")),
+
|
|||
| 46 |
- #' join_key("ds1", "ds3", c(pk1 = "pk3"))
+ #' Validate parent-child key |
|||
| 47 |
- #' )+ #' |
|||
| 48 |
- #'+ #' Helper function checks the parent-child relations are valid. |
|||
| 49 |
- #' jk+ #' |
|||
| 50 |
- #'+ #' @param x (`join_keys`) object to assert validity of relations |
|||
| 51 |
- #' @export+ #' |
|||
| 52 |
- #'+ #' @return `join_keys` invisibly |
|||
| 53 |
- #' @seealso [join_key()] for creating `join_keys_set`,+ #' |
|||
| 54 |
- #' [parents()] for parent operations,+ #' @keywords internal |
|||
| 55 |
- #' [teal_data()] for `teal_data` constructor _and_+ assert_parent_child <- function(x) {
|
|||
| 56 | -+ | 441x |
- #' [default_cdisc_join_keys] for default CDISC keys.+ jk <- join_keys(x) |
|
| 57 | -+ | 441x |
- #'+ jk_parents <- parents(jk) |
|
| 58 |
- join_keys <- function(...) {
+
|
|||
| 59 | -820x | +441x |
- if (missing(...)) {
+ checkmate::assert_class(jk, c("join_keys", "list"))
|
|
| 60 | -245x | +
- return(new_join_keys())+ |
||
| 61 | -+ | 441x |
- }+ if (!is.null(jk_parents)) {
|
|
| 62 | -575x | +441x |
- x <- rlang::list2(...)+ for (idx1 in seq_along(jk_parents)) {
|
|
| 63 | -575x | +177x |
- if (length(x) == 1L) {
+ name_from <- names(jk_parents)[[idx1]] |
|
| 64 | -510x | +177x |
- UseMethod("join_keys", x[[1]])
+ for (idx2 in seq_along(jk_parents[[idx1]])) {
|
|
| 65 | -+ | 177x |
- } else {
+ name_to <- jk_parents[[idx1]][[idx2]] |
|
| 66 | -65x | +177x |
- join_keys.default(...)+ keys_from <- jk[[name_from]][[name_to]] |
|
| 67 | -+ | 177x |
- }+ keys_to <- jk[[name_to]][[name_from]] |
|
| 68 | -+ | 177x |
- }+ if (length(keys_from) == 0 && length(keys_to) == 0) {
|
|
| 69 | -+ | 1x |
-
+ stop(sprintf("No join keys from %s to its parent (%s) and vice versa", name_from, name_to))
|
|
| 70 |
- #' @rdname join_keys+ } |
|||
| 71 |
- #' @order 1+ } |
|||
| 72 |
- #' @export+ } |
|||
| 73 |
- join_keys.default <- function(...) {
+ } |
|||
| 74 | -113x | +440x |
- c(new_join_keys(), ...)+ invisible(x) |
|
| 77 |
- #' @rdname join_keys+ #' Verify key set compatibility |
|||
| 78 |
- #' @order 1+ #' |
|||
| 79 |
- #' @export+ #' Helper function to ensuring compatibility between two sets of keys |
|||
| 80 |
- join_keys.join_keys <- function(...) {
+ #' |
|||
| 81 | -457x | +
- x <- rlang::list2(...)+ #' @return Returns `TRUE` if successful, otherwise raises error. |
||
| 82 | -457x | +
- x[[1]]+ #' @keywords internal |
||
| 83 |
- }+ assert_compatible_keys2 <- function(x, y) {
|
|||
| 84 |
-
+ # Helper to flatten join_keys / join_key_set |
|||
| 85 | -+ | 3x |
- #' @rdname join_keys+ flatten_join_key_sets <- function(value) {
|
|
| 86 | -+ | 6x |
- #' @order 1+ value <- unclass(value) |
|
| 87 | -+ | 6x |
- #' @export+ Reduce( |
|
| 88 | -+ | 6x |
- join_keys.teal_data <- function(...) {
+ init = list(), |
|
| 89 | -5x | +6x |
- x <- rlang::list2(...)+ f = function(u, v, ...) {
|
|
| 90 | -5x | +6x |
- x[[1]]@join_keys+ el <- value[v][[1]] |
|
| 91 | -+ | 6x |
- }+ res <- lapply(seq_along(el), function(ix) el[ix]) |
|
| 92 | -+ | 6x |
-
+ names(res) <- rep(v, length(res)) |
|
| 93 | -+ | 6x |
- #' @rdname join_keys+ append(u, res) |
|
| 94 |
- #' @order 5+ }, |
|||
| 95 | -+ | 6x |
- #'+ x = names(value) |
|
| 96 |
- #' @section Functions:+ ) |
|||
| 97 |
- #' - `join_keys(x) <- value`: Assignment of the `join_keys` in object with `value`.+ } |
|||
| 98 |
- #' `value` needs to be an object of class `join_keys` or `join_key_set`.+ |
|||
| 99 | -+ | 3x |
- #'+ x <- flatten_join_key_sets(x) |
|
| 100 | -+ | 3x |
- #' @param x (`join_keys`) empty object to set the new relationship pairs.+ y <- flatten_join_key_sets(y) |
|
| 101 |
- #' `x` is typically an object of `join_keys` class. When called with the `join_keys(x)`+ |
|||
| 102 | -+ | 3x |
- #' or `join_keys(x) <- value` then it can also take a supported class (`teal_data`, `join_keys`)+ for (idx_1 in seq_along(x)) {
|
|
| 103 | -+ | 3x |
- #'+ for (idx_2 in seq_along(y)) {
|
|
| 104 | -+ | 3x |
- #' @export+ assert_compatible_keys(x[idx_1], y[idx_2]) |
|
| 105 |
- `join_keys<-` <- function(x, value) {
+ } |
|||
| 106 | -16x | +
- checkmate::assert_class(value, classes = c("join_keys", "list"))
+ } |
||
| 107 | -16x | +2x |
- UseMethod("join_keys<-", x)
+ TRUE |
|
| 110 |
- #' @rdname join_keys+ #' Updates the keys of the datasets based on the parents |
|||
| 111 |
- #' @order 5+ #' |
|||
| 112 |
- #' @export+ #' @param x (`join_keys`) object to update the keys. |
|||
| 113 |
- #' @examples+ #' |
|||
| 114 |
- #' # Assigning keys via join_keys(x)[i, j] <- value ----+ #' @return (`self`) invisibly for chaining+ |
+ |||
| 115 | ++ |
+ #'+ |
+ ||
| 116 | ++ |
+ #' @keywords internal+ |
+ ||
| 117 | ++ |
+ update_keys_given_parents <- function(x) {
+ |
+ ||
| 118 | +12x | +
+ jk <- join_keys(x)+ |
+ ||
| 119 | ++ | + + | +||
| 120 | +12x | +
+ checkmate::assert_class(jk, "join_keys", .var.name = checkmate::vname(x))+ |
+ ||
| 121 | ++ | + + | +||
| 122 | +12x | +
+ datanames <- names(jk)+ |
+ ||
| 123 | +12x | +
+ for (d1_ix in seq_along(datanames)) {
+ |
+ ||
| 124 | +34x | +
+ d1 <- datanames[[d1_ix]]+ |
+ ||
| 125 | +34x | +
+ d1_parent <- parent(jk, d1)+ |
+ ||
| 126 | +34x | +
+ for (d2 in datanames[-1 * seq.int(d1_ix)]) {
+ |
+ ||
| 127 | +38x | +
+ if (length(jk[[d1]][[d2]]) == 0) {
+ |
+ ||
| 128 | +16x | +
+ d2_parent <- parent(jk, d2)+ |
+ ||
| 129 | ++ | + + | +||
| 130 | +12x | +
+ if (!identical(d1_parent, d2_parent) || length(d1_parent) == 0) next |
||
| 115 | +131 |
- #'+ |
||
| 116 | +132 |
- #' obj <- join_keys()+ # both has the same parent -> common keys to parent |
||
| 117 | -+ | |||
| 133 | +4x |
- #' # or+ keys_d1_parent <- sort(jk[[d1]][[d1_parent]]) |
||
| 118 | -+ | |||
| 134 | +4x |
- #' obj <- teal_data()+ keys_d2_parent <- sort(jk[[d2]][[d2_parent]]) |
||
| 119 | +135 |
- #'+ |
||
| 120 | -+ | |||
| 136 | +4x |
- #' join_keys(obj)["ds1", "ds1"] <- "pk1"+ common_ix_1 <- unname(keys_d1_parent) %in% unname(keys_d2_parent) |
||
| 121 | -+ | |||
| 137 | +4x |
- #' join_keys(obj)["ds2", "ds2"] <- "pk2"+ common_ix_2 <- unname(keys_d2_parent) %in% unname(keys_d1_parent) |
||
| 122 | +138 |
- #' join_keys(obj)["ds3", "ds3"] <- "pk3"+ |
||
| 123 | +139 |
- #' join_keys(obj)["ds1", "ds2"] <- c(pk1 = "pk2")+ # No common keys between datasets - leave empty |
||
| 124 | -+ | |||
| 140 | +1x |
- #' join_keys(obj)["ds1", "ds3"] <- c(pk1 = "pk3")+ if (all(!common_ix_1)) next |
||
| 125 | +141 |
- #'+ |
||
| 126 | -+ | |||
| 142 | +3x |
- #' identical(jk, join_keys(obj))+ fk <- structure( |
||
| 127 | -+ | |||
| 143 | +3x |
- `join_keys<-.join_keys` <- function(x, value) {
+ names(keys_d2_parent)[common_ix_2], |
||
| 128 | -10x | +144 | +3x |
- value+ names = names(keys_d1_parent)[common_ix_1] |
| 129 | +145 |
- }+ ) |
||
| 130 | -+ | |||
| 146 | +3x |
-
+ jk[[d1]][[d2]] <- fk # mutate join key |
||
| 131 | +147 |
- #' @rdname join_keys+ } |
||
| 132 | +148 |
- #' @order 5+ } |
||
| 133 | +149 |
- #' @export+ } |
||
| 134 | +150 |
- #' @examples+ # check parent child relation |
||
| 135 | -+ | |||
| 151 | +12x |
- #' # Setter for join_keys within teal_data ----+ assert_parent_child(x = jk) |
||
| 136 | +152 |
- #'+ |
||
| 137 | -+ | |||
| 153 | +12x |
- #' td <- teal_data()+ jk |
||
| 138 | +154 |
- #' join_keys(td) <- jk+ } |
| 139 | +1 |
- #'+ #' Show `teal_data` object |
|
| 140 | +2 |
- #' join_keys(td)["ds1", "ds2"] <- "new_key"+ #' |
|
| 141 | +3 |
- #' join_keys(td) <- c(join_keys(td), join_keys(join_key("ds3", "ds2", "key3")))
+ #' Prints `teal_data` object. |
|
| 142 | +4 |
- #' join_keys(td)+ #' |
|
| 143 | +5 |
- `join_keys<-.teal_data` <- function(x, value) {
- |
- |
| 144 | -6x | -
- join_keys(x@join_keys) <- value- |
- |
| 145 | -6x | -
- datanames(x) <- x@datanames # datanames fun manages some exceptions- |
- |
| 146 | -6x | -
- x+ #' @param object (`teal_data`) |
|
| 147 | +6 |
- }+ #' @return Input `teal_data` object. |
|
| 148 | +7 |
-
+ #' @importFrom methods show |
|
| 149 | +8 |
- #' Internal constructor+ #' @examples |
|
| 150 | +9 |
- #'+ #' teal_data() |
|
| 151 | +10 |
- #' @return an empty `join_keys` list+ #' teal_data(x = iris, code = "x = iris") |
|
| 152 | +11 |
- #'+ #' verify(teal_data(x = iris, code = "x = iris")) |
|
| 153 | +12 |
- #' @keywords internal+ #' @export |
|
| 154 | +13 |
- new_join_keys <- function() {
+ setMethod("show", signature = "teal_data", function(object) {
|
|
| 155 | -382x | +||
| 14 | +! |
- structure(+ if (object@verified) {
|
|
| 156 | -382x | +||
| 15 | +! |
- list(),+ cat("\u2705\ufe0e", "verified teal_data object\n")
|
|
| 157 | -382x | +||
| 16 | +
- class = c("join_keys", "list"),
+ } else {
|
||
| 158 | -382x | +||
| 17 | +! |
- "parents" = list()+ cat("\u2716", "unverified teal_data object\n")
|
|
| 159 | +18 |
- )+ }+ |
+ |
| 19 | +! | +
+ rlang::env_print(object@env) |
|
| 160 | +20 |
- }+ }) |
| 1 |
- #' @rdname join_keys+ #' Get code from `teal_data` object |
||
| 2 |
- #' @order 7+ #' |
||
| 3 |
- #' @export+ #' Retrieve code from `teal_data` object. |
||
| 4 |
- format.join_keys <- function(x, ...) {
+ #' |
||
| 5 | -6x | +
- if (length(x) > 0) {
+ #' Retrieve code stored in `@code`, which (in principle) can be used to recreate all objects found in `@env`. |
|
| 6 | -5x | +
- my_parents <- parents(x)+ #' Use `names` to limit the code to one or more of the datasets enumerated in `@datanames`. |
|
| 7 | -5x | +
- names_sorted <- topological_sort(my_parents)+ #' |
|
| 8 | -5x | +
- names <- union(names_sorted, names(x))+ #' @section Extracting dataset-specific code: |
|
| 9 | -5x | +
- x_implicit <- update_keys_given_parents(x)+ #' When `names` is specified, the code returned will be limited to the lines needed to _create_ |
|
| 10 | -5x | +
- out <- lapply(names, function(i) {
+ #' the requested datasets. The code stored in the `@code` slot is analyzed statically to determine |
|
| 11 | -15x | +
- out_i <- lapply(union(i, names(x[[i]])), function(j) {
+ #' which lines the datasets of interest depend upon. The analysis works well when objects are created |
|
| 12 | -35x | +
- direction <- if (identical(my_parents[[j]], i)) {
+ #' with standard infix assignment operators (see `?assignOps`) but it can fail in some situations. |
|
| 13 |
- " <-- "+ #' |
||
| 14 | -35x | +
- } else if (identical(my_parents[[i]], j)) {
+ #' Consider the following examples: |
|
| 15 |
- " --> "+ #' |
||
| 16 | -35x | +
- } else if (!identical(i, j)) {
+ #' _Case 1: Usual assignments._ |
|
| 17 |
- " <-> "+ #' ```r |
||
| 18 |
- } else {
+ #' data <- teal_data() |> |
||
| 19 |
- ""+ #' within({
|
||
| 20 |
- }+ #' foo <- function(x) {
|
||
| 21 |
-
+ #' x + 1 |
||
| 22 | -35x | +
- keys <- x[[i]][[j]]+ #' } |
|
| 23 | -35x | +
- sprintf(+ #' x <- 0 |
|
| 24 | -35x | +
- "%s%s: [%s]",+ #' y <- foo(x) |
|
| 25 | -35x | +
- direction, j,+ #' }) |
|
| 26 | -35x | +
- if (length(keys) == 0) "no primary keys" else toString(keys)+ #' get_code(data, names = "y") |
|
| 27 |
- )+ #' ``` |
||
| 28 |
- })+ #' `x` has no dependencies, so `get_code(data, names = "x")` will return only the second call.\cr |
||
| 29 |
-
+ #' `y` depends on `x` and `foo`, so `get_code(data, names = "y")` will contain all three calls. |
||
| 30 | -15x | +
- implicit_datasets <- setdiff(names(x_implicit[[i]]), names(x[[i]]))+ #' |
|
| 31 | -15x | +
- if (length(implicit_datasets) > 0) {
+ #' _Case 2: Some objects are created by a function's side effects._ |
|
| 32 | -2x | +
- out_i <- c(+ #' ```r |
|
| 33 | -2x | +
- out_i,+ #' data <- teal_data() |> |
|
| 34 | -2x | +
- paste0(+ #' within({
|
|
| 35 | -2x | +
- " --* (implicit via parent with): ",+ #' foo <- function() {
|
|
| 36 | -2x | +
- paste(implicit_datasets, collapse = ", ")+ #' x <<- x + 1 |
|
| 37 |
- )+ #' } |
||
| 38 |
- )+ #' x <- 0 |
||
| 39 |
- }+ #' foo() |
||
| 40 |
-
+ #' y <- x |
||
| 41 | -15x | +
- paste(out_i, collapse = "\n")+ #' }) |
|
| 42 |
- })+ #' get_code(data, names = "y") |
||
| 43 | -5x | +
- paste(+ #' ``` |
|
| 44 | -5x | +
- c(+ #' Here, `y` depends on `x` but `x` is modified by `foo` as a side effect (not by reassignment) |
|
| 45 | -5x | +
- sprintf("A join_keys object containing foreign keys between %s datasets:", length(x)),
+ #' and so `get_code(data, names = "y")` will not return the `foo()` call.\cr |
|
| 46 | -5x | +
- out+ #' To overcome this limitation, code dependencies can be specified manually. |
|
| 47 |
- ),+ #' Lines where side effects occur can be flagged by adding "`# @linksto <object name>`" at the end.\cr |
||
| 48 | -5x | +
- collapse = "\n"+ #' Note that `within` evaluates code passed to `expr` as is and comments are ignored. |
|
| 49 |
- )+ #' In order to include comments in code one must use the `eval_code` function instead.+ |
+ ||
| 50 | ++ |
+ #'+ |
+ |
| 51 | ++ |
+ #' ```r+ |
+ |
| 52 | ++ |
+ #' data <- teal_data() |>+ |
+ |
| 53 | ++ |
+ #' eval_code("
+ |
+ |
| 54 | ++ |
+ #' foo <- function() {
+ |
+ |
| 55 | ++ |
+ #' x <<- x + 1+ |
+ |
| 56 | ++ |
+ #' } |
|
| 50 | +57 |
- } else {
+ #' x <- 0 |
|
| 51 | -1x | +||
| 58 | +
- "An empty join_keys object."+ #' foo() # @linksto x |
||
| 52 | +59 |
- }+ #' y <- x |
|
| 53 | +60 |
- }+ #' ") |
|
| 54 | +61 |
-
+ #' get_code(data, names = "y") |
|
| 55 | +62 |
- #' @rdname join_keys+ #' ``` |
|
| 56 | +63 |
- #' @order 7+ #' Now the `foo()` call will be properly included in the code required to recreate `y`. |
|
| 57 | +64 |
- #' @export+ #' |
|
| 58 | +65 |
- print.join_keys <- function(x, ...) {
+ #' Note that two functions that create objects as side effects, `assign` and `data`, are handled automatically. |
|
| 59 | -1x | +||
| 66 | +
- cat(format(x, ...), "\n")+ #' |
||
| 60 | -1x | +||
| 67 | +
- invisible(x)+ #' Here are known cases where manual tagging is necessary: |
||
| 61 | +68 |
- }+ #' - non-standard assignment operators, _e.g._ `%<>%` |
| 1 | +69 |
- #' Get and set parents in `join_keys` object+ #' - objects used as conditions in `if` statements: `if (<condition>)` |
||
| 2 | +70 |
- #'+ #' - objects used to iterate over in `for` loops: `for(i in <sequence>)` |
||
| 3 | +71 |
- #' `parents()` facilitates the creation of dependencies between datasets by+ #' - creating and evaluating language objects, _e.g._ `eval(<call>)` |
||
| 4 | +72 |
- #' assigning a parent-child relationship.+ #' |
||
| 5 | +73 |
#' |
||
| 6 | +74 |
- #' Each element is defined by a `list` element, where `list("child" = "parent")`.
+ #' @param object (`teal_data`) |
||
| 7 | +75 |
- #'+ #' @param datanames `r lifecycle::badge("deprecated")` (`character`) vector of dataset names to return the code for.
|
||
| 8 | +76 |
- #' @param x (`join_keys` or `teal_data`) object that contains "parents" information+ #' For more details see the "Extracting dataset-specific code" section. Use `names` instead. |
||
| 9 | +77 |
- #' to retrieve or manipulate.+ #' @param names (`character`) Successor of `datanames`. Vector of dataset names to return the code for. |
||
| 10 | +78 |
- #'+ #' For more details see the "Extracting dataset-specific code" section. |
||
| 11 | +79 |
- #' @return a `list` of `character` representing the parents.+ #' @param deparse (`logical`) flag specifying whether to return code as `character` (`deparse = TRUE`) or as |
||
| 12 | +80 |
- #'+ #' `expression` (`deparse = FALSE`). |
||
| 13 | +81 |
- #' @export+ #' @param ... Parameters passed to internal methods. Currently, the only supported parameter is `check_names` |
||
| 14 | +82 |
- #' @seealso [join_keys()]+ #' (`logical(1)`) flag, which is `TRUE` by default. Function warns about missing objects, if they do not exist in |
||
| 15 | +83 |
- parents <- function(x) {
+ #' `code` but are passed in `datanames`. To remove the warning, set `check_names = FALSE`. |
||
| 16 | -702x | +|||
| 84 | +
- UseMethod("parents", x)
+ #' |
|||
| 17 | +85 |
- }+ #' @return |
||
| 18 | +86 |
-
+ #' Either a character string or an expression. If `names` is used to request a specific dataset, |
||
| 19 | +87 |
- #' @describeIn parents Retrieves parents of `join_keys` object.+ #' only code that _creates_ that dataset (not code that uses it) is returned. Otherwise, all contents of `@code`. |
||
| 20 | +88 |
- #' @export+ #' |
||
| 21 | +89 |
#' @examples |
||
| 22 | +90 |
- #' # Get parents of join_keys ---+ #' tdata1 <- teal_data() |
||
| 23 | +91 |
- #'+ #' tdata1 <- within(tdata1, {
|
||
| 24 | +92 |
- #' jk <- default_cdisc_join_keys["ADEX"]+ #' a <- 1 |
||
| 25 | +93 |
- #' parents(jk)+ #' b <- a^5 |
||
| 26 | +94 |
- parents.join_keys <- function(x) {
+ #' c <- list(x = 2) |
||
| 27 | -1x | +|||
| 95 | +
- if (is.null(attr(x, "parents"))) list() else attr(x, "parents")+ #' }) |
|||
| 28 | +96 |
- }+ #' get_code(tdata1) |
||
| 29 | +97 |
-
+ #' get_code(tdata1, names = "a") |
||
| 30 | +98 |
- #' @describeIn parents Retrieves parents of `join_keys` inside `teal_data` object.+ #' get_code(tdata1, names = "b") |
||
| 31 | +99 |
- #' @export+ #' |
||
| 32 | +100 |
- #' @examples+ #' tdata2 <- teal_data(x1 = iris, code = "x1 <- iris") |
||
| 33 | +101 |
- #' # Get parents of join_keys inside teal_data object ---+ #' get_code(tdata2) |
||
| 34 | +102 |
- #'+ #' get_code(verify(tdata2)) |
||
| 35 | +103 |
- #' td <- teal_data(+ #' |
||
| 36 | +104 |
- #' ADSL = rADSL,+ #' @rdname get_code |
||
| 37 | +105 |
- #' ADTTE = rADTTE,+ #' @aliases get_code,teal_data-method |
||
| 38 | +106 |
- #' ADRS = rADRS,+ #' |
||
| 39 | +107 |
- #' join_keys = default_cdisc_join_keys[c("ADSL", "ADTTE", "ADRS")]
+ #' @export |
||
| 40 | +108 |
- #' )+ setMethod("get_code",
|
||
| 41 | +109 |
- #' parents(td)+ signature = "teal_data", |
||
| 42 | +110 |
- parents.teal_data <- function(x) {
+ definition = function(object, deparse = TRUE, names = NULL, datanames = lifecycle::deprecated(), ...) {
+ |
+ ||
| 111 | +2x | +
+ if (lifecycle::is_present(datanames)) {
+ |
+ ||
| 112 | +! | +
+ lifecycle::deprecate_warn(+ |
+ ||
| 113 | +! | +
+ when = "0.6.1",+ |
+ ||
| 114 | +! | +
+ what = "teal.data::get_code(datanames)",+ |
+ ||
| 115 | +! | +
+ with = "teal.code::get_code(names)", |
||
| 43 | -1x | +|||
| 116 | +! |
- parents(x@join_keys)+ always = TRUE |
||
| 44 | +117 |
- }+ ) |
||
| 45 | -+ | |||
| 118 | +! |
-
+ names <- datanames |
||
| 46 | +119 |
- #' @describeIn parents Assignment of parents in `join_keys` object.+ } |
||
| 47 | +120 |
- #'+ |
||
| 48 | -+ | |||
| 121 | +2x |
- #' @param value (`named list`) of `character` vectors.+ if (!is.null(names) && lifecycle::is_present(datanames)) {
|
||
| 49 | -+ | |||
| 122 | +! |
- #'+ stop("Please use either 'names' (recommended) or 'datanames' parameter.")
|
||
| 50 | +123 |
- #' @export+ } |
||
| 51 | +124 |
- `parents<-` <- function(x, value) {
+
|
||
| 52 | -438x | +125 | +2x |
- UseMethod("parents<-", x)
+ checkmate::assert_character(names, min.len = 1L, null.ok = TRUE) |
| 53 | -+ | |||
| 126 | +2x |
- }+ checkmate::assert_flag(deparse) |
||
| 54 | +127 | |||
| 55 | -+ | |||
| 128 | +2x |
- #' @describeIn parents Assignment of parents of `join_keys` object.+ methods::callNextMethod(object = object, deparse = deparse, names = names, ...) |
||
| 56 | +129 |
- #' @export+ } |
||
| 57 | +130 |
- #' @examples+ ) |
| 58 | +1 |
- #' # Assignment of parents ---+ #' Names of data sets in `teal_data` object |
||
| 59 | +2 |
#' |
||
| 60 | +3 |
- #' jk <- join_keys(+ #' Get or set the value of the `datanames` slot. |
||
| 61 | +4 |
- #' join_key("ds1", "ds2", "id"),
+ #' |
||
| 62 | +5 |
- #' join_key("ds5", "ds6", "id"),
+ #' The `@datanames` slot in a `teal_data` object specifies which of the variables stored in its environment |
||
| 63 | +6 |
- #' join_key("ds7", "ds6", "id")
+ #' (the `@env` slot) are data sets to be taken into consideration. |
||
| 64 | +7 |
- #' )+ #' The contents of `@datanames` can be specified upon creation and default to all variables in `@env`. |
||
| 65 | +8 |
- #'+ #' Variables created later, which may well be data sets, are not automatically considered such. |
||
| 66 | +9 |
- #' parents(jk) <- list(ds2 = "ds1")+ #' Use this function to update the slot. |
||
| 67 | +10 |
#' |
||
| 68 | -- |
- #' # Setting individual parent-child relationship- |
- ||
| 69 | +11 |
- #'+ #' @param x (`teal_data`) object to access or modify |
||
| 70 | +12 |
- #' parents(jk)["ds6"] <- "ds5"+ #' @param value (`character`) new value for `@datanames`; all elements must be names of variables existing in `@env` |
||
| 71 | +13 |
- #' parents(jk)["ds7"] <- "ds6"+ #' |
||
| 72 | +14 |
- `parents<-.join_keys` <- function(x, value) {
- |
- ||
| 73 | -437x | -
- checkmate::assert_list(value, types = "character", names = "named")+ #' @return The contents of `@datanames` or `teal_data` object with updated `@datanames`. |
||
| 74 | +15 | - - | -||
| 75 | -434x | -
- new_parents <- list()+ #' |
||
| 76 | +16 | - - | -||
| 77 | -434x | -
- for (dataset in names(value)) {
+ #' @examples |
||
| 78 | +17 |
- # Custom .var.name so it is verbose and helpful for users- |
- ||
| 79 | -168x | -
- checkmate::assert_string(value[[dataset]], .var.name = sprintf("value[[\"%s\"]]", dataset))
+ #' td <- teal_data(iris = iris) |
||
| 80 | +18 | - - | -||
| 81 | -167x | -
- parent <- new_parents[[dataset]]- |
- ||
| 82 | -167x | -
- checkmate::assert(- |
- ||
| 83 | -167x | -
- checkmate::check_null(parent),- |
- ||
| 84 | -167x | -
- checkmate::check_true(- |
- ||
| 85 | -167x | -
- length(parent) == 0 &&- |
- ||
| 86 | -167x | -
- length(value[[dataset]]) == 0+ #' td <- within(td, mtcars <- mtcars) |
||
| 87 | +19 |
- ),- |
- ||
| 88 | -167x | -
- checkmate::check_true(parent == value[[dataset]]),- |
- ||
| 89 | -167x | -
- "Please check the difference between provided datasets parents and provided join_keys parents.",- |
- ||
| 90 | -167x | -
- .var.name = "value"+ #' datanames(td) |
||
| 91 | +20 |
- )+ #' |
||
| 92 | -167x | +|||
| 21 | +
- if (is.null(parent)) {
+ #' datanames(td) <- c("iris", "mtcars")
|
|||
| 93 | -167x | +|||
| 22 | +
- new_parents[[dataset]] <- value[[dataset]]+ #' datanames(td) |
|||
| 94 | +23 |
- }+ #' |
||
| 95 | +24 |
- }+ #' @name datanames |
||
| 96 | +25 |
-
+ #' @aliases datanames,teal_data-method |
||
| 97 | -433x | +|||
| 26 | +
- if (is_dag(new_parents)) {
+ #' @aliases datanames<-,teal_data,character-method |
|||
| 98 | -4x | +|||
| 27 | +
- stop("Cycle detected in a parent and child dataset graph.")
+ #' @aliases datanames,qenv.error-method |
|||
| 99 | +28 |
- }+ #' @aliases datanames<-,qenv.error,character-method |
||
| 100 | +29 | |||
| 101 | -429x | +|||
| 30 | +
- attr(x, "parents") <- new_parents+ #' @rdname datanames |
|||
| 102 | +31 |
-
+ #' @export |
||
| 103 | -429x | +32 | +15x |
- assert_parent_child(x)+ setGeneric("datanames", function(x) standardGeneric("datanames"))
+ |
+
| 33 | ++ |
+ setMethod("datanames", signature = "teal_data", definition = function(x) {
|
||
| 104 | -428x | +34 | +13x |
- x+ x@datanames |
| 105 | +35 |
- }+ }) |
||
| 106 | +36 |
-
+ setMethod("datanames", signature = "qenv.error", definition = function(x) {
|
||
| 107 | -+ | |||
| 37 | +2x |
- #' @describeIn parents Assignment of parents of `join_keys` inside `teal_data` object.+ NULL |
||
| 108 | +38 |
- #' @export+ }) |
||
| 109 | +39 |
- #' @examples+ |
||
| 110 | +40 |
- #' # Assignment of parents of join_keys inside teal_data object ---+ #' @rdname datanames |
||
| 111 | +41 |
- #'+ #' @export |
||
| 112 | -+ | |||
| 42 | +14x |
- #' parents(td) <- list("ADTTE" = "ADSL") # replace existing
+ setGeneric("datanames<-", function(x, value) standardGeneric("datanames<-"))
|
||
| 113 | +43 |
- #' parents(td)["ADRS"] <- "ADSL" # add new parent+ setMethod("datanames<-", signature = c("teal_data", "character"), definition = function(x, value) {
|
||
| 114 | -+ | |||
| 44 | +13x |
- `parents<-.teal_data` <- function(x, value) {
+ checkmate::assert_subset(value, names(x@env)) |
||
| 115 | -1x | +45 | +12x |
- parents(x@join_keys) <- value+ x@datanames <- .get_sorted_datanames(datanames = value, join_keys = x@join_keys, env = x@env) |
| 116 | -1x | +46 | +12x | +
+ methods::validObject(x)+ |
+
| 47 | +12x |
x |
||
| 117 | +48 |
- }+ }) |
||
| 118 | +49 |
-
+ setMethod("datanames<-", signature = c("qenv.error", "character"), definition = function(x, value) {
|
||
| 119 | -+ | |||
| 50 | +1x |
- #' @describeIn parents Getter for individual parent.+ methods::validObject(x) |
||
| 120 | -+ | |||
| 51 | +1x |
- #'+ x |
||
| 121 | +52 |
- #' @param dataset_name (`character(1)`) Name of dataset to query on their parent.+ }) |
||
| 122 | +53 |
- #'+ |
||
| 123 | +54 |
- #' @return For `parent(x, dataset_name)` returns `NULL` if parent does not exist.+ |
||
| 124 | +55 |
- #'+ #' @keywords internal |
||
| 125 | +56 |
- #' @export+ .get_sorted_datanames <- function(datanames, join_keys, env) {
|
||
| 126 | -+ | |||
| 57 | +60x |
- #'+ child_parent <- sapply( |
||
| 127 | -+ | |||
| 58 | +60x |
- #' @examples+ datanames, |
||
| 128 | -+ | |||
| 59 | +60x |
- #' # Get individual parent ---+ function(name) parent(join_keys, name), |
||
| 129 | -+ | |||
| 60 | +60x |
- #'+ USE.NAMES = TRUE, |
||
| 130 | -+ | |||
| 61 | +60x |
- #' parent(jk, "ds2")+ simplify = FALSE |
||
| 131 | +62 |
- #' parent(td, "ADTTE")+ ) |
||
| 132 | +63 |
- parent <- function(x, dataset_name) {
+
+ |
+ ||
| 64 | +60x | +
+ union(+ |
+ ||
| 65 | +60x | +
+ intersect(unlist(topological_sort(child_parent)), ls(env)), |
||
| 133 | -179x | +66 | +60x |
- checkmate::assert_string(dataset_name)+ datanames |
| 134 | +67 |
- # assert x is performed by parents()- |
- ||
| 135 | -179x | -
- parents(x)[[dataset_name]]+ ) |
||
| 136 | +68 |
}@@ -17251,14 +14053,14 @@ teal.data coverage - 89.08% |
| 1 |
- #' Names of data sets in `teal_data` object+ #' Comprehensive data integration function for `teal` applications |
||
| 3 |
- #' Get or set the value of the `datanames` slot.+ #' @description |
||
| 4 |
- #'+ #' `r lifecycle::badge("stable")`
|
||
| 5 |
- #' The `@datanames` slot in a `teal_data` object specifies which of the variables stored in its environment+ #' |
||
| 6 |
- #' (the `@env` slot) are data sets to be taken into consideration.+ #' Universal function to pass data to teal application. |
||
| 7 |
- #' The contents of `@datanames` can be specified upon creation and default to all variables in `@env`.+ #' |
||
| 8 |
- #' Variables created later, which may well be data sets, are not automatically considered such.+ #' @param ... any number of objects (presumably data objects) provided as `name = value` pairs. |
||
| 9 |
- #' Use this function to update the slot.+ #' |
||
| 10 |
- #'+ #' @param join_keys (`join_keys` or single `join_key_set`) |
||
| 11 |
- #' @param x (`teal_data`) object to access or modify+ #' optional object with datasets column names used for joining. |
||
| 12 |
- #' @param value (`character`) new value for `@datanames`; all elements must be names of variables existing in `@env`+ #' If empty then no joins between pairs of objects. |
||
| 14 |
- #' @return The contents of `@datanames` or `teal_data` object with updated `@datanames`.+ #' @param code (`character`, `language`) optional code to reproduce the datasets provided in `...`. |
||
| 15 |
- #'+ #' Note this code is not executed and the `teal_data` may not be reproducible |
||
| 16 |
- #' @examples+ #' |
||
| 17 |
- #' td <- teal_data(iris = iris)+ #' @param check (`logical`) `r lifecycle::badge("deprecated")`
|
||
| 18 |
- #' td <- within(td, mtcars <- mtcars)+ #' Use [verify()] to verify code reproducibility . |
||
| 19 |
- #' datanames(td)+ #' |
||
| 20 |
- #'+ #' @return A `teal_data` object. |
||
| 21 |
- #' datanames(td) <- c("iris", "mtcars")
+ #' |
||
| 22 |
- #' datanames(td)+ #' @export |
||
| 24 |
- #' @name datanames+ #' @examples |
||
| 25 |
- #' @aliases datanames,teal_data-method+ #' teal_data(x1 = iris, x2 = mtcars) |
||
| 26 |
- #' @aliases datanames<-,teal_data,character-method+ #' |
||
| 27 |
- #' @aliases datanames,qenv.error-method+ teal_data <- function(..., |
||
| 28 |
- #' @aliases datanames<-,qenv.error,character-method+ join_keys = teal.data::join_keys(), |
||
| 29 |
-
+ code = character(0), |
||
| 30 |
- #' @rdname datanames+ check) {
|
||
| 31 | -+ | 48x |
- #' @export+ data_objects <- rlang::list2(...) |
| 32 | -15x | +48x |
- setGeneric("datanames", function(x) standardGeneric("datanames"))
+ if (inherits(join_keys, "join_key_set")) {
|
| 33 | -+ | ! |
- setMethod("datanames", signature = "teal_data", definition = function(x) {
+ join_keys <- teal.data::join_keys(join_keys) |
| 34 | -13x | +
- x@datanames+ } |
|
| 35 | -+ | 48x |
- })+ if (!missing(check)) {
|
| 36 | -+ | ! |
- setMethod("datanames", signature = "qenv.error", definition = function(x) {
+ lifecycle::deprecate_stop( |
| 37 | -2x | +! |
- NULL+ when = "0.4.0", |
| 38 | -+ | ! |
- })+ "teal_data( |
| 39 | -+ | ! |
-
+ check = 'check argument is deprecated. Use `verify()` to verify code reproducibility. |
| 40 | -+ | ! |
- #' @rdname datanames+ Find more information on https://github.com/insightsengineering/teal/discussions/945' |
| 41 |
- #' @export+ )" |
||
| 42 | -14x | +
- setGeneric("datanames<-", function(x, value) standardGeneric("datanames<-"))
+ ) |
|
| 43 |
- setMethod("datanames<-", signature = c("teal_data", "character"), definition = function(x, value) {
+ } |
||
| 44 | -13x | +
- checkmate::assert_subset(value, names(x@env))+ |
|
| 45 | -12x | +
- x@datanames <- .get_sorted_datanames(datanames = value, join_keys = x@join_keys, env = x@env)+ if ( |
|
| 46 | -12x | +48x |
- methods::validObject(x)+ checkmate::test_list( |
| 47 | -12x | +48x |
- x+ data_objects, |
| 48 | -+ | 48x |
- })+ types = c("TealDataConnector", "TealDataset", "TealDatasetConnector"),
|
| 49 | -+ | 48x |
- setMethod("datanames<-", signature = c("qenv.error", "character"), definition = function(x, value) {
+ min.len = 1 |
| 50 | -1x | +
- methods::validObject(x)+ ) |
|
| 51 | -1x | +
- x+ ) {
|
|
| 52 | -+ | ! |
- })+ lifecycle::deprecate_stop( |
| 53 | -+ | ! |
-
+ when = "0.4.0", |
| 54 | -+ | ! |
-
+ "teal_data( |
| 55 | -+ | ! |
- #' @keywords internal+ data_objects = 'should use data directly. Using TealDatasetConnector and TealDataset is deprecated. |
| 56 | -+ | ! |
- .get_sorted_datanames <- function(datanames, join_keys, env) {
+ Find more information on https://github.com/insightsengineering/teal/discussions/945' |
| 57 | -109x | +
- child_parent <- sapply(+ )" |
|
| 58 | -109x | +
- datanames,+ ) |
|
| 59 | -109x | +
- function(name) parent(join_keys, name),+ } else {
|
|
| 60 | -109x | +48x |
- USE.NAMES = TRUE,+ if (length(data_objects) > 0 && !checkmate::test_names(names(data_objects), type = "named")) {
|
| 61 | -109x | +! |
- simplify = FALSE+ stop("Dot (`...`) arguments on `teal_data()` must be named.")
|
| 62 |
- )+ } |
||
| 63 | -+ | 48x |
-
+ new_teal_data( |
| 64 | -109x | +48x |
- union(+ data = data_objects, |
| 65 | -109x | +48x |
- intersect(unlist(topological_sort(child_parent)), ls(env)),+ code = code, |
| 66 | -109x | +48x |
- datanames+ join_keys = join_keys |
| 67 |
- )+ ) |
||
| 68 | + |
+ }+ |
+ |
| 69 | +
} |