From 038577c607a26617b91dac463447b55df1096965 Mon Sep 17 00:00:00 2001 From: mpadge Date: Thu, 22 Jun 2023 11:30:04 +0200 Subject: [PATCH] only extract call_envs once for each call, not for each parameter #14, #16 --- DESCRIPTION | 2 +- R/load-and-clear-traces.R | 19 +++----- R/tracer-define.R | 69 +++++++++++++++--------------- codemeta.json | 2 +- tests/testthat/_snaps/trace-fns.md | 52 +++++++++++----------- 5 files changed, 68 insertions(+), 76 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9a8c078..ac9e8a9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: typetracer Title: Trace Function Parameter Types -Version: 0.1.1.023 +Version: 0.1.1.024 Authors@R: c( person("Mark", "Padgham", , "mark.padgham@email.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0003-2172-5265")), diff --git a/R/load-and-clear-traces.R b/R/load-and-clear-traces.R index 8cedafc..d98ef71 100644 --- a/R/load-and-clear-traces.R +++ b/R/load-and-clear-traces.R @@ -28,19 +28,18 @@ load_traces <- function (files = FALSE, quiet = FALSE) { par_formals <- tr_i$formals num_traces <- tr_i$num_traces trace_source <- tr_i$source # only exists for packages + call_envs <- tr_i$call_envs tr_i <- tr_i [which (!names (tr_i) %in% - c ("fn_name", "formals", "num_traces", "source"))] + c ("fn_name", "formals", "num_traces", "source", "call_envs"))] fn_call_hash <- gsub ("^.*typetrace\\_|\\.Rds$", "", i) # simple vector columns: par_name <- vapply (tr_i, function (i) i$par, character (1L)) types <- vapply (tr_i, function (i) i$type, character (1L)) modes <- vapply (tr_i, function (i) i$mode, character (1L)) - storage_mode <- vapply ( # wrapped coz otherwise > 80 char wide - tr_i, function (i) { - i$storage_mode - }, + storage_mode <- vapply ( + tr_i, function (i) i$storage_mode, character (1) ) len <- vapply (tr_i, function (i) i$length, integer (1L)) @@ -50,13 +49,9 @@ load_traces <- function (files = FALSE, quiet = FALSE) { par_uneval <- I (lapply (tr_i, function (i) i$par_uneval)) par_eval <- I (lapply (tr_i, function (i) i$par_eval)) - call_envs <- do.call (rbind, lapply (tr_i, function (i) { - ci <- i$call_envs - if (nrow (ci) == 0L) { - ci <- ci [1, ] # auto-fills with NA - } - return (ci) - })) + if (nrow (call_envs) == 0L) { + call_envs <- call_envs [1, ] # auto-fills with NA + } call_envs$call_env <- paste0 (call_envs$namespace, "::", call_envs$name) call_envs$call_env [which (is.na (call_envs$name))] <- NA_character_ diff --git a/R/tracer-define.R b/R/tracer-define.R index 2906894..66b3c86 100644 --- a/R/tracer-define.R +++ b/R/tracer-define.R @@ -87,39 +87,6 @@ typetracer_header <- function () { } } - # Extract calling environments, noting that rlang enumerates envs from - # "0" for the calling environment. For srcref structure, see: - # https://journal.r-project.org/archive/2010-2/RJournal_2010-2_Murdoch.pdf # nolint - # Note that line numbers in srcref are from parsed versions, so will - # generally not exactly match. - trace_dat <- rlang::trace_back (bottom = fn_env) - trace_dat <- trace_dat [which (trace_dat$parent == 0), ] - call_envs <- lapply (trace_dat$call, function (i) { - call_i <- data.frame ( - name = as.character (as.name (as.list (i) [[1]])), - file = NA_character_, - linestart = NA_integer_, - lineend = NA_integer_ - ) - if (!is.null (attributes (i)$srcref)) { - call_i$file <- attr (attributes (i)$srcref, "srcfile")$filename - call_i$linestart <- attr (i, "srcref") [1] - call_i$lineend <- attr (i, "srcref") [3] - } - return (call_i) - }) - call_envs <- do.call (rbind, call_envs) - call_envs$namespace <- trace_dat$namespace - index <- which (is.na (call_envs$namespaces)) - if (length (index) > 0L) { - call_envs$namespace [index] <- trace_dat$scope [index] - } - call_envs <- call_envs [which (call_envs$namespace != "typetracer"), ] - if (nrow (call_envs) > 0L) { - # assume first branch of trace_back is desired env - call_envs <- call_envs [1, ] - } - list ( par = p, class = class (res), @@ -128,11 +95,43 @@ typetracer_header <- function () { mode = mode (res), length = length (res), par_uneval = s, - par_eval = res, - call_envs = call_envs + par_eval = res ) + }) + # Extract calling environments, noting that rlang enumerates envs from + # "0" for the calling environment. For srcref structure, see: + # https://journal.r-project.org/archive/2010-2/RJournal_2010-2_Murdoch.pdf # nolint + # Note that line numbers in srcref are from parsed versions, so will + # generally not exactly match. + trace_dat <- rlang::trace_back (bottom = fn_env) + trace_dat <- trace_dat [which (trace_dat$parent == 0), ] + call_envs <- lapply (trace_dat$call, function (i) { + call_i <- data.frame ( + name = as.character (as.name (as.list (i) [[1]])), + file = NA_character_, + linestart = NA_integer_, + lineend = NA_integer_ + ) + if (!is.null (attributes (i)$srcref)) { + call_i$file <- attr (attributes (i)$srcref, "srcfile")$filename + call_i$linestart <- attr (i, "srcref") [1] + call_i$lineend <- attr (i, "srcref") [3] + } + return (call_i) }) + call_envs <- do.call (rbind, call_envs) + call_envs$namespace <- trace_dat$namespace + index <- which (is.na (call_envs$namespaces)) + if (length (index) > 0L) { + call_envs$namespace [index] <- trace_dat$scope [index] + } + call_envs <- call_envs [which (call_envs$namespace != "typetracer"), ] + if (nrow (call_envs) > 0L) { + # assume first branch of trace_back is desired env + call_envs <- call_envs [1, ] + } + typetracer_env$data$call_envs <- call_envs typetracer_env$data$fn_name <- as.character (typetracer_env$fn_name) typetracer_env$data$formals <- typetracer_env$par_formals diff --git a/codemeta.json b/codemeta.json index 1a270a8..fed9eed 100644 --- a/codemeta.json +++ b/codemeta.json @@ -11,7 +11,7 @@ "codeRepository": "https://github.com/mpadge/typetracer", "issueTracker": "https://github.com/mpadge/typetracer/issues", "license": "https://spdx.org/licenses/MIT", - "version": "0.1.1.023", + "version": "0.1.1.024", "programmingLanguage": { "@type": "ComputerLanguage", "name": "R", diff --git a/tests/testthat/_snaps/trace-fns.md b/tests/testthat/_snaps/trace-fns.md index 8eb6097..03720ae 100644 --- a/tests/testthat/_snaps/trace-fns.md +++ b/tests/testthat/_snaps/trace-fns.md @@ -49,36 +49,34 @@ s <- "NULL" } } - trace_dat <- rlang::trace_back(bottom = fn_env) - trace_dat <- trace_dat[which(trace_dat$parent == 0), - ] - call_envs <- lapply(trace_dat$call, function(i) { - call_i <- data.frame(name = as.character(as.name(as.list(i)[[1]])), - file = NA_character_, linestart = NA_integer_, - lineend = NA_integer_) - if (!is.null(attributes(i)$srcref)) { - call_i$file <- attr(attributes(i)$srcref, "srcfile")$filename - call_i$linestart <- attr(i, "srcref")[1] - call_i$lineend <- attr(i, "srcref")[3] - } - return(call_i) - }) - call_envs <- do.call(rbind, call_envs) - call_envs$namespace <- trace_dat$namespace - index <- which(is.na(call_envs$namespaces)) - if (length(index) > 0L) { - call_envs$namespace[index] <- trace_dat$scope[index] - } - call_envs <- call_envs[which(call_envs$namespace != "typetracer"), - ] - if (nrow(call_envs) > 0L) { - call_envs <- call_envs[1, ] - } list(par = p, class = class(res), typeof = typeof(res), storage_mode = storage.mode(res), mode = mode(res), - length = length(res), par_uneval = s, par_eval = res, - call_envs = call_envs) + length = length(res), par_uneval = s, par_eval = res) }) + trace_dat <- rlang::trace_back(bottom = fn_env) + trace_dat <- trace_dat[which(trace_dat$parent == 0), ] + call_envs <- lapply(trace_dat$call, function(i) { + call_i <- data.frame(name = as.character(as.name(as.list(i)[[1]])), + file = NA_character_, linestart = NA_integer_, lineend = NA_integer_) + if (!is.null(attributes(i)$srcref)) { + call_i$file <- attr(attributes(i)$srcref, "srcfile")$filename + call_i$linestart <- attr(i, "srcref")[1] + call_i$lineend <- attr(i, "srcref")[3] + } + return(call_i) + }) + call_envs <- do.call(rbind, call_envs) + call_envs$namespace <- trace_dat$namespace + index <- which(is.na(call_envs$namespaces)) + if (length(index) > 0L) { + call_envs$namespace[index] <- trace_dat$scope[index] + } + call_envs <- call_envs[which(call_envs$namespace != "typetracer"), + ] + if (nrow(call_envs) > 0L) { + call_envs <- call_envs[1, ] + } + typetracer_env$data$call_envs <- call_envs typetracer_env$data$fn_name <- as.character(typetracer_env$fn_name) typetracer_env$data$formals <- typetracer_env$par_formals typetracer_env$data$num_traces <- typetracer_env$num_traces