Skip to content

Commit

Permalink
only extract call_envs once for each call, not for each parameter #14, …
Browse files Browse the repository at this point in the history 
…#16
  • Loading branch information
@mpadge
mpadge committed Jun 22, 2023
1 parent 64522b3 commit 038577c
Show file tree
Hide file tree
Showing 5 changed files with 68 additions and 76 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -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", , "[email protected]", role = c("aut", "cre"),
comment = c(ORCID = "0000-0003-2172-5265")),
Expand Down
19 changes: 7 additions & 12 deletions R/load-and-clear-traces.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand All @@ -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_

Expand Down
69 changes: 34 additions & 35 deletions R/tracer-define.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand All @@ -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
Expand Down
2 changes: 1 addition & 1 deletion codemeta.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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",
Expand Down
52 changes: 25 additions & 27 deletions tests/testthat/_snaps/trace-fns.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down

0 comments on commit 038577c

Please sign in to comment.