Nothing
# is.element function for R6 objects
r6_is_element <- function(e, x) {
return(any(vapply(x, FUN.VALUE = TRUE, FUN = identical, y = e)))
}
# setequal function for R6 objects
r6_setequal <- function(A, B) {
# is e an element of x
AinB <- all(
vapply(A, FUN.VALUE = TRUE, FUN = r6_is_element, x = B)
)
BinA <- all(
vapply(B, FUN.VALUE = TRUE, FUN = r6_is_element, x = A)
)
return(AinB & BinA)
}
# custom expectation to compare two sets of R6 objects
expect_r6_setequal <- function(object, eset) {
# capture object and label
act <- testthat::quasi_label(rlang::enquo(object), arg = "object")
# copy the object
oset <- act$val
# coerce it to a list
oset <- if (is.list(oset)) oset else list(oset)
# object must be a list of R6 objects
if (!is.list(oset)) {
testthat::expect(
ok = FALSE,
sprintf("%s must be a list", act$lab)
)
}
is_r6 <- vapply(oset, FUN.VALUE = TRUE, FUN = inherits, what = "R6")
if (!all(is_r6)) {
testthat::expect(
ok = FALSE,
sprintf("%s must be a list of R6 objects", act$lab)
)
}
# compare sets
testthat::expect(
ok = r6_setequal(oset, eset),
sprintf("%s is not equal to to the expected set", act$lab)
)
# Invisibly return the value
invisible(oset)
}
# expectation that a numeric value is equal within tolerance. The expectation
# expect_equal from testthat appears from its documentation to do exactly this,
# but seems to be configured to ignore small floating point differences. In this
# version any specified tolerance is permitted.
expect_intol <- function(object, E, tolerance) {
# capture object and label
act <- testthat::quasi_label(rlang::enquo(object), arg = "object")
# object must be numeric
if (!is.numeric(act$val)) {
testthat::expect(
ok = FALSE,
sprintf("%s must be numeric", act$lab)
)
}
# test if object value is equal to E within tolerance
testthat::expect(
ok = (abs(act$val - E) <= tolerance),
sprintf("%s (%f) is not within %f of %f", act$lab, act$val, tolerance, E)
)
# Invisibly return the value
invisible(act$val)
}
# expectation that object, lies in an interval (including its limits).
expect_between <- function(object, lower, upper) {
# capture object and label
act <- testthat::quasi_label(rlang::enquo(object), arg = "object")
# test
testthat::expect(
ok = ((act$val >= lower) && (act$val <= upper)),
sprintf(
"%s (%f) does not lie in the interval [%f,%f]",
act$lab, act$val, lower, upper
)
)
# Invisibly return the value
invisible(act$val)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.