tests/testthat/test-pure-r-benchmarks.R

In twolodzko/extraDistr: Additional Univariate and Multivariate Distributions

test_that("Compare PDF's/PMF's to pure-R benchmarks", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  expect_warning(expect_equal(dbbinom(x, 100, 1, 10), dbbinomR(x, 100, 1, 10)))
  expect_warning(expect_equal(dbbinom(x, 100, 1000, 0.001), dbbinomR(x, 100, 1000, 0.001)))
  expect_warning(expect_equal(dbnbinom(x[1:(n-2)], 100, 1, 10),
                              dbnbinomR(x[1:(n-2)], 100, 1, 10))) # numerical precission in R version
  expect_equal(dbetapr(x, 1, 1, 1), dbetaprR(x, 1, 1, 1))
  expect_equal(dbetapr(x, 0.0001, 0.0001, 0.0001), dbetaprR(x, 0.0001, 0.0001, 0.0001))
  expect_equal(dbetapr(x, 100, 100, 100), dbetaprR(x, 100, 100, 100))
  expect_equal(dfatigue(x, 1, 1, 0), dfatigueR(x, 1, 1, 0))
  expect_equal(dfatigue(x, 0.0001, 0.0001, -100), dfatigueR(x, 0.0001, 0.0001, -100))
  expect_warning(expect_equal(ddlaplace(x, 0, 0.5), ddlaplaceR(x, 0, 0.5)))
  expect_warning(expect_equal(ddlaplace(x, 0, 0.999), ddlaplaceR(x, 0, 0.999)))
  expect_warning(expect_equal(ddlaplace(x, 0, 0.0001), ddlaplaceR(x, 0, 0.0001)))
  expect_warning(expect_equal(ddweibull(x, 0.5, 1), ddweibullR(x, 0.5, 1)))
  expect_warning(expect_equal(ddweibull(x, 0.0001, 0.0001), ddweibullR(x, 0.0001, 0.0001)))
  expect_warning(expect_equal(ddweibull(x, 0.9999, 1000), ddweibullR(x, 0.9999, 1000)))
  expect_equal(dfrechet(x, 1, 1, 1), dfrechetR(x, 1, 1, 1))
  expect_warning(expect_equal(dgpois(x[1:(n-1)], 1, 1),
                              dgpoisR(x[1:(n-1)], 1, 1))) # numerical precission in R version
  expect_equal(dgev(x, 1, 1, 1), dgevR(x, 1, 1, 1))
  expect_equal(dgev(x[2:n], 1, 1, 0), dgevR(x[2:n], 1, 1, 0)) # numerical precission in R version
  expect_equal(dgev(x, 1, 1, -1), dgevR(x, 1, 1, -1))
  expect_equal(dgompertz(x, 1, 1), dgompertzR(x, 1, 1))
  expect_equal(dgpd(x, 1, 1, 1), dgpdR(x, 1, 1, 1))
  expect_equal(dgpd(x, 1, 1, 0), dgpdR(x, 1, 1, 0))
  expect_equal(dgpd(x, 1, 1, -1), dgpdR(x, 1, 1, -1))
  expect_equal(dgumbel(x, 1, 1), dgumbelR(x, 1, 1))
  expect_equal(dinvgamma(x, 1, 1), dinvgammaR(x, 1, 1))
  expect_equal(dinvgamma(x, 1.2, 0.9), dinvgammaR(x, 1.2, 0.9))
  expect_equal(dlaplace(x, -1, 5), dlaplaceR(x, -1, 5))
  expect_equal(dlaplace(x, 9999, 0.000001), dlaplaceR(x, 9999, 0.000001))
  expect_warning(expect_equal(dlgser(x, 0.5), dlgserR(x, 0.5)))
  expect_warning(expect_equal(dlgser(x, 0.00001), dlgserR(x, 0.00001)))
  expect_warning(expect_equal(dlgser(x, 0.9999), dlgserR(x, 0.9999)))
  expect_equal(dlomax(x, 1, 0.5), dlomaxR(x, 1, 0.5))
  expect_equal(dpareto(x, 1, 1), dparetoR(x, 1, 1))
  expect_equal(dpower(x, 1, 1), dpowerR(x, 1, 1))
  expect_equal(drayleigh(x, 1), drayleighR(x, 1))
  expect_equal(dsgomp(x, 0.5, 1), dsgompR(x, 0.5, 1))
  
})


test_that("Compare dinvgamma to actuar implementation", {
  
  skip_on_cran()
  skip_if_not_installed("actuar")
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  
  expect_equal(dinvgamma(x, 1.2, 0.9), actuar::dinvgamma(x, 1.2, scale=0.9))
  expect_equal(pinvgamma(x, 1.2, 0.9), actuar::pinvgamma(x, 1.2, scale=0.9))
  
})


test_that("Compare dhuber to hoa implementation", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  skip_on_cran()
  skip_if_not_installed("hoa")

  expect_equal(dhuber(x), hoa::dHuber(x))
  expect_equal(phuber(x), hoa::pHuber(x))
  
})


test_that("Compare triangular to triangle implementation", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  skip_on_cran()
  skip_if_not_installed("triangle")
  
  expect_equal(dtriang(x, -1, 1), triangle::dtriangle(x, -1, 1))
  expect_equal(dtriang(x, 0, 1, 0.8), triangle::dtriangle(x, 0, 1, 0.8))
  
  expect_equal(ptriang(x, -1, 1), triangle::ptriangle(x, -1, 1))
  expect_equal(ptriang(x, 0, 1, 0.8), triangle::ptriangle(x, 0, 1, 0.8))
  
})


test_that("Compare GEV and GPD to evd implementation", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  skip_on_cran()
  skip_if_not_installed("evd")

  expect_equal(dgev(x, 0, 1, 0), evd::dgev(x, 0, 1, 0))
  expect_equal(dgev(x, 0, 1, 1), evd::dgev(x, 0, 1, 1))
  expect_equal(dgev(x, 0, 1, -1), evd::dgev(x, 0, 1, -1))
  
  expect_equal(pgev(x, 0, 1, 0), evd::pgev(x, 0, 1, 0))
  expect_equal(pgev(x, 0, 1, 1), evd::pgev(x, 0, 1, 1))
  expect_equal(pgev(x, 0, 1, -1), evd::pgev(x, 0, 1, -1))
  
  expect_equal(dgpd(x, 0, 1, 0), evd::dgpd(x, 0, 1, 0))
  expect_equal(dgpd(x, 0, 1, 1), evd::dgpd(x, 0, 1, 1))
  expect_equal(dgpd(x, 0, 1, -1), evd::dgpd(x, 0, 1, -1))
  
  expect_equal(pgpd(x, 0, 1, 0), evd::pgpd(x, 0, 1, 0))
  expect_equal(pgpd(x, 0, 1, 1), evd::pgpd(x, 0, 1, 1))
  expect_equal(pgpd(x, 0, 1, -1), evd::pgpd(x, 0, 1, -1))
  
})


test_that("Compare to distributions from VGAM package", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  skip_on_cran()
  skip_if_not_installed("VGAM")
  
  expect_warning(expect_equal(dzib(x, 45, 0.7, 0.2), VGAM::dzibinom(x, 45, 0.7, 0.2)))
  expect_warning(expect_equal(dzib(x, 45, 0.7, 0.0001), VGAM::dzibinom(x, 45, 0.7, 0.0001)))
  expect_warning(expect_equal(dzib(x, 45, 0.7, 0.9999), VGAM::dzibinom(x, 45, 0.7, 0.9999)))
  expect_equal(pzib(x, 45, 0.7, 0.2), VGAM::pzibinom(x, 45, 0.7, 0.2))
  expect_equal(pzib(x, 45, 0.7, 0.0001), VGAM::pzibinom(x, 45, 0.7, 0.0001))
  expect_equal(pzib(x, 45, 0.7, 0.9999), VGAM::pzibinom(x, 45, 0.7, 0.9999))
  
  expect_warning(expect_equal(dzinb(x, 45, 0.7, 0.2), VGAM::dzinegbin(x, 45, 0.7, NULL, 0.2)))
  expect_warning(expect_equal(dzinb(x, 45, 0.7, 0.0001), VGAM::dzinegbin(x, 45, 0.7, NULL, 0.0001)))
  expect_warning(expect_equal(dzinb(x, 45, 0.7, 0.9999), VGAM::dzinegbin(x, 45, 0.7, NULL, 0.9999)))
  expect_equal(pzinb(x, 45, 0.7, 0.2), VGAM::pzinegbin(x, 45, 0.7, NULL, 0.2))
  expect_equal(pzinb(x, 45, 0.7, 0.0001), VGAM::pzinegbin(x, 45, 0.7, NULL, 0.0001))
  expect_equal(pzinb(x, 45, 0.7, 0.9999), VGAM::pzinegbin(x, 45, 0.7, NULL, 0.9999))
  
  expect_warning(expect_equal(dzip(x, 7, 0.2), VGAM::dzipois(x, 7, 0.2)))
  expect_warning(expect_equal(dzip(x, 7, 0.0001), VGAM::dzipois(x, 7, 0.0001)))
  expect_warning(expect_equal(dzip(x, 7, 0.9999), VGAM::dzipois(x, 7, 0.9999)))
  expect_equal(pzip(x, 7, 0.2), VGAM::pzipois(x, 7, 0.2))
  expect_equal(pzip(x, 7, 0.0001), VGAM::pzipois(x, 7, 0.0001))
  expect_equal(pzip(x, 7, 0.9999), VGAM::pzipois(x, 7, 0.9999))
  
  expect_equal(dlaplace(x), VGAM::dlaplace(x))
  expect_equal(plaplace(x), VGAM::plaplace(x))
  
  expect_equal(dpareto(x, 1, 1), VGAM::dpareto(x, 1, 1))
  expect_equal(ppareto(x, 1, 1), suppressWarnings(VGAM::ppareto(x, 1, 1)))
  
  expect_warning(expect_equal(dbbinom(x, 100, 2, 7), VGAM::dbetabinom.ab(x, 100, 2, 7)))
  expect_equal(pbbinom(x, 100, 2, 7), VGAM::pbetabinom.ab(x, 100, 2, 7))
  
  expect_equal(dfrechet(x, 1, 0, 1), VGAM::dfrechet(x, 0, 1, 1))
  expect_equal(pfrechet(x, 1, 0, 1), VGAM::pfrechet(x, 0, 1, 1))
  
  expect_equal(dgumbel(x, 0, 1), VGAM::dgumbel(x, 0, 1))
  expect_equal(pgumbel(x, 0, 1), VGAM::pgumbel(x, 0, 1))
  
  expect_equal(dgompertz(x, 1, 1), VGAM::dgompertz(x, 1, 1))
  expect_equal(pgompertz(x, 1, 1), VGAM::pgompertz(x, 1, 1))  
  
  expect_equal(dkumar(x, 3, 7), VGAM::dkumar(x, 3, 7))
  expect_equal(pkumar(x, 3, 7), suppressWarnings(VGAM::pkumar(x, 3, 7)))
  
  expect_equal(dslash(x), VGAM::dslash(x))
  # expect_equal(pslash(x), VGAM::pslash(x))
  
  expect_equal(dhuber(x), VGAM::dhuber(x, 1.345))
  expect_equal(phuber(x), VGAM::phuber(x, 1.345))
  
  expect_warning(expect_equal(dlgser(x, 0.5), VGAM::dlog(x, 0.5)))
  expect_warning(expect_equal(dlgser(x, 0.0001), VGAM::dlog(x, 0.0001)))
  expect_warning(expect_equal(dlgser(x, 0.9999), VGAM::dlog(x, 0.9999)))
  
  expect_equal(drayleigh(x), VGAM::drayleigh(x))
  expect_equal(prayleigh(x), VGAM::prayleigh(x))
  
  expect_warning(expect_equal(
    extraDistr::dskellam(x, 7, 8),
    VGAM::dskellam(x, 7, 8)
  ))

})


