Merge branch 'issue-54' into develop

* issue-54:
  Increment version number to 1.1.1.9019
  Implemented `qtrunc.contbern()` (#54)

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: TruncExpFam
 Title: Truncated Exponential Family
-Version: 1.1.1.9018
+Version: 1.1.1.9019
 Date: 2024-02-26
 Authors@R:
 	c(

R/qtrunc.R

@@ -61,6 +61,14 @@ qtrunc.chisq <- function(p, df, a = 0, b = Inf, ..., lower.tail, log.p) {
   return(q)
 }
 
+qtrunc.contbern <- function(p, lambda, a = 0, b = 1, ..., lower.tail, log.p) {
+  F_a <- pcontbern(a, lambda)
+  F_b <- pcontbern(b, lambda)
+  rescaled_p <- rescale_p(p, F_a, F_b, lower.tail, log.p)
+  q <- qcontbern(rescaled_p, lambda)
+  return(q)
+}
+
 qtrunc.normal <- function(
     p, mean = 0, sd = 1, a = -Inf, b = Inf, ..., lower.tail, log.p
   ) {

tests/testthat/test-qtrunc-truncated-a.R

@@ -88,6 +88,24 @@ test_that("qtrunc() works as expected (chisq)", {
   }
 })
 
+test_that("qtrunc() works as expected (contbern)", {
+  fam <- "contbern"
+  for (i in seq_len(3L)) {
+    lb <- runif(1L)
+    pt <- runif(i)
+    a <- runif(1L)
+    q_trunc <- qtrunc(pt, fam, lb, a = a)
+    q_stats <- qcontbern(pt, lb)
+    expect_length(q_trunc, i)
+    for (ii in seq_along(pt)) {
+      expect_gt(q_trunc[ii], q_stats[ii])
+      # Working back to p from q
+      ptr <- ptrunc(q_trunc[ii], fam, lb, a = a)
+      expect_equal(pt[ii], ptr)
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {

tests/testthat/test-qtrunc-truncated-ab.R

@@ -89,6 +89,24 @@ test_that("qtrunc() works as expected (chisq)", {
   }
 })
 
+test_that("qtrunc() works as expected (contbern)", {
+  fam <- "contbern"
+  for (i in seq_len(3L)) {
+    lambda <- runif(1L)
+    pt <- runif(i)
+    a <- runif(1L)
+    b <- runif(1L, a, 1L)
+    q_trunc <- qtrunc(pt, fam, lambda, a = a, b = b)
+    q_stats <- qcontbern(pt, lambda)
+    expect_length(q_trunc, i)
+    for (ii in seq_along(pt)) {
+      # Working back to p from q
+      ptr <- ptrunc(q_trunc[ii], fam, lambda, a = a, b = b)
+      expect_equal(pt[ii], ptr)
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {

tests/testthat/test-qtrunc-truncated-b.R

@@ -92,6 +92,25 @@ test_that("qtrunc() works as expected (chisq)", {
   }
 })
 
+test_that("qtrunc() works as expected (contbern)", {
+  fam <- "contbern"
+  for (i in seq_len(3L)) {
+    lambda <- runif(1L)
+    pt <- runif(i)
+    b <- runif(1L)
+    q_trunc <- qtrunc(pt, fam, lambda, b = b)
+    q_stats <- qcontbern(pt, lambda)
+    expect_length(pt, i)
+    expect_length(q_trunc, i)
+    for (ii in seq_along(pt)) {
+      expect_lt(q_trunc[ii], q_stats[ii])
+      # Working back to p from q
+      ptr <- ptrunc(q_trunc[ii], fam, lambda, b = b)
+      expect_equal(pt[ii], ptr)
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {

tests/testthat/test-qtrunc-untruncated.R

@@ -81,6 +81,24 @@ test_that("qtrunc() works as expected (chisq)", {
   }
 })
 
+test_that("qtrunc() works as expected (contbern)", {
+  fam <- "contbern"
+  for (i in seq_len(3L)) {
+    lambda <- runif(1)
+    pt <- runif(i)
+    q_trunc <- qtrunc(pt, fam, lambda)
+    q_stats <- qcontbern(pt, lambda)
+    expect_length(pt, i)
+    expect_length(q_trunc, i)
+    for (ii in seq_along(pt)) {
+      expect_equal(q_trunc[ii], q_stats[ii])
+      # Working back to p from q
+      ptr <- ptrunc(q_trunc[ii], fam, lambda)
+      expect_equal(pt[ii], ptr)
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {