Nothing
test_that("properties are set correctly", {
x <- 2L
y <- 3.0
expect_error(ExprModVar$new("z", "GBP", x + y), class = "quo_not_quosure")
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x + y))
expect_true(z$is_expression())
expect_identical(z$distribution(), "x + y")
expect_false(z$is_probabilistic())
#
y <- ConstModVar$new("y", "GBP", 42.0)
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x + y))
expect_true(z$is_expression())
expect_identical(z$distribution(), "x + y")
expect_false(z$is_probabilistic())
#
y <- NormModVar$new("y", "GBP", mu = 0.0, sigma = 1.0)
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x + y))
expect_true(z$is_expression())
expect_identical(z$distribution(), "x + y")
expect_true(z$is_probabilistic())
})
test_that("ExprModVar obeys scoping rules", {
# operands in a function environment (test_that)
x <- 2L
y <- 3L
z <- ExprModVar$new("z", "Z", quo = rlang::quo(x + y))
expect_identical(z$distribution(), "x + y")
expect_intol(z$mean(), 5.0, 0.1)
# operands in different function environments
f <- function() {
y <- 4.0
z <- ExprModVar$new("z", "Z", quo = rlang::quo(x + y))
expect_intol(z$mean(), 6.0, 0.1)
}
f()
# ExprModVar can be passed as an object
x <- 20.0
y <- 30.0
z <- ExprModVar$new("z", "Z", quo = rlang::quo(x + y))
g <- function(mv) {
x <- 200.0
y <- 300.0
expect_intol(mv$mean(), 50.0, 1.0)
}
g(z)
})
test_that("stub quantile function checks inputs and has correct output", {
x <- 2.0
y <- 3.0
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x + y))
probs <- c(0.1, 0.2, 0.5)
expect_silent(z$quantile(probs))
probs <- c(0.1, NA_real_, 0.5)
expect_error(z$quantile(probs), class = "probs_not_defined")
probs <- c(0.1, "boo", 0.5)
expect_error(z$quantile(probs), class = "probs_not_numeric")
probs <- c(0.1, 0.4, 1.5)
expect_error(z$quantile(probs), class = "probs_out_of_range")
probs <- c(0.1, 0.2, 0.5)
expect_length(z$quantile(probs), 3L)
})
test_that("operands are identified correctly", {
# simple case
x <- 2.0
y <- NormModVar$new("y", "GBP", mu = 0.0, sigma = 1.0)
z <- ConstModVar$new("z", "GPB", 42.0)
e <- ExprModVar$new("e", "GBP", quo = rlang::quo(x * y + z))
mv <- e$operands()
expect_length(mv, 2L) # y and z
d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
return(v$description())
})
expect_setequal(d, c("y", "z"))
# nested case, with repeats
e1 <- ExprModVar$new("e1", "GBP", quo = rlang::quo(x * y + z))
e2 <- ExprModVar$new("e2", "GBP", quo = rlang::quo(z + 3.0))
e3 <- ExprModVar$new("e3", "GBP", quo = rlang::quo(e1 + e2))
mv <- e3$operands()
expect_length(mv, 4L) # y, z, e1, e2
d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
return(v$description())
})
expect_setequal(d, c("e1", "e2", "y", "z"))
# deeper nesting
e4 <- ExprModVar$new("e4", "", quo = rlang::quo(2.0 * e3))
mv <- e4$operands()
d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
return(v$description())
})
expect_setequal(d, c("e1", "e2", "e3", "y", "z"))
# nesting without recursion
mv <- e3$operands(recursive = FALSE)
d <- vapply(mv, FUN.VALUE = "x", FUN = function(v) {
return(v$description())
})
expect_setequal(d, c("e1", "e2"))
})
test_that("set and get function as expected", {
# check initialization
x <- 2L
y <- NormModVar$new("y", "GBP", mu = 0.0, sigma = 1.0)
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x * y))
expect_false(is.na(z$get()))
# check illegal input
expect_error(z$set(TRUE), class = "what_not_character")
expect_error(z$set("red"), class = "what_not_supported")
expect_error(z$set("value"), class = "invalid_val")
expect_error(z$set("value", val = TRUE), class = "invalid_val")
# check value setting
z$set("value", 10.0)
expect_identical(z$get(), 10.0)
# skip remaining tests on CRAN because they rely on sampling
skip_on_cran()
# check quantile, estimated from empirical distribution
z$set("q97.5")
v <- z$get()
expect_gt(v, 3.5)
# check mean is within 3.29 std errors (roughly 0.1%)
z$set("expected")
tol <- 3.29 * 2.0 / sqrt(1000.0)
expect_intol(z$get(), 0.0, tol)
# check that set() for operands affects get() for the expression
y$set("q97.5")
z$set("current")
expect_gt(z$get(), 3.5)
y$set("expected")
expect_intol(z$get(), 0.0, tol)
# check that a random sample from z is from a SN*2, despite setting y
n <- 1000L
S <- vector(mode = "numeric", length = n)
for (i in seq_len(n)) {
y$set("q97.5")
z$set("random")
S[[i]] <- z$get()
}
# 99.9% confidence limits; expected 0.1% test failure rate; skip for CRAN
ht <- ks.test(S, rnorm(n, mean = 0.0, sd = 2.0))
expect_gt(ht$p.value, 0.001)
})
test_that("modified expressions are created correctly", {
alpha <- 1.0
beta <- 9.0
p <- BetaModVar$new("P(success)", "P", alpha = alpha, beta = beta)
q <- ExprModVar$new("P(failure)", "P", rlang::quo(1.0 - p))
# check externally added method
expect_error(q$add_method(42.0), class = "method_not_character")
q.mean <- q$add_method("mean()")
expect_intol(
eval(rlang::quo_get_expr(q.mean), envir = rlang::quo_get_env(q.mean)),
0.9,
0.05
)
expect_intol(q$mean(), 0.9, 0.05)
# check that random sampling is supported
q$set("random")
rbeta <- q$get()
expect_gte(rbeta, 0.0)
expect_lte(rbeta, 1.0)
# check internally added methods; 99.9% confidence limits assuming CLT; expect
# 0.1% test failure rate; skip for CRAN
n <- 1000L
samp <- vapply(seq_len(n), FUN.VALUE = 1.0, FUN = function(i) {
q$set("random")
rv <- q$get()
return(rv)
})
expect_length(samp, n)
skip_on_cran()
ht <- ks.test(samp, rbeta(n, shape1 = beta, shape2 = alpha))
expect_gt(ht$p.value, 0.001)
})
test_that("illegal sample sizes for estimating parameters are rejected", {
x <- 3.0
y <- NormModVar$new("y", "GBP", mu = 0.0, sigma = 1.0)
z <- ExprModVar$new("z", "GBP", quo = rlang::quo(x * y))
expect_error(
ExprModVar$new("z", "GBP", quo = rlang::quo(x * y), "100"),
class = "nemp_not_integer"
)
expect_error(
ExprModVar$new("z", "GBP", quo = rlang::quo(x * y), 100L),
class = "nemp_too_small"
)
expect_error(
ExprModVar$new("z", "GBP", quo = rlang::quo(x * y), 999.5),
class = "nemp_not_integer"
)
expect_silent(
ExprModVar$new("z", "GBP", quo = rlang::quo(x * y))
)
expect_silent(
ExprModVar$new("z", "GBP", quo = rlang::quo(x * y), 10000L)
)
})
test_that("quantile estimation checks inputs and has correct output", {
p <- BetaModVar$new("P(success)", "P", alpha = 1.0, beta = 9.0)
q <- ExprModVar$new("P(failure)", "P", rlang::quo(1.0 - p))
probs <- c(0.1, 0.2, 0.5)
expect_silent(q$q_hat(probs))
probs <- c(0.1, NA_real_, 0.5)
expect_error(q$q_hat(probs), class = "probs_not_defined")
probs <- c(0.1, "boo", 0.5)
expect_error(q$q_hat(probs), class = "probs_not_numeric")
probs <- c(0.1, 0.4, 1.5)
expect_error(q$q_hat(probs), class = "probs_out_of_range")
probs <- c(0.1, 0.2, 0.5)
expect_length(q$q_hat(probs), 3L)
})
test_that("nested expressions are evaluated correctly", {
# skip test on cran because it involves sampling
skip_on_cran()
# standard normal and an expression with an identity operator
sn1 <- NormModVar$new("sn1", "", mu = 0.0, sigma = 1.0)
s1 <- ExprModVar$new("s1", "", rlang::quo(1.0 * sn1))
# tolerance is 3.29 * standard error (roughly 0.1%)
tol <- 3.29 * sqrt(2.0) / sqrt(1000L)
# check that all 3 products have a mean of 1 (chisq with 1 dof)
p1 <- ExprModVar$new("p1", "", rlang::quo(sn1 * sn1))
expect_intol(p1$mu_hat(), 1.0, tol)
p2 <- ExprModVar$new("p2", "", rlang::quo(s1 * s1))
expect_intol(p2$mu_hat(), 1.0, tol)
p3 <- ExprModVar$new("p3", "", rlang::quo(s1 * sn1))
expect_intol(p3$mu_hat(), 1.0, tol)
})
test_that("autocorrelation in nested expressions is preserved", {
# skip test on cran because it involves sampling
skip_on_cran()
# create expressions to wrap standard normals
sn1 <- NormModVar$new("sn1", "", mu = 0.0, sigma = 1.0)
s1 <- ExprModVar$new("s1", "", rlang::quo(1.0 * sn1))
sn2 <- NormModVar$new("sn2", "", mu = 0.0, sigma = 1.0)
s2 <- ExprModVar$new("s2", "", rlang::quo(1.0 * sn2))
x <- ExprModVar$new("x", "", rlang::quo(1.0 * s1))
y <- ExprModVar$new("y", "", rlang::quo(1.0 * s2))
# create nested correlated and nested uncorrelated expressions
zc <- ExprModVar$new("zc", "", rlang::quo(x * s1))
zu <- ExprModVar$new("zu", "", rlang::quo(y * s1))
# tolerance is 3.29 * standard error (roughly 0.1%)
tol <- 3.29 * sqrt(2.0) / sqrt(1000L)
# zc is a chi-squared with 1 dof
expect_intol(zc$mu_hat(), 1.0, tol)
# zu is a modified Bessel function with mean 0 and sd 1
expect_intol(zu$mu_hat(), 0.0, tol)
})
test_that("scalar expression is evaluated correctly", {
x <- ExprModVar$new("x", "", rlang::quo(1.0))
expect_false(x$is_probabilistic())
expect_length(x$operands(), 0L)
expect_identical(x$distribution(), "1")
expect_intol(x$mean(), 1.0, 0.001)
expect_true(is.na(x$mode()))
expect_true(is.na(x$SD()))
expect_identical(x$quantile(probs = c(0.025, 0.975)), c(NA_real_, NA_real_))
expect_intol(x$mu_hat(), 1.0, 0.01)
expect_intol(x$sigma_hat(), 0.0, 0.01)
expect_intol(x$q_hat(probs = 0.025), 1.0, 0.01)
expect_intol(x$q_hat(probs = 0.975), 1.0, 0.01)
})
test_that("expression chi square from SN is correct", {
# x ~ N(0,1), y = x^2 ~ Chisq(k=1)
k <- 1L
x <- NormModVar$new("x", "", mu = 0.0, sigma = 1.0)
y <- ExprModVar$new("y", "", rlang::quo(x ^ 2L))
# check that mode and SD are undefined
expect_true(is.na(y$mode())) # mode is undefined for ExprModVar
expect_true(is.na(y$SD())) # SD is undefined for ExprModVar
# skip sampling tests on cran
skip_on_cran()
# tolerance is 3.29 * standard error (roughly 0.1%)
tol <- 3.29 * sqrt(2L * k) / sqrt(1000L)
expect_equal(y$mean(), 0.0) # product of operand means is 0
expect_intol(y$mu_hat(), k, tol) # true mean is k=1
median <- k * (1L - 2L / (9L * k)) ^ 3L
expect_intol(y$q_hat(p = 0.5), median, tol)
# generate a distribution and check it
n <- 1000L
samp <- vapply(seq_len(n), FUN.VALUE = 1.0, FUN = function(i) {
y$set("random")
rv <- y$get()
return(rv)
})
ht <- ks.test(samp, rchisq(n, df = 1L))
expect_gt(ht$p.value, 0.001)
})
test_that("one Dirichlet matches a Beta and an expression", {
# skip on cran because tests involve sampling
skip_on_cran()
# p follows Beta(1,9) and q is 1-p
alpha <- 1.0
beta <- 9.0
p <- BetaModVar$new("P(success)", "P", alpha = alpha, beta = beta)
q <- ExprModVar$new("P(failure)", "P", rlang::quo(1.0 - p))
# p and q are both derived from Dir(1,9) distribution
D <- DirichletDistribution$new(alpha = c(1.0, 9.0))
p.d <- ModVar$new("P(success)", "P", D = D, k = 1L)
q.d <- ModVar$new("P(failure)", "P", D = D, k = 2L)
# tolerance is 3.29 standard errors (approx 0.1%)
sd <- sqrt((alpha * beta) / ((alpha + beta) ^ 2L * (alpha + beta + 1L)))
tol <- 3.29 * sd / sqrt(1000L)
# compare means
expect_identical(p$mean(), p.d$mean())
expect_intol(q$mean(), q.d$mean(), tol)
# compare quantiles for p
probs <- c(0.025, 0.975)
expect_setequal(unname(p$quantile(probs)), unname(p.d$quantile(probs)))
# quantiles defined for q.d but not q
expect_true(all(is.na(q$quantile(probs))))
expect_false(anyNA(q.d$quantile(probs)))
})
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.