Skip to content

Commit

Permalink
Merge branch 'issue-54' into develop
Browse files Browse the repository at this point in the history 
* issue-54:
  Updated NEWS.md (#54)
  Increment version number to 1.1.1.9013
  Reduced test length (#54)
  Fixed unit tests for binomial (#54)
  Implemented `ptrunc.nbinom()` (#54)
  Implemented `ptrunc.lognormal()` (#54)
  Added more tests #54
  • Loading branch information
@wleoncio
wleoncio committed Apr 19, 2024
2 parents 5bb4d85 + 5843bf7 commit 6e39622
Show file tree
Hide file tree
Showing 7 changed files with 364 additions and 47 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: TruncExpFam
Title: Truncated Exponential Family
Version: 1.1.1.9012
Version: 1.1.1.9013
Date: 2024-02-26
Authors@R:
c(
Expand Down
2 changes: 1 addition & 1 deletion NEWS.md
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
# TruncExpFam (development version)

* Implemented `ptrunc()` for some distributions (issue #54)
* Implemented `ptrunc()` for all distributions (issue #54)
* Refactoring (issue #104)
* Fixed bugs related to using the Negative Binomial with `mu` instead of `prob` (issue #107)
* Fixed domain validation on Negative Binomial and Inverse Gamma
Expand Down
24 changes: 24 additions & 0 deletions R/ptrunc.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,30 @@ ptrunc.invgauss <- function(q, m, s, a = 0, b = Inf, ...) {
return(truncated_p(p_q, p_a, p_b, lower.tail = TRUE, log.p = FALSE))
}

ptrunc.lognormal <- function(
q, meanlog = 0, sdlog = 1, a = 0, b = Inf, ..., lower.tail, log.p
) {
validate_q_a_b(q, a, b)
p_q <- plnorm(q, meanlog, sdlog, lower.tail = TRUE, log.p)
p_a <- plnorm(a, meanlog, sdlog, lower.tail = TRUE, log.p)
p_b <- plnorm(b, meanlog, sdlog, lower.tail = TRUE, log.p)
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

ptrunc.nbinom <- function(
q, size, prob, mu, a = 0, b = Inf, ..., lower.tail, log.p
) {
if (missing(prob)) {
prob <- size / (size + mu) # from help("pnbinom")
mu <- NULL
}
validate_q_a_b(q, a, b)
p_q <- pnbinom(q, size, prob, lower.tail = TRUE, log.p = log.p)
p_a <- pnbinom(a - 1L, size, prob, lower.tail = TRUE, log.p = log.p)
p_b <- pnbinom(b, size, prob, lower.tail = TRUE, log.p = log.p)
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

truncated_p <- function(p_q, p_a, p_b, lower.tail, log.p) {
# Usual cases --------------------------------------------------------------
if (log.p) {
Expand Down
95 changes: 85 additions & 10 deletions tests/testthat/test-ptrunc-truncated-a.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ test_that("lower truncation works as expected (normal)", {
lg <- FALSE
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
mn <- rnorm(1L, sd = 10)
sg <- rchisq(1L, 5L)
qt <- rnorm(i, mn, sg)
Expand Down Expand Up @@ -37,7 +37,7 @@ test_that("lower truncation works as expected (normal)", {
test_that("lower truncation works as expected (beta)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
shp1 <- sample(1:10, 1L)
shp2 <- sample(1:10, 1L)
a <- rbeta(1L, shp1, shp2)
Expand Down Expand Up @@ -69,7 +69,7 @@ test_that("lower truncation works as expected (beta)", {
test_that("lower truncation works as expected (binomial)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
size <- sample(10:30, 1L)
prob <- runif(1L, .2, .8)
a <- sample(1:(size - 4L), 1L)
Expand All @@ -94,7 +94,7 @@ test_that("lower truncation works as expected (binomial)", {
test_that("lower truncation works as expected (poisson)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
lambda <- sample(10:50, 1L)
max_qt <- qpois(p = .99, lambda)
a <- sample(seq(1L, max_qt - 3L), 1L)
Expand All @@ -121,7 +121,7 @@ test_that("lower truncation works as expected (poisson)", {
test_that("lower truncation works as expected (chisq)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
df <- sample(1:100, 1L)
a <- min(rchisq(10L, df))
qt <- replicate(i, max(rchisq(10L, df), a))
Expand All @@ -145,7 +145,7 @@ test_that("lower truncation works as expected (chisq)", {
})

test_that("lower truncation works as expected (contbern)", {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
lambda <- runif(1L)
a <- runif(1L)
qt <- runif(i, a, 1L)
Expand All @@ -162,7 +162,7 @@ test_that("lower truncation works as expected (contbern)", {
test_that("lower truncation works as expected (exp)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
rate <- rchisq(1L, df = 10L)
a <- rexp(1L, rate)
qt <- replicate(i, max(rexp(10L, rate), a))
Expand All @@ -189,7 +189,7 @@ test_that("lower truncation works as expected (exp)", {
test_that("lower truncation works as expected (gamma)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
shape <- rchisq(1L, df = 10L)
rate <- rchisq(1L, df = 10L)
a <- rgamma(1L, shape, rate)
Expand Down Expand Up @@ -224,7 +224,7 @@ test_that("lower truncation works as expected (gamma)", {
test_that("lower truncation works as expected (invgamma)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
shape <- rchisq(1L, df = 10L)
rate <- rchisq(1L, df = 10L)
a <- rinvgamma(1L, shape, rate)
Expand Down Expand Up @@ -257,7 +257,7 @@ test_that("lower truncation works as expected (invgamma)", {
})

test_that("lower truncation works as expected (invgauss)", {
for (i in seq_len(5)) {
for (i in seq_len(3L)) {
m <- rchisq(1L, df = 10L)
s <- rchisq(1L, df = 10L)
a <- rinvgauss(1L, m, s)
Expand All @@ -273,3 +273,78 @@ test_that("lower truncation works as expected (invgauss)", {
}
}
})

test_that("lower truncation works as expected (lognormal)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(3L)) {
meanlog <- rnorm(1L, sd = 10)
sdlog <- rchisq(1L, 5L)
qt <- rlnorm(i, meanlog, sdlog)
a <- rlnorm(1L, meanlog, sdlog)
while (any(a > qt)) {
a <- rlnorm(1L, meanlog, sdlog)
}
p_trunc <- ptrunc(
qt, "lognormal", meanlog, sdlog, a = a, lower.tail = lt, log.p = lg
)
p_ln <- plnorm(qt, meanlog, sdlog, lower.tail = lt, log.p = lg)
expect_length(qt, i)
expect_length(p_trunc, i)
for (q in seq_along(qt)) {
if (!lg) {
expect_gte(p_trunc[q], 0)
expect_lte(p_trunc[q], 1)
if (lt) {
expect_lte(p_trunc[q], p_ln[q])
} else {
expect_gte(p_trunc[q], p_ln[q])
}
} else {
expect_lte(p_trunc[q], 0)
}
}
}
}
}
})

test_that("lower truncation works as expected (negative binomial)", {
for (lt in c(TRUE, FALSE)) {
for (lg in c(FALSE, TRUE)) {
for (i in seq_len(3L)) {
size <- sample(1:10, 1L)
prob <- runif(1)
mu <- size * (1 - prob) / prob
qt <- rnbinom(i, size, prob)
a <- rnbinom(1L, size, prob)
while (any(a > qt)) {
a <- rnbinom(1L, size, prob)
}
p_trunc <- ptrunc(
qt, "nbinom", size, prob, lower.tail = lt, log.p = lg, a = a
)
p_trunc_2 <- ptrunc(
qt, "nbinom", size, mu = mu, lower.tail = lt, log.p = lg, a = a
)
p_binom <- pnbinom(qt, size, prob, lower.tail = lt, log.p = lg)
expect_length(qt, i)
expect_length(p_trunc, i)
expect_equal(p_trunc, p_trunc_2, tolerance = 1e-6)
for (q in seq_along(qt)) {
if (!lg) {
expect_gte(p_trunc[q], 0)
expect_lte(p_trunc[q], 1)
if (lt) {
expect_lte(p_trunc[q], p_binom[q])
} else {
expect_gte(round(p_trunc[q], 6), round(p_binom[q], 6))
}
} else {
expect_lte(p_trunc[q], 0)
}
}
}
}
}
})
Loading

0 comments on commit 6e39622

Please sign in to comment.