test_that("Check against the parameter values tested in VGAM", {
  
  x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
         0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  n <- length(x)
  
  skip_on_cran()
  skip_if_not_installed("VGAM")

  expect_warning(expect_equal(dbbinom(x, 10, 0.8, 1.2),
                              VGAM::dbetabinom.ab(x, 10, 0.8, 1.2)))
  
  expect_equal(dpareto(x, 1.9, 2.3), dparetoR(x, 1.9, 2.3))
  expect_equal(dpareto(x, 2.3, 1.9), VGAM::dpareto(x, 1.9, 2.3)) # reverse order of params!
  
  expect_equal(dlst(x, 3, -0.9, 2), dt((x+0.9)/2, df = 3)/2)
  
  expect_equal(dlaplace(x, -0.9, 2), VGAM::dlaplace(x, -0.9, 2))
  
  expect_warning(expect_equal(dbern(x, 0.3), dbinom(x, 1, 0.3)))

})


test_that("Compare with LaplacesDemon package implementations", {
  
  skip_on_cran()
  skip_if_not_installed("LaplacesDemon")
  
  alpha <- runif(5, 0, 3)
  x <- rdirichlet(5000, alpha)
  
  expect_equal(ddirichlet(x, alpha),
               LaplacesDemon::ddirichlet(x, alpha))
  
  alpha <- c(0.0001, 0.0001, 0.0001, 0.0001, 0.0001)
  
  expect_equal(ddirichlet(x, alpha),
               LaplacesDemon::ddirichlet(x, alpha))
  
  alpha <- c(1000, 1000, 1000, 1000, 1000)
  
  expect_equal(ddirichlet(x, alpha),
               LaplacesDemon::ddirichlet(x, alpha))
  
  alpha <- c(1e-4, 10000, 100, 1e-5, 1000)
  
  expect_equal(ddirichlet(x, alpha),
               LaplacesDemon::ddirichlet(x, alpha))
  
  # x <- c(-1e5, -100, -10, -5.5, -5, -1.01, -1, -0.5, 0.001, 0,
  #        0.001, 0.5, 1, 1.01, 5, 5.5, 10, 100, 1e5)
  # 
  # expect_equal(dbern(x, 0.32), LaplacesDemon::dbern(x, 0.32))
  # expect_equal(dgpd(x, 0.2, 3.4, 1.4), LaplacesDemon::dgpd(x, 0.2, 3.4, 1.4))
  # expect_equal(dhcauchy(x, 2.6), LaplacesDemon::dhalfcauchy(x, 2.6))
  # expect_equal(dhnorm(x, 8.3), LaplacesDemon::dhalfnorm(x, 8.3))
  # expect_equal(dht(x, sigma=3.4, nu=7), LaplacesDemon::dhalft(x, scale=3.4, nu=7))
  # expect_equal(dinvchisq(x, 2.3, 5), LaplacesDemon::dinvchisq(x, 2.3, 5))
  # expect_equal(dinvgamma(x, 7.6, 3), LaplacesDemon::dinvgamma(x, 7.6, 3))
  # expect_equal(dwald(x, -2, 6), LaplacesDemon::dinvgaussian(x, -2, 6))
  # expect_equal(dpareto(x, 5, 6), LaplacesDemon::dpareto(x, 5, 6))
  # 
  # expect_equal(dcat(), LaplacesDemon::dcat())
  
})


test_that("Compare dmnom to dmultinom from base R", {

  n <- 100
  p <- runif(5)
  p <- p/sum(p)
  
  x <- rmnom(5000, n, p)
  
  expect_equal(dmnom(x, n, p), apply(x, 1, dmultinom, n, p))
  
  p <- c(1e-4, 10000, 100, 1e-5, 1000)
  p <- p/sum(p)
  
  expect_equal(dmnom(x, n, p), apply(x, 1, dmultinom, n, p))
  
})


test_that("Bivariate Poisson distribution agrees with code by Karlis and Ntzoufras", {
  
  x <- rbvpois(1000, 7, 8, 5)

  expect_equal(
    dbvpois(x[,1], x[,2], 7, 8, 5),
    pbivpois(x[,1], x[,2], 7, 8, 5)
  )
  
})


test_that("Skellam distribution agrees with the implementation in skellam package", {
  
  skip_on_cran()
  skip_if_not_installed("skellam")
  
  x <- extraDistr::rskellam(5000, 7, 8)
  
  expect_equal(
    extraDistr::dskellam(x, 7, 8),
    skellam::dskellam(x, 7, 8)
  )
  
})