Skip to content

Instantly share code, notes, and snippets.

@garyfeng
Last active September 23, 2015 14:12
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save garyfeng/45fe1015710d77bc4909 to your computer and use it in GitHub Desktop.
Save garyfeng/45fe1015710d77bc4909 to your computer and use it in GitHub Desktop.
Creating an operator to extract a named member of a list that is in a list. Why? Read on. [Now part of the "pdata" library at github.com/garyfeng/pdata.
# To create an operator to extract a named member of a list that is in a list.
# This may sound confusing, but imagine you have a data.frame where a variable/column is a list of lists,
# and the lists have named members, e.g.,
# df$itinary <- list(list(from="NYC", to="LA", via="train"), list(from="LA", to="SF"), ...)
# You want to get the "from" value of itinary as a vector. You can do
# df$itinary@"from" or `@`(df$itinary, "via")
# Typically you'd use ```sapply(x, function(m) {m[["from"]]})```. The following is an extention to the idea in 2 ways:
# 1). We define a in-fix operator `@` that does so in a way that is syntactically more natural
# 2). We added error handling, in the case of bad indecies, etc.
require(testthat)
# %@@% is the permissive operator that returns a vector or, in the case of non-atomic properties, a list
`%@@%` <- function(x, key) {
# makesure the input vars are valid
force(x); force(key);
if(missing(key)) stop()
if(!is.list(x)) stop("First parameter must be a list")
sapply(x, function(c) {
result <- tryCatch(
# test the following code
{`[[`(c, key);}
, warning = function(war) {print(war)}
, error = function(err) {print(err); result<-NA}
#, finally = {stop("Error `@`: will reach this step no matter what.")}
)
if (is.null(result)) result<-NA
result
})
}
# @ and %@% are strict versions of @@ that only returns a vector of atomic values, replacing everything else with NA
`@` <- `%@%` <- function(x, key) {
result <-x%@@%key
if(is.list(result)) {
sapply(result, function(x){
if(is.atomic(x)) x else NA
})
} else {
result
}
}
### Unit testing ###
testvec <- list(
list(from=1, to="here", date="1990-12-12"),
list(from=2, to="there", via=list("train", "airplane"), date=123.45)
)
key <- "from"
test_that("`@` and `@@` return the desired properties as a vector", {
expect_equal(testvec%@%"from", c(1,2))
expect_equal(testvec%@%"to", c("here", "there"))
expect_equal(testvec@key, c(1,2))
expect_equal(testvec@"to", c("here", "there"))
expect_equal(`@`(testvec, 2), c("here", "there"))
expect_equal(testvec%@@%"from", c(1,2))
expect_equal(testvec%@@%"to", c("here", "there"))
expect_equal(`%@@%`(testvec, 2), c("here", "there"))
})
test_that("`@` and `%@@%` return a vector of NA when the property
does not exist in the element, without a warning or a message", {
expect_equal(testvec%@%"not a property", c(NA, NA))
expect_equal(testvec%@@%"not a property", c(NA, NA))
})
test_that("`@` and `%@@%` coerce returned vector into the class of first element", {
expect_equal(testvec@"date", c("1990-12-12", "123.45"))
expect_equal(testvec%@@%"date", c("1990-12-12", "123.45"))
})
test_that("`@` returns a vector of NA when the property does not exist, whereas
the more permissive `%@@%` will return a list", {
expect_equal(testvec%@@%"via", list(NA, list("train", "airplane")))
expect_equal(testvec%@%"via", c(NA, NA))
})
test_that("`@` and `%@@%` return a vector of NA when the index is out of bound, and prints a message", {
expect_equal(`@`(testvec, 10), c(NA, NA))
expect_equal(`%@%`(testvec, list(1,"that")), c(NA, NA))
expect_equal(`%@@%`(testvec, 10), c(NA, NA))
expect_equal(`%@@%`(testvec, list(1,"that")), c(NA, NA))
})
test_that("`@` and `%@@%` throw errors in the following tests", {
expect_error(`@`(whatever, 10))
expect_error(`@`(testvec, nonsenseKey))
expect_error(`%@%`(list(1,"that")))
expect_error(`%@%`("that", 1))
expect_error(`%@@%`(c(1,2,3), 1))
})
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment