diff --git a/DESCRIPTION b/DESCRIPTION index c12c2748c..d861ed5a7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,5 +62,4 @@ Collate: 'qenv-show.R' 'qenv-within.R' 'teal.code-package.R' - 'utils-code_dependency.R' 'utils.R' diff --git a/R/utils-code_dependency.R b/R/utils-code_dependency.R deleted file mode 100644 index 72c7d6771..000000000 --- a/R/utils-code_dependency.R +++ /dev/null @@ -1,360 +0,0 @@ -#' Create Object Dependencies Structure Within Parsed Code -#' -#' @description This function constructs a dependency structure that identifies the relationships between objects in -#' parsed code. It helps you understand which objects are needed to recreate a specific object. -#' -#' @details This function assumes that object relationships are established using the `<-`, `=`, or `->` assignment -#' operators. It does not support other object creation methods like `assign` or `<<-`, nor non-standard-evaluation -#' methods. To specify relationships between side-effects and objects, you can use the comment tag -#' `# @linksto object_name` at the end of a line where the side-effect occurs. -#' -#' @param code An `expression` with `srcref` attribute or a `character` with the code. -#' @param object_names (`character(n)`) A vector containing the names of existing objects. -#' -#' @return A `list` with three components: -#' - `occurrence`: A named `list` where object names are the names of existing objects, and each element is a numeric -#' vector indicating the calls in which the object appears. -#' - `cooccurrence`: A `list` of the same length as the number of calls in `parsed_code` -#' (`parsed_code = parse(text = code)` for code input as `character` and `parsed_code = code` for expression input. -#' It contains `NULL` values if there is no co-occurrence between objects or a `character` vector indicating the -#' co-occurrence of objects in a specific `parsed_code` call element. If it's a character vector, the first element is -#' the name of the dependent object, and the rest are the influencing objects. -#' - `effects`: A named `list` where object names are the names of existing objects, and each element is a numeric -#' vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, -#' the element is `NULL`. -#' -#' -#' @keywords internal -#' -code_dependency <- function(code, object_names) { - checkmate::assert_multi_class(code, classes = c("character", "expression")) - checkmate::assert_character(object_names, null.ok = TRUE) - - if (is.expression(code)) { - if (!is.null(attr(code, "srcref"))) { - parsed_code <- code - } else { - stop("The 'expression' code input does not contain 'srcref' attribute.") - } - } - - if (is.character(code)) { - parsed_code <- parse(text = code, keep.source = TRUE) - } - - pd <- utils::getParseData(parsed_code) - - calls_pd <- lapply(pd[pd$parent == 0, "id"], get_children, pd = pd) - - occurrence <- lapply(sapply(object_names, detect_symbol, calls_pd = calls_pd, simplify = FALSE), which) - - cooccurrence <- lapply( - calls_pd, - function(x) { - sym_cond <- which(x$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL") & x$text %in% object_names) - sym_form_cond <- which(x$token == "SYMBOL_FORMALS" & x$text %in% object_names) - sym_cond <- sym_cond[!x[sym_cond, "text"] %in% x[sym_form_cond, "text"]] - - object_ids <- x[sym_cond, "id"] - dollar_ids <- x[x$"token" %in% c("'$'", "'@'"), "id"] - after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] - sym_cond <- setdiff(sym_cond, which(x$id %in% after_dollar)) - - if (length(sym_cond) >= 2) { - ass_cond <- grep("ASSIGN", x$token) - text <- unique(x[sort(c(sym_cond, ass_cond)), "text"]) - - if (text[1] == "->") { - rev(text[-1]) - } else { - text[-1] - } - } - } - ) - - side_effects <- grep("@linksto", pd[pd$token == "COMMENT", "text"], value = TRUE) - check_effects <- - if (length(side_effects) > 0) { - affected <- - unlist(strsplit(sub("\\s*#\\s*@linksto\\s+", "", side_effects), "\\s+")) - - union(object_names, affected) - } else { - object_names - } - - effects <- sapply( - check_effects, - function(x) { - maxid <- suppressWarnings(max(occurrence[[x]])) - return_code_for_effects( - x, - calls_pd = calls_pd, - occur = suppressWarnings(lapply(occurrence, function(x) setdiff(x, maxid:max(maxid, max(x))))), - cooccur = cooccurrence, - eff = NULL - ) - }, - simplify = FALSE - ) - - list( - occurrence = occurrence, - cooccurrence = cooccurrence, - effects = effects - ) -} - -#' @title Get child calls within `getParseData()` object -#' @param pd (`data.frame`) A result of `utils::getParseData()`. -#' @param parent Object parent id in `utils::getParseData()`. -#' @return Row `bounded` `utils::getParseData()` of all elements of a call pointing to a `parent` id. -#' @keywords internal -get_children <- function(pd, parent) { - idx_children <- abs(pd$parent) == parent - children <- pd[idx_children, c("token", "text", "id")] - if (nrow(children) == 0) { - return(NULL) - } - - if (parent > 0) { - do.call(rbind, c(list(children), lapply(children$id, get_children, pd = pd))) - } -} - -#' @title Detects `"SYMBOL"` tokens for row `bounded` `getParseData()` structure -#' @param object `character` containing the name of the object -#' @param calls_pd A `list` of `data.frame`s, which is a result of `get_children(utils::getParseData(), parent = 0)` -#' applied on `parse(text = code, keep.source = TRUE)` at `code_dependency(code)`. -#' @return A `logical` vector pointing in which elements of `pd` the `SYMBOL` token row has `object` in text column -#' @keywords internal -detect_symbol <- function(object, calls_pd) { - vapply( - calls_pd, - function(call) { - is_symbol <- - any(call[call$token %in% c("SYMBOL", "SYMBOL_FUNCTION_CALL"), "text"] == object) - - is_formal <- used_in_function(call, object) - - object_ids <- call[call$text == object, "id"] - dollar_ids <- call[call$"token" %in% c("'$'", "'@'"), "id"] - after_dollar <- object_ids[(object_ids - 2) %in% dollar_ids] - object_ids <- setdiff(object_ids, after_dollar) - - is_symbol & !is_formal & length(object_ids) > 0 - }, - logical(1) - ) -} - -#' @title Whether an object is used inside a function within a call -#' @param call An element of `calls_pd` list used in `detect_symbol`. -#' @param object A character with object name. -#' @return A `logical(1)`. -#' @keywords internal -used_in_function <- function(call, object) { - if (any(call[call$token == "SYMBOL_FORMALS", "text"] == object) && any(call$token == "FUNCTION")) { - object_sf_ids <- call[call$text == object & call$token == "SYMBOL", "id"] - function_start_id <- call[call$token == "FUNCTION", "id"] - all(object_sf_ids > function_start_id) - } else { - FALSE - } -} - -#' Return the lines of code needed to reproduce the object. -#' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the `object` -#' -#' @param object `character` with object name -#' @param occur result of `code_dependency()$occurrence` -#' @param cooccur result of `code_dependency()$cooccurrence` -#' @param eff result of `code_dependency()$effects` -#' @param parent `NULL` or `numeric` vector - in a recursive call, it is possible needed to drop parent object -#' indicator to omit dependency cycles -#' -#' @return A `numeric` vector with number of lines of input `pd` to be returned. -#' -#' @keywords internal -return_code <- function(object, occur, cooccur, eff, parent = NULL) { - if (all(unlist(lapply(occur, length)) == 0)) { - return(NULL) - } - - influences <- vapply(cooccur, match, integer(1L), x = object) - where_influences <- which(influences > 1L) - object_influencers <- which(influences == 1L) - - object_influencers <- setdiff(object_influencers, parent) - - lines <- setdiff(occur[[object]], where_influences) - - if (length(object_influencers) == 0) { - return(sort(unique(lines))) - } else { - for (idx in object_influencers) { - influencer_names <- cooccur[[idx]][-1] - - influencer_lines <- - unlist( - lapply( - influencer_names, - return_code, - occur = suppressWarnings(lapply(occur, function(x) setdiff(x, idx:max(idx, max(x))))), - cooccur = cooccur[1:idx], - parent = where_influences, - eff = eff - ) - ) - - influencer_effects_lines <- unlist(eff[influencer_names]) - lines <- c(lines, influencer_lines, influencer_effects_lines) - } - sort(unique(lines)) - } -} - -#' Return the lines of code needed to reproduce the side-effects having an impact on the object. -#' @return `numeric` vector indicating which lines of `parsed_code` calls are required to build the side-effects having -#' and impact on the `object` -#' -#' @param object `character` with object name -#' @param calls_pd A `list` of `data.frame`s, which is a result of `get_children(utils::getParseData(), parent = 0)` -#' applied on `parse(text = code, keep.source = TRUE)` at `code_dependency(code)`. -#' @param occur result of `code_dependency()$occurrence` -#' @param cooccur result of `code_dependency()$cooccurrence` -#' -#' @return A `numeric` vector with number of lines of input `pd` to be returned for effects. -#' -#' @keywords internal -return_code_for_effects <- function(object, calls_pd, occur, cooccur, eff) { - symbol_effects_names <- - unlist( - lapply( - calls_pd, - function(x) { - com_cond <- - x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) - - # Make sure comment id is not the highest id in the item. - # For calls like 'options(prompt = ">") # @linksto ADLB', - # 'options(prompt = ">")' is put in a one item - # and '# @linksto ADLB' is the first element of the next item. - # This is tackled in B. - - - if (!com_cond[1] & sum(com_cond) > 0) { - # A. - x[x$token == "SYMBOL", "text"] - } else if (com_cond[1] & sum(com_cond[-1]) > 0) { - # B. - x <- x[-1, ] - x[x$token == "SYMBOL", "text"] - } - } - ) - ) - - commented_calls <- vapply( - calls_pd, - function(x) any(x$token == "COMMENT" & grepl("@linksto", x$text)), - logical(1) - ) - - symbol_effects_lines <- - unlist( - lapply( - symbol_effects_names, - function(x) { - code <- return_code(x, occur = occur, cooccur = cooccur, eff = eff) - if (is.null(code)) { - # Below is just used for comments with @linksto. - intersect(which(detect_symbol(x, calls_pd)), which(commented_calls)) - } else { - code - } - } - ) - ) - - # When commet_id is the highest id in the item - take previous item. - side_effects_names <- - unlist( - lapply( - calls_pd, - function(x) { - com_cond <- - x$token == "COMMENT" & grepl("@linksto", x$text) & grepl(paste0("[\\s]*", object, "[\\s$]*"), x$text) - - # Work out the situation when comment id is the highest id in the item. - # For calls like 'options(prompt = ">") # @linksto ADLB', - # 'options(prompt = ">")' is put in a one item - # and '# @linksto ADLB' is the first element of the next item. - - com_cond[1] - } - ) - ) - - side_effects_lines <- which(side_effects_names) - 1 - - sort(unique(c(symbol_effects_lines, side_effects_lines))) -} - -#' Return the lines of code (with side-effects) needed to reproduce the object -#' @return `character` vector of elements of `code` calls that were required to build the side-effects and -#' influencing objects having and impact on the `object` -#' -#' @param code An `expression` with `srcref` attribute or a `character` with the code. -#' @param names A `character(n)` with object names. -#' @keywords internal -get_code_dependency <- function(code, names) { - checkmate::assert_multi_class(code, classes = c("character", "expression")) - checkmate::assert_character(names) - - if (is.expression(code)) { - if (!is.null(attr(code, "srcref"))) { - parsed_code <- code - } else { - stop("The 'expression' code input does not contain 'srcref' attribute.") - } - } - - if (is.character(code)) { - parsed_code <- parse(text = code, keep.source = TRUE) - } - - pd <- utils::getParseData(parsed_code) - - symbols <- unique(pd[pd$token == "SYMBOL", "text"]) - - if (!all(names %in% symbols)) { - warning( - "Objects not found in 'qenv' environment: ", - toString(setdiff(names, symbols)) - ) - } - - code_dependency <- code_dependency(parsed_code, symbols) - - lines <- - sapply(names, function(name) { - object_lines <- - return_code( - name, - occur = code_dependency$occurrence, - cooccur = code_dependency$cooccurrence, - eff = code_dependency$effects - ) - - effects_lines <- code_dependency$effects[[name]] - c(object_lines, effects_lines) - }, - simplify = FALSE - ) - - object_lines_unique <- sort(unique(unlist(lines))) - - as.character(parsed_code)[object_lines_unique] -} diff --git a/man/code_dependency.Rd b/man/code_dependency.Rd deleted file mode 100644 index 87d815a2d..000000000 --- a/man/code_dependency.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{code_dependency} -\alias{code_dependency} -\title{Create Object Dependencies Structure Within Parsed Code} -\usage{ -code_dependency(code, object_names) -} -\arguments{ -\item{code}{An \code{expression} with \code{srcref} attribute or a \code{character} with the code.} - -\item{object_names}{(\code{character(n)}) A vector containing the names of existing objects.} -} -\value{ -A \code{list} with three components: -\itemize{ -\item \code{occurrence}: A named \code{list} where object names are the names of existing objects, and each element is a numeric -vector indicating the calls in which the object appears. -\item \code{cooccurrence}: A \code{list} of the same length as the number of calls in \code{parsed_code} -(\code{parsed_code = parse(text = code)} for code input as \code{character} and \code{parsed_code = code} for expression input. -It contains \code{NULL} values if there is no co-occurrence between objects or a \code{character} vector indicating the -co-occurrence of objects in a specific \code{parsed_code} call element. If it's a character vector, the first element is -the name of the dependent object, and the rest are the influencing objects. -\item \code{effects}: A named \code{list} where object names are the names of existing objects, and each element is a numeric -vector indicating which calls have an effect on that object. If there are no side-effects pointing at an object, -the element is \code{NULL}. -} -} -\description{ -This function constructs a dependency structure that identifies the relationships between objects in -parsed code. It helps you understand which objects are needed to recreate a specific object. -} -\details{ -This function assumes that object relationships are established using the \verb{<-}, \code{=}, or \verb{->} assignment -operators. It does not support other object creation methods like \code{assign} or \verb{<<-}, nor non-standard-evaluation -methods. To specify relationships between side-effects and objects, you can use the comment tag -\verb{# @linksto object_name} at the end of a line where the side-effect occurs. -} -\keyword{internal} diff --git a/man/detect_symbol.Rd b/man/detect_symbol.Rd deleted file mode 100644 index 28bacfdee..000000000 --- a/man/detect_symbol.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{detect_symbol} -\alias{detect_symbol} -\title{Detects \code{"SYMBOL"} tokens for row \code{bounded} \code{getParseData()} structure} -\usage{ -detect_symbol(object, calls_pd) -} -\arguments{ -\item{object}{\code{character} containing the name of the object} - -\item{calls_pd}{A \code{list} of \code{data.frame}s, which is a result of \code{get_children(utils::getParseData(), parent = 0)} -applied on \code{parse(text = code, keep.source = TRUE)} at \code{code_dependency(code)}.} -} -\value{ -A \code{logical} vector pointing in which elements of \code{pd} the \code{SYMBOL} token row has \code{object} in text column -} -\description{ -Detects \code{"SYMBOL"} tokens for row \code{bounded} \code{getParseData()} structure -} -\keyword{internal} diff --git a/man/get_children.Rd b/man/get_children.Rd deleted file mode 100644 index 73014b649..000000000 --- a/man/get_children.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{get_children} -\alias{get_children} -\title{Get child calls within \code{getParseData()} object} -\usage{ -get_children(pd, parent) -} -\arguments{ -\item{pd}{(\code{data.frame}) A result of \code{utils::getParseData()}.} - -\item{parent}{Object parent id in \code{utils::getParseData()}.} -} -\value{ -Row \code{bounded} \code{utils::getParseData()} of all elements of a call pointing to a \code{parent} id. -} -\description{ -Get child calls within \code{getParseData()} object -} -\keyword{internal} diff --git a/man/get_code_dependency.Rd b/man/get_code_dependency.Rd deleted file mode 100644 index 6f82f6b63..000000000 --- a/man/get_code_dependency.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{get_code_dependency} -\alias{get_code_dependency} -\title{Return the lines of code (with side-effects) needed to reproduce the object} -\usage{ -get_code_dependency(code, names) -} -\arguments{ -\item{code}{An \code{expression} with \code{srcref} attribute or a \code{character} with the code.} - -\item{names}{A \code{character(n)} with object names.} -} -\value{ -\code{character} vector of elements of \code{code} calls that were required to build the side-effects and -influencing objects having and impact on the \code{object} -} -\description{ -Return the lines of code (with side-effects) needed to reproduce the object -} -\keyword{internal} diff --git a/man/return_code.Rd b/man/return_code.Rd deleted file mode 100644 index 614676c49..000000000 --- a/man/return_code.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{return_code} -\alias{return_code} -\title{Return the lines of code needed to reproduce the object.} -\usage{ -return_code(object, occur, cooccur, eff, parent = NULL) -} -\arguments{ -\item{object}{\code{character} with object name} - -\item{occur}{result of \code{code_dependency()$occurrence}} - -\item{cooccur}{result of \code{code_dependency()$cooccurrence}} - -\item{eff}{result of \code{code_dependency()$effects}} - -\item{parent}{\code{NULL} or \code{numeric} vector - in a recursive call, it is possible needed to drop parent object -indicator to omit dependency cycles} -} -\value{ -\code{numeric} vector indicating which lines of \code{parsed_code} calls are required to build the \code{object} - -A \code{numeric} vector with number of lines of input \code{pd} to be returned. -} -\description{ -Return the lines of code needed to reproduce the object. -} -\keyword{internal} diff --git a/man/return_code_for_effects.Rd b/man/return_code_for_effects.Rd deleted file mode 100644 index f62859324..000000000 --- a/man/return_code_for_effects.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{return_code_for_effects} -\alias{return_code_for_effects} -\title{Return the lines of code needed to reproduce the side-effects having an impact on the object.} -\usage{ -return_code_for_effects(object, calls_pd, occur, cooccur, eff) -} -\arguments{ -\item{object}{\code{character} with object name} - -\item{calls_pd}{A \code{list} of \code{data.frame}s, which is a result of \code{get_children(utils::getParseData(), parent = 0)} -applied on \code{parse(text = code, keep.source = TRUE)} at \code{code_dependency(code)}.} - -\item{occur}{result of \code{code_dependency()$occurrence}} - -\item{cooccur}{result of \code{code_dependency()$cooccurrence}} -} -\value{ -\code{numeric} vector indicating which lines of \code{parsed_code} calls are required to build the side-effects having -and impact on the \code{object} - -A \code{numeric} vector with number of lines of input \code{pd} to be returned for effects. -} -\description{ -Return the lines of code needed to reproduce the side-effects having an impact on the object. -} -\keyword{internal} diff --git a/man/used_in_function.Rd b/man/used_in_function.Rd deleted file mode 100644 index cc791d8ab..000000000 --- a/man/used_in_function.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-code_dependency.R -\name{used_in_function} -\alias{used_in_function} -\title{Whether an object is used inside a function within a call} -\usage{ -used_in_function(call, object) -} -\arguments{ -\item{call}{An element of \code{calls_pd} list used in \code{detect_symbol}.} - -\item{object}{A character with object name.} -} -\value{ -A \code{logical(1)}. -} -\description{ -Whether an object is used inside a function within a call -} -\keyword{internal} diff --git a/tests/testthat/test-code_dependency.R b/tests/testthat/test-code_dependency.R deleted file mode 100644 index 5a4baf142..000000000 --- a/tests/testthat/test-code_dependency.R +++ /dev/null @@ -1,375 +0,0 @@ -testthat::test_that("get_code_dependency extract code of a binding from a simple code put in a character", { - q <- c( - "a <- 1", - "b <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - "a <- 1" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - "b <- 2" - ) -}) - -testthat::test_that("get_code_dependency warns if binding doesn't exist in a code", { - q <- c( - "a <- 1", - "b <- 2" - ) - testthat::expect_warning( - get_code_dependency(q, names = "c") - ) -}) - - -testthat::test_that( - "get_code_dependency extracts code of a parent binding but only those evaluated before coocurence", - { - q <- c( - "a <- 1", - "b <- a", - "a <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- a") - ) - } -) - -testthat::test_that("get_code_dependency extracts code of a parent binding if used as an arg in fun call", { - q <- c( - "a <- 1", - "b <- identity(x = a)", - "a <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- identity(x = a)") - ) -}) - -testthat::test_that("get_code_dependency is possible to output the code for multiple objects", { - q <- c( - "a <- 1", - "b <- 2", - "c <- 3" - ) - testthat::expect_identical( - get_code_dependency(q, names = c("a", "b")), - c("a <- 1", "b <- 2") - ) -}) - -testthat::test_that("get_code_dependency can't extract the code when no assign operator", { - q <- c( - "a <- 1", - "assign('b', 5)", - "b <- b + 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - "b <- b + 2" - ) -}) - -testthat::test_that("@linksto tag indicate affected object if object is assigned anywhere in a code", { - q <- c( - "a <- 1", - "assign('b', 5) # @linksto b", - "b <- b + 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("assign(\"b\", 5)", "b <- b + 2") - ) -}) - - -testthat::test_that( - "get_code_dependency can extract the code when function creates an object which is used only on rhs", - { - q <- c( - "data(iris)", - "iris2 <- head(iris)" - ) - testthat::expect_identical( - get_code_dependency(q, names = "iris2"), - c("data(iris)", "iris2 <- head(iris)") - ) - } -) - -testthat::test_that("get_code_dependency can extract the code when using <<-", { - q <- c( - "a <- 1", - "b <- a", - "b <<- b + 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- a", "b <<- b + 2") - ) -}) - -testthat::test_that("get_code_dependency detects every assign calls even if not evaluated", { - q <- c( - "a <- 1", - "b <- 2", - "eval(expression({b <- b + 2}))" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("b <- 2", "eval(expression({\n b <- b + 2\n}))") - ) -}) - - -# @linksto --------------------------------------------------------------------------------------------------------- - - -testthat::test_that("@linksto cause to return this line for affected binding", { - q <- " - a <- 1 # @linksto b - b <- 2 - " - - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- 2") - ) -}) - -testthat::test_that( - "@linksto returns this line for affected binding - even if object is not specificed/created in the same eval_code", - { - q <- c( - "a <- 1 # @linksto b", - "b <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- 2") - ) - } -) - -testthat::test_that( - "@linksto returns this line for affected binding - if object is not specificed in the same element of code", - { - q <- c( - "a <- 1 ", - "b <- 2 # @linksto a" - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - c("a <- 1", "b <- 2") - ) - } -) - -testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output", - { - q <- c( - "a <- 1", - "b <- a", - "a <- 3" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- a") - ) - } -) - -testthat::test_that( - "lines affecting parent evaluated after co-occurrence are not included in get_code_dependency output - when using @linksto", - { - q <- c( - "a <- 1 ", - "b <- 2 # @linksto a", - "a <- a + 1", - "b <- b + 1" - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - c("a <- 1", "b <- 2", "a <- a + 1") - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("b <- 2", "b <- b + 1") - ) - } -) - -testthat::test_that( - "@linksto gets extracted if it's a side-effect on a dependent object", - { - q <- " - iris[1:5, ] -> iris2 - iris_head <- head(iris) # @linksto iris2 - classes <- lapply(iris2, class) - " - testthat::expect_identical( - get_code_dependency(q, names = "classes"), - c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "classes <- lapply(iris2, class)") - ) - } -) - -testthat::test_that( - "@linksto gets extracted if it's a side-effect on a dependent object of a dependent object", - { - q <- " - iris[1:5, ] -> iris2 - iris_head <- head(iris) # @linksto iris3 - iris3 <- iris_head[1, ] # @linksto iris2 - classes <- lapply(iris2, class) - " - testthat::expect_identical( - get_code_dependency(q, names = "classes"), - c("iris2 <- iris[1:5, ]", "iris_head <- head(iris)", "iris3 <- iris_head[1, ]", "classes <- lapply(iris2, class)") - ) - } -) - -# functions ------------------------------------------------------------------------------------------------------- - -testthat::test_that("get_code_dependency ignores occurrence in function definition", { - q <- c( - "b <- 2", - "foo <- function(b) { b <- b + 2 }" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - "b <- 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "foo"), - "foo <- function(b) {\n b <- b + 2\n}" - ) -}) - -testthat::test_that("get_code_dependency ignores occurrence in function definition without { curly brackets", { - q <- c( - "b <- 2", - "foo <- function(b) b <- b + 2 " - ) - testthat::expect_identical( - get_code_dependency(q, names = "foo"), - "foo <- function(b) b <- b + 2" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - "b <- 2" - ) -}) - -testthat::test_that("get_code_dependency ignores effect of the object which occurs in a function definition", { - q <- c( - "b <- 2", - "foo <- function(b) { b <- b + 2 }" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("b <- 2") - ) -}) - -testthat::test_that("get_code_dependency detects occurrence of the function object", { - q <- c( - "a <- 1", - "b <- 2", - "foo <- function(b) { b <- b + 2 }", - "b <- foo(a)" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- 2", "foo <- function(b) {\n b <- b + 2\n}", "b <- foo(a)") - ) -}) - -testthat::test_that( - "Can't detect occurrence of function definition when a formal is named the same as a function", - { - q <- c( - "x <- 1", - "foo <- function(foo = 1) 'text'", - "a <- foo(x)" - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - c("x <- 1", "foo <- function(foo = 1) \"text\"", "a <- foo(x)") - ) - } -) - -# $ --------------------------------------------------------------------------------------------------------------- - -testthat::test_that("get_code_dependency understands $ usage and do not treat rhs of $ as objects (only lhs)", { - q <- c( - "x <- data.frame(a = 1:3)", - "a <- data.frame(y = 1:3)", - "a$x <- a$y", - "a$x <- a$x + 2", - "a$x <- x$a" - ) - testthat::expect_identical( - get_code_dependency(q, names = "x"), - c("x <- data.frame(a = 1:3)") - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - c("x <- data.frame(a = 1:3)", "a <- data.frame(y = 1:3)", "a$x <- a$y", "a$x <- a$x + 2", "a$x <- x$a") - ) -}) - -testthat::test_that("get_code_dependency detects cooccurrence properly even if all objects are on rhs", { - q <- c( - "a <- 1", - "b <- list(c = 2)", - "b[[a]] <- 3" - ) - testthat::expect_identical( - get_code_dependency(q, names = "b"), - c("a <- 1", "b <- list(c = 2)", "b[[a]] <- 3") - ) -}) - - -# @ --------------------------------------------------------------------------------------------------------------- - -testthat::test_that("get_code_dependency understands @ usage and do not treat rhs of @ as objects (only lhs)", { - q <- c( - "setClass('aclass', slots = c(a = 'numeric', x = 'numeric', y = 'numeric')) # @linksto a x", - "x <- new('aclass', a = 1:3, x = 1:3, y = 1:3)", - "a <- new('aclass', a = 1:3, x = 1:3, y = 1:3)", - "a@x <- a@y", - "a@x <- a@x + 2", - "a@x <- x@a" - ) - testthat::expect_identical( - get_code_dependency(q, names = "x"), - c( - 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', - 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)' - ) - ) - testthat::expect_identical( - get_code_dependency(q, names = "a"), - c( - 'setClass("aclass", slots = c(a = "numeric", x = "numeric", y = "numeric"))', - 'x <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', - 'a <- new("aclass", a = 1:3, x = 1:3, y = 1:3)', - "a@x <- a@y", - "a@x <- a@x + 2", - "a@x <- x@a" - ) - ) -})