tests/testthat/test-dist_trunc.R

In reservr: Fit Distributions and Neural Networks to Censored and Truncated Data

test_that("test dist_trunc", {
  set.seed(1337L)
  dist <- dist_trunc(dist_exponential(), min = 1.0, max = 3.0)
  params <- list(dist = list(rate = 0.5))
  x <- dist$sample(100L, with_params = params)

  # Force rejection sampling algorithm
  caps <- dist$default_params$dist$.__enclos_env__$private$.caps
  dist$default_params$dist$.__enclos_env__$private$.caps <- "sample"
  x <- c(x, dist$sample(100L, with_params = params))
  dist$default_params$dist$.__enclos_env__$private$.caps <- caps

  expect_silent(fit(dist, x))
  expect_identical(dist$get_type(), "continuous")
  expect_density(dist, function(x, log = FALSE, dist) {
    d <- dexp(x, rate = dist$rate) /
      diff(pexp(c(1.0, 3.0), rate = dist$rate))
    if (log) d <- log(d)
    d
  }, params, x)
  expect_probability(dist, function(q, log.p = FALSE, lower.tail = TRUE, dist) {
    p <- (pexp(q, rate = dist$rate) - pexp(1.0, rate = dist$rate)) /
      diff(pexp(c(1.0, 3.0), rate = dist$rate))
    if (!lower.tail) p <- 1 - p
    pmax(0, pmin(1, p))
    if (log.p) p <- log(p)
    p
  }, params, x)
  expect_quantile(dist, function(p, log.p = FALSE, lower.tail = TRUE, dist) {
    if (log.p) p <- exp(p)
    if (!lower.tail) p <- 1 - p
    pt <- pexp(1.0, rate = dist$rate) +
      p * diff(pexp(c(1.0, 3.0), rate = dist$rate))
    qexp(pt, rate = dist$rate)
  }, params)
  expect_identical(dist$is_in_support(x), rep_len(TRUE, length(x)))
  # TODO implement gradients
  # expect_diff_density(dist, x, params)
  # expect_diff_density(dist, x, list(dist = list(rate = 4.0)))
  # expect_diff_probability(dist, x, params)
  # expect_diff_probability(dist, x, list(dist = list(rate = 4.0)))
  expect_tf_logdensity(dist, params, x)
  expect_tf_logprobability(dist, params, x, x + 1.0)

  expect_iprobability(dist, params, x, x + 1.0)
  expect_iprobability(dist, params, 0, x)
  expect_iprobability(dist, params, x, Inf)

  expect_tf_fit(dist, params, interval(1.0, 3.0))
})