Nothing
#context("GEV: rpost_rcpp vs rpost")
# We check that the values simulated using rpost() and rpost_rcpp() are
# (close enough to) identical when they are called using the same data,
# the same prior and starting from the same random number seed.
# Set a tolerance for the comparison of the simulated values
my_tol <- 1e-5
gev_test <- function(seed = 47, prior, n = 5, rotate = TRUE, trans = "none",
use_phi_map = FALSE, data = portpirie, nrep = 2, ...){
if (prior == "user") {
prior_rfn <- set_prior(prior = "norm", model = "gev", ...)
ptr_gev_norm <- create_prior_xptr("gev_norm")
prior_cfn <- set_prior(prior = ptr_gev_norm, model = "gev",
mean = c(0,0,0),
icov = solve(diag(c(10000, 10000, 100))))
} else {
prior_rfn <- set_prior(prior = prior, model = "gev", ...)
prior_cfn <- set_prior(prior = prior, model = "gev", ...)
}
set.seed(seed)
res1 <- rpost(n = n, model = "gev", prior = prior_rfn,
data = data, rotate = rotate, trans = trans,
use_phi_map = use_phi_map, nrep = nrep)
set.seed(seed)
res2 <- rpost_rcpp(n = n, model = "gev", prior = prior_cfn,
data = data, rotate = rotate, trans = trans,
use_phi_map = use_phi_map, nrep = nrep)
return(list(sim1 = as.numeric(res1$sim_vals),
sim2 = as.numeric(res2$sim_vals),
data_rep1 = as.numeric(res1$data_rep),
data_rep2 = as.numeric(res2$data_rep)))
}
test_function <- function(x, test_string) {
testthat::test_that(test_string, {
testthat::expect_equal(x$sim1, x$sim2, tolerance = my_tol)
testthat::expect_equal(x$data_rep1, x$data_rep2, tolerance = my_tol)
})
}
# Slow, belt-and-braces
#rotate_vals <- c(FALSE, TRUE)
#trans_vals <- c("none", "BC")
#use_phi_map_vals <- c(FALSE, TRUE)
# Faster, sufficient
rotate_vals <- TRUE
trans_vals <- "BC"
use_phi_map_vals <- TRUE
for (rotate in rotate_vals) {
for (trans in trans_vals) {
for (use_phi_map in use_phi_map_vals) {
test_string <- paste("rotate =", rotate, "trans =", trans,
"use_phi_map =", use_phi_map)
x <- gev_test(prior = "flat", min_xi = -1,
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "norm", mean = c(0,0,0),
cov = diag(c(10000, 10000, 100)),
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "loglognorm", mean = c(0,0,0),
cov = diag(c(10000, 10000, 100)),
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "mdi",
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "beta",
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "user", mean = c(0,0,0),
cov = diag(c(10000, 10000, 100)),
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
x <- gev_test(prior = "prob", quant = c(85, 88, 95),
alpha = c(4, 2.5, 2.25, 0.25), data = oxford,
rotate = rotate, trans = trans, use_phi_map = use_phi_map)
test_function(x, test_string)
}
}
}
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.