#+r-pkg-version: 0.0.0.9000 #+r-pkg-url: https://github.com/stasvlasov/inlist #+r-pkg-bug-reports: https://github.com/stasvlasov/inlist/issues
:export_options+: author:nil :export_options+: title:nil#+end
Its main function inlist(your_list, i, j) filters your_list by i and applies j. For those familiar with data.table the inlist’s interface is similar to data.table’s `[` extractor method (i.e., data.table:::`[.data.table`(dt, i ,j) means subset dt using i and manipulate with j). Each list’s element is bound to environment where filtering (i) and selection (j) is evaluated However, unlike data.table’s i and j list’s named elements in inlist are bound to variables that are prefixed with .. It also binds special variables ., .., ..., .n, .N, ..n and ..N variables for accessing the list element itself, the original list, elements’ index, length of the list, etc. as well as a special function ._() which can be used to subsitute default values when some list’s elemenst are not available.
l <- list(list(a = 1
, b = 1)
, list(a = 2
, b = 2
, c = 2)
, list(a = 3
, b = 3
, e = 3)
, list(a = 4
, b = 4
, e = 4
, d = 4
, f = 4))
inlist(l, .n == length(.), .b)
# [[1]]
# [1] 3
inlist(l, .e, .a)
# [[1]]
# [1] 3
#
# [[2]]
# [1] 4
inlist(l, , .a)
# [[1]]
# [1] 1
#
# [[2]]
# [1] 2
#
# [[3]]
# [1] 3
#
# [[4]]
# [1] 4
inlist(l, , paste("Hello", .a, "world!"))
# [[1]]
# [1] "Hello 1 world!"
#
# [[2]]
# [1] "Hello 2 world!"
#
# [[3]]
# [1] "Hello 3 world!"
#
# [[4]]
# [1] "Hello 4 world!"
inlist(l, , paste("Hello", .e, "world!"))
# [[1]]
# [1] "Hello 3 world!"
#
# [[2]]
# [1] "Hello 4 world!"
inlist(l, , paste("Hello", .a, ._(.e + ._(.f, 10) , "brave"), "world!"))
# [[1]]
# [1] "Hello 1 brave world!"
#
# [[2]]
# [1] "Hello 2 brave world!"
#
# [[3]]
# [1] "Hello 3 13 world!"
#
# [[4]]
# [1] "Hello 4 8 world!"
devtools::install_github("<<github-repo()>>")| name | version |
|---|---|
| utils |
| name | version | comment |
|---|---|---|
| tinytest | for package development (unit testing) |
##' Select and apply expression to elements of table like lists.
##'
##' Each list element is attached to both `extractor` and `applicator` environment so its own named elements are available as variables prefixed with "." (dot character).
##'
##' - `.` - current list's element
##' - `..` - (filtered) list (in `extractor` environment it is the same as initial list)
##' - `.n` - (filtered) list element's index
##' - `.N` - (filtered) list's length
##' - `...` - initial list (`l`)
##' - `..n` - initial list element's index
##' - `..N` - initial list's length
##' - `._(x, fb)` - function that returns the fallback `fb` if some of the variables in `x` are unbound (i.e., due to non existing list elements)
##'
##' @param l list (or NULL)
##' @param extractor Predicate expression to filter list elements before applying evaluated in the environment of list's element
##' @param applicator Expression applied to each element of the list evaluated in the element's environment
##' @param fallback Optional. If provided use this value as a fall back in case some variables (prefixed with dot) are not fount in the list's element environment. Otherwise (the default) those elements will be ignored and not included to results
##'
##' @return List of filtered with `extractor` elements with values returned by `applicator`. Unbound expressions are omitted (if `fallback` is not provided) so list might be shorter.
##'
##' @export
inlist <- function(l, extractor, applicator, fallback) {
if(!is.list(l) & !is.null(l)) stop("inlist -- argument `l` should be either list or NULL")
if(base::missing(fallback)) {
fallback_void <- TRUE
fallback <- NULL
} else {
fallback_void <- FALSE
}
sys_call <- as.list(sys.call())
parent_frame <- parent.frame()
## eval in elements envir
.eval <- function(envir, index, x, fallback, wrapper, .l, n = index, prefix_dots = TRUE) {
## `(` is identity function
## prepend dot to names
if(length(envir) > 0 & prefix_dots) {
names(envir) <- ifelse(names(envir) != "", paste0(".", names(envir)), "")
}
envir <- c(envir, list(. = envir
, .. = .l
, .n = index
, .N = length(.l)
, ... = l
, ..n = n
, ..N = length(l)
, ._ = \(x, fallback = NULL) {
.eval(envir
, index
, as.list(sys.call())[[2]] # i.e., x
, fallback
, `(`
, .l
, n
, prefix_dots = FALSE)
}))
vars_skip <- NULL
## check if function was used and eval even if args are not bound
if("._" %in% all.names(x)) {
x_data <-
parse(text = deparse1(x), keep.source = TRUE) |>
utils::getParseData()
while(!is.na(i <- which(x_data$text == "._")[1])) {
x_data <- x_data[-(1:i),]
x_data <- x_data[x_data$token != "expr",]
x_data <- split(x_data, cumsum(x_data$parent == x_data$parent[1]))
## if there are parent elements then there were arguments
if(length(x_data) %in% c(2,3)) {
._first_arg <- x_data[[1]][-1,]
vars_skip <- c(vars_skip, ._first_arg[._first_arg$token == "SYMBOL", "text"])
x_data <- x_data[[length(x_data)]][-1,]
} else {
stop("inlist -- wrong number of arguments in ._() function")
}
}
}
vars <- all.vars(x)
## remove vars that are in ._
vars <- vars[!(vars %in% vars_skip)]
## find vars names that starts with .
vars <- vars[substr(vars,0,1) == "."]
vars_exist <- sapply(vars, \(v) eval(bquote(exists(.(v))), envir, parent_frame))
if(all(vars_exist)) {
do.call(wrapper, list(eval(x, envir, parent_frame)))
} else {
return(fallback)
}
}
## apply with index
.apply <- function(.l, x, wrapper = `(`, fallback, ..n = NULL) {
mapply(
\(e, i, n) .eval(e, i, x, fallback, wrapper, .l, n)
, e = .l
, i = seq_along(.l)
, n = if(is.null(..n)) seq_along(.l) else ..n
, SIMPLIFY = FALSE)
}
## filter
if(missing(extractor)) {
extract_l <- TRUE
} else {
extractor <- sys_call[[3]]
extract_l <- .apply(l, extractor, fallback = FALSE, wrapper = Negate(isFALSE)) |> unlist()
}
## map
if(missing(applicator)) {
apply_l <- l[extract_l]
} else {
applicator <- sys_call[[4]]
apply_l <- .apply(l[extract_l], applicator, fallback, wrapper = list, ..n = seq_along(l)[extract_l])
}
## return()
if(fallback_void) {
apply_l <- Filter(Negate(is.null), apply_l)
}
return(lapply(apply_l, unlist, recursive = FALSE))
}
l <- list(list(a = 1
, b = 1)
, list(a = 2
, b = 2
, c = 2)
, list(a = 3
, b = 3
, e = 3)
, list(a = 4
, b = 4
, e = 4
, d = 4
, f = 4))
## test placeholders
expect_equal(
inlist(l, .n == length(.), .b)
, list(3)
)
## test filter
expect_equal(
inlist(l, .e, .a)
, list(3, 4)
)
expect_equal(
inlist(l, , .a)
, list(1, 2, 3, 4)
)
expect_equal(
inlist(l, , paste("Hello", .a, "world!"))
, list("Hello 1 world!", "Hello 2 world!", "Hello 3 world!", "Hello 4 world!")
)
expect_equal(
inlist(l, , paste("Hello", .e, "world!"))
, list("Hello 3 world!", "Hello 4 world!")
)
## substitutes
expect_equal(
inlist(l, , ._(paste("f is", .f), "f does not exist"))
, list("f does not exist"
, "f does not exist"
, "f does not exist"
, "f is 4")
)
expect_equal(
inlist(l, , paste("Hello", .a, ._(.e + ._(.f, 10) , "brave"), "world!"))
, list("Hello 1 brave world!"
, "Hello 2 brave world!"
, "Hello 3 13 world!"
, "Hello 4 8 world!"))
## Check types
l <- NULL
expect_equal(
inlist(l, .n == length(.), .b)
, list()
)
l <- list()
expect_equal(
inlist(l, .n == length(.), .b)
, list()
)
l <- ""
expect_error(
inlist(l, .n == length(.), .b)
)
l <- 1
expect_error(
inlist(l, .n == length(.), .b)
)
l <- NA
expect_error(
inlist(l, .n == length(.), .b)
)