Nothing
#' Test for rpkb
#'
#'
#'
#' @srrstats {G5.1, G5.5} data sets are generated using simple functions with
#' fixed seed
#' @srrstats {G5.2,G5.2a,G5.2b} all the error and warning messages are tested
#' @srrstats {PD4.0} the numeric output are tested
#' @srrstats {PD4.2} The function is tested for all the methods (distributions)
#' available
#' @srrstats {PD4.3} different values of the \code{uniroot} function are tested
#' @srrstats {PD4.4} The function uniroot satisfies this standard.
#' @srrstats {PD4.1} Tests that generated points are in expected range
#'
#'
#' @noRd
library(testthat)
test_that("Random Generation from PKBD works", {
# Check the errors
set.seed(123)
expect_error(rpkb(10, mu = c(1,0,0), rho = 2),
'Input argument rho must be within [0,1)',fixed=TRUE)
expect_error(rpkb(10, mu = c(0,0,0), rho = 0.8),
'Input argument mu cannot be a vector of zeros',fixed=TRUE)
expect_error(rpkb(10, mu = 2, rho = 0.8),
'mu must have length >= 2',fixed=TRUE)
expect_error(rpkb(-10, mu = c(1,0,0), rho = 0.8),
'n must be a positive integer',fixed=TRUE)
expect_error(rpkb(10, mu = c(1,0,0), rho = 0.8, method = "invalid"),
'Unknown method',fixed=TRUE)
#------------------------------------------------------
## Generating data point on the Sphere
## "rejvmf"
size <- 100
rho <- 0.8
mu <- c(1,0,0)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejvmf")
expect_equal(dim(pkbd_dat$x),c(size,length(mu)))
expect_true(is.matrix(pkbd_dat$x))
expect_equal(rowSums(pkbd_dat$x^2), rep(1,size))
## "rejacg"
size <- 100
rho <- 0.8
mu <- c(1,0,0)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejacg")
expect_equal(dim(pkbd_dat$x),c(size,length(mu)))
expect_true(is.matrix(pkbd_dat$x))
expect_equal(rowSums(pkbd_dat$x^2), rep(1,size))
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejacg", max.iter=20)
expect_lt(pkbd_dat$beta$iter, 20)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejacg", tol.eps=1e-7)
expect_lt(pkbd_dat$beta$estim.prec, 1e-7)
## "rejpsaw"
size <- 100
rho <- 0.8
mu <- c(1,0,0)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejpsaw")
expect_equal(dim(pkbd_dat$x),c(size,length(mu)))
expect_true(is.matrix(pkbd_dat$x))
expect_equal(rowSums(pkbd_dat$x^2), rep(1,size))
# dimension = 2
mu <- c(1,0)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejpsaw")
expect_equal(dim(pkbd_dat$x),c(size,length(mu)))
expect_true(is.matrix(pkbd_dat$x))
expect_equal(rowSums(pkbd_dat$x^2), rep(1,size))
# dimension > 3
mu <- c(1,0,0,0)
pkbd_dat <- rpkb(size, mu = mu, rho = rho, method = "rejpsaw")
expect_equal(dim(pkbd_dat$x),c(size,length(mu)))
expect_true(is.matrix(pkbd_dat$x))
expect_equal(rowSums(pkbd_dat$x^2), rep(1,size))
#------------------------------------------------------
## Test numerical values
rho <- 0.9
mu <- rnorm(3)
mu <- mu/sqrt(sum(mu^2))
size <- 100
x <- rpkb(size, mu = mu, rho = rho, method = "rejpsaw")
# Test if the mean of generated points is close to the true mean
expect_lt(max(abs(colMeans(x$x)-mu)),1e-1)
x <- rpkb(size, mu = mu, rho = 0.99, method = "rejpsaw")
# Test if the mean of generated points is close to the true mean
# higher rho, less variability
expect_lt(max(abs(colMeans(x$x)-mu)),1e-2)
})
test_that("Random Generation from PKBD compared to wrapped Cauchy", {
require(circular)
# Parameters
n <- 10000
location <- circular::circular(pi)
rho <- 0.6
set.seed(1234)
# Generate data from wrapped cauchy
wc <- circular::rwrappedcauchy(n, mu = location, rho = rho)
# Generate data from pkbd
pkbd <- rpkb(n, mu = c(-1, 0), rho = rho)$x
# Convert Cartesian coordinates to angles for comparison
pkbd_angles <- circular::coord2rad(pkbd,
control.circular = list(modulo="asis"))
# Compute the sample circular quantiles
vect_quantiles <- c(0.05,seq(0.1,0.9,0.05), 0.95)
wc_q <- circular::quantile.circular(wc, vect_quantiles)
pkbd_q <- circular::quantile.circular(pkbd_angles, vect_quantiles)
# Test that the computed quantiles are close
tol <- 0.01
expect_equal(wc_q, pkbd_q, tolerance = tol)
})
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.