Nothing
tests/testthat/test-aliases.R
# ======================================================== #
# rtrunc methods vs aliases #
# ======================================================== #
context("Matching output of rtrunc, ptrunc and qtrunc aliases")
test_that("rtrunc works the same from generic and alias", {
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 32, 22, .4, .6, family = "beta", faster = FALSE)
},
expected = {
set.seed(8)
rtruncbeta(1000, 32, 22, .4, .6)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 4, .2, 2, family = "binomial", faster = FALSE)
},
expected = {
set.seed(8)
rtruncbinom(1000, 4, .2, 2)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 45, 40, family = "chisq", faster = FALSE)
},
expected = {
set.seed(8)
rtruncchisq(1000, 45, 40)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, .2, .2, .7, family = "contbern", faster = FALSE)
},
expected = {
set.seed(8)
rtrunccontbern(1000, .2, .2, .7)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 0.584, 0.5, 1, family = "exp", faster = FALSE)
},
expected = {
set.seed(8)
rtruncexp(1000, 0.584, 0.5, 1)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(
1000, shape = 45, rate = 12, a = 1, b = 8, family = "gamma",
faster = FALSE
)
},
expected = {
set.seed(8)
rtruncgamma(1000, shape = 45, rate = 12, a = 1, b = 8)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(
1000, shape = 45, rate = 12, a = 0.2, b = 0.3, family = "invgamma",
faster = FALSE
)
},
expected = {
set.seed(8)
rtruncinvgamma(1000, shape = 45, rate = 12, a = 0.2, b = 0.3)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 38, 38, 0, 100, family = "invgauss", faster = FALSE)
},
expected = {
set.seed(8)
rtruncinvgauss(1000, 38, 38, 0, 100)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, -32, 2, family = "lognormal", faster = FALSE)
},
expected = {
set.seed(8)
rtrunclnorm(1000, -32, 2)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 152, .37, family = "nbinom", faster = FALSE)
},
expected = {
set.seed(8)
rtruncnbinom(1000, 152, .37)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 100, 200, 0, family = "normal", faster = FALSE)
},
expected = {
set.seed(8)
rtruncnorm(1000, 100, 200, 0)
},
)
expect_identical(
object = {
set.seed(8)
rtrunc(1000, 7521, 7500, family = "poisson", faster = FALSE)
},
expected = {
set.seed(8)
rtruncpois(1000, 7521, 7500)
},
)
})
test_that("ptrunc works the same from generic and alias", {
gen_args <- function(FUN, ...) {
pb <- sort(runif(3))
qt <- FUN(pb, ...)
list("a" = qt[1], "q" = qt[2], "b" = qt[3])
}
x <- gen_args(qbeta, shape1 = 1, shape2 = 2)
expect_identical(
ptrunc(x$q, 1, 2, x$a, x$b, family = "beta"),
ptruncbeta(x$q, 1, 2, x$a, x$b)
)
x <- gen_args(qbinom, size = 50, prob = 0.3)
expect_identical(
ptrunc(x$q, 50, .3, x$a, x$b, family = "binomial"),
ptruncbinom(x$q, 50, .3, x$a, x$b)
)
x <- gen_args(qchisq, df = 23)
expect_identical(
ptrunc(x$q, 23, x$a, x$b, family = "chisq"),
ptruncchisq(x$q, 23, x$a, x$b)
)
x <- gen_args(qcontbern, lambda = 0.5)
expect_identical(
ptrunc(x$q, 0.5, x$a, x$b, family = "contbern"),
ptrunccontbern(x$q, 0.5, x$a, x$b)
)
x <- gen_args(qexp, rate = 26)
expect_identical(
ptrunc(x$q, 26, x$a, x$b, family = "exp"),
ptruncexp(x$q, 26, x$a, x$b)
)
x <- gen_args(qgamma, shape = 4, rate = 5)
expect_identical(
ptrunc(x$q, 4, 5, a = x$a, b = x$b, family = "gamma"),
ptruncgamma(x$q, 4, 5, a = x$a, b = x$b)
)
x <- gen_args(qinvgamma, shape = 4, scale = 6)
expect_identical(
ptrunc(x$q, 4, 6, a = x$a, b = x$b, family = "invgamma"),
ptruncinvgamma(x$q, 4, 6, a = x$a, b = x$b)
)
x <- gen_args(qinvgauss, m = 1, s = 3)
expect_identical(
ptrunc(x$q, 1, 3, a = x$a, b = x$b, family = "invgauss"),
ptruncinvgauss(x$q, 1, 3, a = x$a, b = x$b)
)
x <- gen_args(qlnorm, meanlog = 7, sdlog = 2)
expect_identical(
ptrunc(x$q, 7, 2, a = x$a, b = x$b, family = "lognormal"),
ptrunclnorm(x$q, 7, 2, a = x$a, b = x$b)
)
x <- gen_args(qnbinom, size = 55, prob = .4)
expect_identical(
ptrunc(x$q, 55, .4, a = x$a, b = x$b, family = "nbinom"),
ptruncnbinom(x$q, 55, .4, a = x$a, b = x$b)
)
x <- gen_args(qnorm, mean = 1, sd = 3)
expect_identical(
ptrunc(x$q, mean = 1, sd = 3, a = x$a, b = x$b),
ptruncnorm(x$q, mean = 1, sd = 3, a = x$a, b = x$b)
)
x <- gen_args(qpois, lambda = 72)
expect_identical(
ptrunc(x$q, 72, a = x$a, b = x$b, family = "poisson"),
ptruncpois(x$q, 72, a = x$a, b = x$b)
)
})
test_that("qtrunc works the same from generic and alias", {
gen_args <- function(FUN, ...) {
pb <- sort(runif(3))
qt <- FUN(pb, ...)
list("a" = qt[1], "p" = pb[2], "b" = qt[3])
}
x <- gen_args(qbeta, shape1 = 1, shape2 = 2)
expect_identical(
qtrunc(x$p, 1, 2, x$a, x$b, family = "beta"),
qtruncbeta(x$p, 1, 2, x$a, x$b)
)
x <- gen_args(qbinom, size = 50, prob = 0.3)
expect_identical(
qtrunc(x$p, 50, .3, x$a, x$b, family = "binomial"),
qtruncbinom(x$p, 50, .3, x$a, x$b)
)
x <- gen_args(qchisq, df = 23)
expect_identical(
qtrunc(x$p, 23, x$a, x$b, family = "chisq"),
qtruncchisq(x$p, 23, x$a, x$b)
)
x <- gen_args(qcontbern, lambda = 0.5)
expect_identical(
qtrunc(x$p, 0.5, x$a, x$b, family = "contbern"),
qtrunccontbern(x$p, 0.5, x$a, x$b)
)
x <- gen_args(qexp, rate = 26)
expect_identical(
qtrunc(x$p, 26, x$a, x$b, family = "exp"),
qtruncexp(x$p, 26, x$a, x$b)
)
x <- gen_args(qgamma, shape = 4, rate = 5)
expect_identical(
qtrunc(x$p, 4, 5, a = x$a, b = x$b, family = "gamma"),
qtruncgamma(x$p, 4, 5, a = x$a, b = x$b)
)
x <- gen_args(qinvgamma, shape = 4, scale = 6)
expect_identical(
qtrunc(x$p, 4, 6, a = x$a, b = x$b, family = "invgamma"),
qtruncinvgamma(x$p, 4, 6, a = x$a, b = x$b)
)
x <- gen_args(qinvgauss, m = 1, s = 3)
expect_identical(
qtrunc(x$p, 1, 3, a = x$a, b = x$b, family = "invgauss"),
qtruncinvgauss(x$p, 1, 3, a = x$a, b = x$b)
)
x <- gen_args(qlnorm, meanlog = 7, sdlog = 2)
expect_identical(
qtrunc(x$p, 7, 2, a = x$a, b = x$b, family = "lognormal"),
qtrunclnorm(x$p, 7, 2, a = x$a, b = x$b)
)
x <- gen_args(qnbinom, size = 55, prob = .4)
expect_identical(
qtrunc(x$p, 55, .4, a = x$a, b = x$b, family = "nbinom"),
qtruncnbinom(x$p, 55, .4, a = x$a, b = x$b)
)
x <- gen_args(qnorm, mean = 1, sd = 3)
expect_identical(
qtrunc(x$p, mean = 1, sd = 3, a = x$a, b = x$b),
qtruncnorm(x$p, mean = 1, sd = 3, a = x$a, b = x$b)
)
x <- gen_args(qpois, lambda = 72)
expect_identical(
qtrunc(x$p, 72, a = x$a, b = x$b, family = "poisson"),
qtruncpois(x$p, 72, a = x$a, b = x$b)
)
})
# ======================================================== #
# rtrunc functions vs stats functions #
# ======================================================== #
context("Matching output of stats::r*")
test_that("Output of rtrunc matches stats::r*", {
expect_setequal(
object = {
set.seed(1)
rbeta(500, shape1 = 8, shape2 = 86)
},
expected = {
set.seed(1)
rtrunc(500, shape1 = 8, shape2 = 86, family = "beta")
}
)
expect_setequal(
object = {
set.seed(1)
rbinom(50, size = 10, prob = .3)
},
expected = {
set.seed(1)
rtrunc(50, size = 10, prob = .3, family = "binomial")
}
)
expect_setequal(
object = {
set.seed(1)
rchisq(50, df = 23)
},
expected = {
set.seed(1)
rtrunc(50, df = 23, family = "chisq")
}
)
expect_setequal(
object = {
set.seed(1)
rcontbern(50, lambda = 0.5)
},
expected = {
set.seed(1)
rtrunc(50, lambda = 0.5, family = "contbern")
}
)
expect_setequal(
object = {
set.seed(1)
rexp(50, rate = 26)
},
expected = {
set.seed(1)
rtrunc(50, rate = 26, family = "exp")
}
)
expect_setequal(
object = {
set.seed(1)
rgamma(50, shape = 4, rate = 5)
},
expected = {
set.seed(1)
rtrunc(50, shape = 4, rate = 5, family = "gamma")
}
)
expect_setequal(
object = {
set.seed(1)
rgamma(50, shape = 4, scale = 6)
},
expected = {
set.seed(1)
rtrunc(50, shape = 4, scale = 6, family = "gamma")
}
)
expect_setequal(
object = {
set.seed(1)
rinvgamma(50, shape = 6, scale = 9)
},
expected = {
set.seed(1)
rtrunc(50, shape = 6, scale = 9, family = "invgamma")
}
)
expect_setequal(
object = {
set.seed(1)
rinvgamma(50, shape = 52, scale = .21)
},
expected = {
set.seed(1)
rtrunc(50, shape = 52, scale = .21, family = "invgamma")
}
)
expect_setequal(
object = {
set.seed(1)
rinvgauss(500, m = 1, s = 3)
},
expected = {
set.seed(1)
rtrunc(500, m = 1, s = 3, family = "invgauss")
}
)
expect_setequal(
object = {
set.seed(1)
rlnorm(50, meanlog = 7, sdlog = 2)
},
expected = {
set.seed(1)
rtrunc(50, meanlog = 7, sdlog = 2, family = "lognormal")
}
)
expect_setequal(
object = {
set.seed(1)
rnbinom(500, size = 55, prob = .4)
},
expected = {
set.seed(1)
rtrunc(500, size = 55, prob = .4, family = "nbinom")
}
)
expect_setequal(
object = {
set.seed(1)
rnbinom(500, size = 55, mu = 4)
},
expected = {
set.seed(1)
rtrunc(500, size = 55, mu = 4, family = "nbinom")
}
)
expect_setequal(
object = {
set.seed(1)
rnorm(500, mean = 1, sd = 3)
},
expected = {
set.seed(1)
rtrunc(500, mean = 1, sd = 3)
}
)
expect_setequal(
object = {
set.seed(1)
rpois(500, lambda = 72)
},
expected = {
set.seed(1)
rtrunc(500, lambda = 72, family = "poisson")
}
)
})
Try the TruncExpFam package in your browser
Any scripts or data that you put into this service are public.
