Skip to content

Commit

Permalink
restructure function-param-types.R to get types from traces for #76
Browse files Browse the repository at this point in the history
  • Loading branch information
@mpadge
mpadge committed Sep 8, 2022
1 parent ee15cf0 commit 157a42e
Show file tree
Hide file tree
Showing 4 changed files with 66 additions and 221 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: autotest
Title: Automatic Package Testing
Version: 0.0.2.202
Version: 0.0.2.203
Authors@R: c(
person("Mark", "Padgham", , "[email protected]", role = c("aut", "cre"),
comment = c(ORCID = "0000-0003-2172-5265")),
Expand Down
45 changes: 8 additions & 37 deletions R/autotest-functions.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -166,52 +166,23 @@ autotest_single_trace <- function (package,
test_data = NULL,
quiet = FALSE) {

# get parameter values:
par_index <- which (!nzchar (names (trace_data)))
par_names_i <- vapply (trace_data [par_index], function (j) j$par, character (1L))
par_vals_i <- lapply (trace_data [par_index], function (j) j$par_eval)
names (par_vals_i) <- par_names_i
index <- which (!vapply (par_vals_i, is.null, logical (1L)))
par_vals_i <- par_vals_i [index]
par_names_i <- par_names_i [index]

# get parameter classes & types:
index <- which (fn_pars$fn_name == trace_data$fn_name &
fn_pars$par_name %in% par_names_i)
fn_pars_i <- fn_pars [index, ]
fn_pars_i <- fn_pars_i [match (fn_pars_i$par_name, par_names_i), ]

# param_types are in [single, vector, tabular]
param_types <- rep (NA_character_, nrow (fn_pars_i))
is_single <- vapply (fn_pars_i$length, function (j)
all (as.integer (strsplit (j, ",") [[1]]) <= 1L),
logical (1L))
param_types [which (is_single)] <- "single"
is_rect <- vapply (trace_data [par_index], function (j)
j$typeof == "list" && length (dim (j$par_eval)) == 2,
logical (1L))
param_types [which (is_rect)] <- "tabular"

# reduce class to first value only
param_class <- gsub (",\\s.*$", "", fn_pars_i$class)
names (param_class) <- fn_pars_i$par_name
index <- which (!param_class %in% c (atomic_modes (), "data.frame"))
param_class <- param_class [index]
param_info <- get_param_info (trace_data, fn_pars)

test_obj <- autotest_obj (package = package,
package_loc = pkg_dir,
fn_name = trace_data$fn_name,
parameters = par_vals_i,
parameter_types = param_types,
class = param_class,
classes = param_class,
parameters = param_info$value,
parameter_types = param_info$type,
class = param_info$class,
classes = param_info$class,
env = new.env (),
test = test,
quiet = quiet)

int_val <- data.frame (
fn = trace_data$fn_name,
par = fn_pars_i$par_name,
int_val = fn_pars_i$storage_mode == "integer"
par = param_info$name,
int_val = param_info$storage_mode == "integer"
)
test_obj <- add_int_attrs (test_obj, int_val)

Expand Down
231 changes: 51 additions & 180 deletions R/function-param-types.R
View file
Original file line number Diff line number Diff line change
@@ -1,187 +1,58 @@

get_param_types <- function (fn, params, par_lengths) {

if (any (params == "NULL")) {
params <- params [params != "NULL"]
}

single_index <- single_params (params)
vec_index <- vector_params (params)
rect_index <- tabular_params (params)

param_types <- rep (NA_character_, length (params))
param_types [vec_index] <- "vector"
param_types [single_index] <- "single"
param_types [rect_index] <- "tabular"

# use par_lengths to set any parameters identified as single through usage
# in present example to vector
index <- which (par_lengths$par %in% names (params) & !par_lengths$single)
if (length (index) > 0) {
par_lengths <- par_lengths [index, , drop = FALSE]
param_types [match (par_lengths$par, names (params))] <- "vector"
}

return (param_types)
}

single_params <- function (params) {

is_single <- function (j) {
chk <- FALSE
if (is.null (dim (j)) && length (j) == 1) {
if (methods::is (j, "name")) {
val <- tryCatch (eval (parse (text = j)),
error = function (e) NULL)
if (!is.null (val))
chk <- length (val) == 1
} else if (!isS4 (j)) {
# single objects can still be almost anything, so only
# consider as truly single those objects which have
# attribute lists each element of which have at most two
# elements. This is entirely arbitrary, and should be
# modified once more is known about the kinds of things
# thrown at this function.
lens <- vapply (attributes (j), length, integer (1))
chk <- !any (lens > 2)
}
} else if (methods::is (j, "formula")) {
chk <- TRUE
}
return (chk)
}

return (which (vapply (params, function (j)
is_single (j),
logical (1))))
}

vector_params <- function (params) {

return (which (vapply (params, function (i)
length (i) > 1 &&
is.null (dim (i)) &&
is.atomic (i) &&
length (class (i) <= 1L) &&
any (grepl (atomic_modes (collapse = TRUE),
class (i))),
logical (1))))
}

tabular_params <- function (params) {

return (which (vapply (params, function (i)
length (dim (i)) == 2 &
!(inherits (i, "Matrix") |
inherits (i, "matrix")),
logical (1))))
}

#' single_or_vec
#' Get names, values, types and classes of parameters
#'
#' Do different usages within a single yaml indicate whether a parameter is
#' restricted to length one, or whether it can be a vector with length > 1?
#' @param res The parsed yaml returned from `parse_yaml_template`.
#' @param trace_data Result of a single 'typetracer' trace.
#' @param fn_pars Result of \link{get_unique_fn_pars} applied to a single trace.
#' @return A `list` of 4 item of "value", "type" and "class", and "storage_mode"
#' of each parameter, where "type" is one of "single", "vector", or "tabular"
#' (or otherwise NA).
#' @noRd
single_or_vec <- function (res) {

fns <- unique (names (res$parameters))

pkg_namespace <- paste0 ("package:", res$package)
pkg_env <- new.env (parent = as.environment (pkg_namespace))

pars <- lapply (fns, function (f) {

pars <- res$parameters [names (res$parameters) == f]
pars <- lapply (pars, function (i) {
nms <- names (unlist (i))
lens <- vapply (nms, function (j) {
ij <- unlist (i) [[j]]
out <- length (ij)
if (methods::is (ij, "name")) {
tmp <- tryCatch (
eval (parse (text = ij),
envir = pkg_env),
error = function (e) NULL)
if (!is.null (tmp))
out <- length (tmp)
}
return (out)
},
integer (1))
data.frame (name = nms,
len = lens) })

pars <- data.frame (do.call (rbind, unname (pars)))
pars <- lapply (split (pars, f = as.factor (pars$name)),
function (i)
i [which.max (i$len), , drop = FALSE])

pars <- do.call (rbind, pars)

data.frame (fn = f,
par = pars$name,
single = pars$len == 1,
stringsAsFactors = FALSE)
})

return (do.call (rbind, pars))
get_param_info <- function (trace_data, fn_pars) {

# get parameter values:
par_index <- which (!nzchar (names (trace_data)))
par_names_i <- vapply (trace_data [par_index], function (j) j$par, character (1L))
par_vals_i <- lapply (trace_data [par_index], function (j) j$par_eval)
names (par_vals_i) <- par_names_i
index <- which (!vapply (par_vals_i, is.null, logical (1L)))
par_vals_i <- par_vals_i [index]
par_names_i <- par_names_i [index]

# get parameter classes & types:
index <- which (fn_pars$fn_name == trace_data$fn_name &
fn_pars$par_name %in% par_names_i)
fn_pars_i <- fn_pars [index, ]
fn_pars_i <- fn_pars_i [match (fn_pars_i$par_name, par_names_i), ]

index <- which (par_names_i %in% fn_pars_i$par_name)
par_vals_i <- par_vals_i [index]
par_names_i <- par_names_i [index]

# param_types are in [single, vector, tabular]
param_types <- rep (NA_character_, nrow (fn_pars_i))
is_single <- vapply (fn_pars_i$length, function (j)
all (as.integer (strsplit (j, ",") [[1]]) <= 1L),
logical (1L))
param_types [which (is_single)] <- "single"
is_rect <- vapply (trace_data [par_index], function (j)
j$typeof == "list" && length (dim (j$par_eval)) == 2,
logical (1L))
param_types [which (is_rect)] <- "tabular"

# reduce class to first value only
param_class <- gsub (",\\s.*$", "", fn_pars_i$class)
names (param_class) <- fn_pars_i$par_name
index <- which (!param_class %in% c (atomic_modes (), "data.frame"))
param_class <- param_class [index]

list (
name = par_names_i,
value = par_vals_i,
type = param_types,
class = param_class,
storage_mode = fn_pars_i$storage_mode
)
}

#' double_or_int
#'
#' Do different usages within a single yaml indicate whether a single-length
#' parameter is intended to be an integer, yet without `L`, or whether it is
#' indeed a double?
#' @param res The parsed yaml returned from `parse_yaml_template`.
#' @noRd
double_or_int <- function (res) {

fns <- unique (names (res$parameters))

is_par_int <- function (p) {
ret <- FALSE
if (is.numeric (p))
ret <- all (abs (p - round (p)) < .Machine$double.eps)
if (!is.null (attr (p, "is_int")))
if (!attr (p, "is_int"))
ret <- FALSE
return (ret)
}

pars <- lapply (fns, function (f) {

pars <- res$parameters [names (res$parameters) == f] [[1]]
nms <- vapply (pars, names, character (1))
pars <- lapply (pars, function (i) i [[1]])
names (pars) <- nms

pars <- lapply (seq_along (pars), function (i) {
nms <- names (pars) [i]
int_val <- is_par_int (pars [[i]])
data.frame (name = nms,
int_val = int_val)
})

pars <- data.frame (do.call (rbind, unname (pars)))
pars <- lapply (split (pars, f = as.factor (pars$name)),
function (i) {
int_val <- all (i$int_val)
i <- i [1, ]
i$int_val <- int_val
return (i)
})

pars <- do.call (rbind, pars)

data.frame (fn = f,
par = pars$name,
int_val = pars$int_val,
stringsAsFactors = FALSE)
})

return (do.call (rbind, pars))
}

# add attributes to elements of `autotest_object` `x` identifying any parameters
# which are exclusively used as `int`, but not explicitly specified as such
Expand Down
9 changes: 6 additions & 3 deletions codemeta.json
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@
"codeRepository": "https://github.com/ropensci-review-tools/autotest",
"issueTracker": "https://github.com/ropensci-review-tools/autotest/issues",
"license": "https://spdx.org/licenses/GPL-3.0",
"version": "0.0.2.202",
"version": "0.0.2.203",
"programmingLanguage": {
"@type": "ComputerLanguage",
"name": "R",
Expand Down Expand Up @@ -313,10 +313,13 @@
},
"sameAs": "https://CRAN.R-project.org/package=yaml"
},
"SystemRequirements": null
"SystemRequirements": {}
},
"fileSize": "487.484KB",
"readme": "https://github.com/ropensci-review-tools/autotest/blob/main/README.md",
"contIntegration": ["https://github.com/ropensci-review-tools/autotest/actions?query=workflow%3AR-CMD-check", "https://codecov.io/gh/ropensci-review-tools/autotest"],
"contIntegration": [
"https://github.com/ropensci-review-tools/autotest/actions?query=workflow%3AR-CMD-check",
"https://codecov.io/gh/ropensci-review-tools/autotest"
],
"developmentStatus": "https://www.repostatus.org/#concept"
}

0 comments on commit 157a42e

Please sign in to comment.