Nothing
### actuar: Actuarial Functions and Heavy Tailed Distributions
###
### Tests for the simulation of compound models with 'rcompound' and
### 'rcomppois'.
###
### AUTHOR: Vincent Goulet <vincent.goulet@act.ulaval.ca>
## Load the package
library(actuar)
## Copy of tools::assertError.
assertError <- tools::assertError
###
### Tests for rcompound
###
## Test the function itself with various types of arguments.
n <- 20
fmodel <- expression(rnbinom(2, 0.8))
smodel <- expression(rgamma(2, 1))
set.seed(123)
x <- numeric(n)
N <- rnbinom(n, 2, 0.8)
y <- rgamma(sum(N), 2, 1)
x[which(N != 0)] <- tapply(y, rep(seq_len(n), N), sum)
stopifnot(exprs = {
identical(x, {
set.seed(123)
rcompound(n, rnbinom(2, 0.8), rgamma(2, 1))
})
identical(x, {
set.seed(123)
rcompound(n, rnbinom(2, 0.8), expression(rgamma(2, 1)))
})
identical(x, {
set.seed(123)
rcompound(n, expression(rnbinom(2, 0.8)), rgamma(2, 1))
})
identical(x, {
set.seed(123)
rcompound(n, fmodel, smodel)
})
})
## Test the calling environment, that is that arguments are correctly
## identified when 'rcompound' is called inside another function.
n <- 20
lambda <- 2
smodel <- expression(rgamma(2, 1))
set.seed(123)
x <- rcompound(n, rpois(2), rgamma(2, 1))
f <- function(n, p, model.sev)
{
## safe way to pass down the arguments
model.freq <- substitute(rpois(p), list(p = p))
model.sev <- substitute(model.sev)
if (is.name(model.sev))
model.sev <- eval.parent(model.sev)
rcompound(n, model.freq, model.sev)
}
g1 <- function(n, p, s, r)
rcompound(n, rpois(p), rgamma(s, r))
g2 <- function(n, p, s, r)
rcompound(n, expression(rpois(p)), expression(rgamma(s, r)))
h <- function(n, p, model.sev)
{
## safe way to pass down the arguments
model.sev <- substitute(model.sev)
if (is.name(model.sev))
model.sev <- eval.parent(model.sev)
f(n, p, model.sev)
}
stopifnot(exprs = {
identical(x, {
set.seed(123)
f(n, 2, rgamma(2, 1))
})
identical(x, {
set.seed(123)
f(n, lambda, expression(rgamma(2, 1)))
})
identical(x, {
set.seed(123)
f(n, lambda, smodel)
})
identical(x, {
set.seed(123)
g1(n, lambda, 2, 1)
})
identical(x, {
set.seed(123)
g2(n, lambda, 2, 1)
})
identical(x, {
set.seed(123)
h(n, 2, rgamma(2, 1))
})
identical(x, {
set.seed(123)
h(n, lambda, smodel)
})
})
## Test invalid arguments.
assertError(rcompound(-1, rpois(2), rgamma(2, 1)))
###
### Tests for rcomppois
###
## Test the function itself with various types of arguments.
n <- 20
lambda <- 2
smodel <- expression(rgamma(2, 1))
set.seed(123)
x <- numeric(n)
N <- rpois(n, 2)
y <- rgamma(sum(N), 2, 1)
x[which(N != 0)] <- tapply(y, rep(seq_len(n), N), sum)
stopifnot(exprs = {
identical(x, {
set.seed(123)
rcomppois(n, 2, rgamma(2, 1))
})
identical(x, {
set.seed(123)
rcomppois(n, lambda, expression(rgamma(2, 1)))
})
identical(x, {
set.seed(123)
rcomppois(n, lambda, smodel)
})
})
## Test the calling environment, that is that arguments are correctly
## identified when 'rcomppois' is called inside another function.
n <- 20
lambda <- 2
smodel <- expression(rgamma(2, 1))
set.seed(123)
x <- rcomppois(n, lambda, smodel)
f <- function(n, p, model)
{
## safe way to pass down all sorts of 'model' objects
model <- substitute(model)
if (is.name(model))
model <- eval.parent(model)
rcomppois(n, p, model)
}
g1 <- function(n, p, s, r)
rcomppois(n, p, rgamma(s, r))
g2 <- function(n, p, s, r)
rcomppois(n, p, expression(rgamma(s, r)))
h <- function(n, p, model)
{
## safe way to pass down all sorts of 'model' objects
model <- substitute(model)
if (is.name(model))
model <- eval.parent(model)
f(n, p, model)
}
stopifnot(exprs = {
identical(x, {
set.seed(123)
f(n, 2, rgamma(2, 1))
})
identical(x, {
set.seed(123)
f(n, lambda, expression(rgamma(2, 1)))
})
identical(x, {
set.seed(123)
f(n, lambda, smodel)
})
identical(x, {
set.seed(123)
g1(n, 2, 2, 1)
})
identical(x, {
set.seed(123)
g2(n, 2, 2, 1)
})
identical(x, {
set.seed(123)
h(n, 2, rgamma(2, 1))
})
identical(x, {
set.seed(123)
h(n, lambda, smodel)
})
})
## Test invalid arguments.
assertError(rcomppois(-1, lambda, smodel))
assertError(rcomppois(n, -1, smodel))
assertError(rcomppois(n, c(3, -1), smodel))
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.