Merge branch 'issue-54' into develop

* issue-54: Increment version number to 1.1.1.9017 Implemented unit tests for `qtrunc.binom()` (#54) Fixed unit tests for #54 Implemented `qtrunc.binom()` (#54) Updated RoxygenNote version
ocbe-uio · Jul 5, 2024 · 5d8ee90 · 5d8ee90
2 parents 03010b6 + 25ac6a2
commit 5d8ee90
Show file tree

Hide file tree

Showing 6 changed files with 165 additions and 11 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: TruncExpFam
 Title: Truncated Exponential Family
-Version: 1.1.1.9016
+Version: 1.1.1.9017
 Date: 2024-02-26
 Authors@R:
 	c(
@@ -27,7 +27,7 @@ Description: Handles truncated members from the exponential family of
 License: GPL-3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Imports: methods, invgamma, rmutil
 Suggests:
     knitr,

diff --git a/R/qtrunc.R b/R/qtrunc.R
@@ -43,6 +43,16 @@ qtrunc.beta <- function(
   return(q)
 }
 
+qtrunc.binomial <- function(
+    p, size, prob, a = 0, b = size, ..., lower.tail, log.p
+  ) {
+  F_a <- pbinom(a - 1L, size, prob, lower.tail, FALSE)
+  F_b <- pbinom(b, size, prob, lower.tail, FALSE)
+  rescaled_p <- rescale_p(p, F_a, F_b, lower.tail, log.p)
+  q <- qbinom(rescaled_p, size, prob, lower.tail, FALSE)
+  return(q)
+}
+
 qtrunc.normal <- function(
     p, mean = 0, sd = 1, a = -Inf, b = Inf, ..., lower.tail, log.p
   ) {

diff --git a/tests/testthat/test-qtrunc-truncated-a.R b/tests/testthat/test-qtrunc-truncated-a.R
@@ -28,6 +28,43 @@ test_that("qtrunc() works as expected (beta)", {
   }
 })
 
+test_that("qtrunc() works as expected (binomial)", {
+  fam <- "binomial"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        sz <- sample(1:10, 1L)
+        pb <- runif(1)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        a <- qtrunc(min(pt) / 2, fam, sz, pb, lower.tail = lt, log.p = lg)
+        q_trunc <- qtrunc(pt, fam, sz, pb, a = a, lower.tail = lt, log.p = lg)
+        q_stats <- qbinom(pt, sz, pb, lower.tail = lt, log.p = lg)
+        expect_length(pt, i)
+        expect_length(q_trunc, i)
+        for (ii in seq_along(pt)) {
+          expect_gte(q_trunc[ii], q_stats[ii])
+          # Working back to p from q
+          q_lo <- max(q_trunc[ii] - 1L, 0L, a)
+          q_hi <- min(q_trunc[ii] + 1L, sz)
+          ptr_1 <- ptrunc(q_lo, fam, sz, pb, a = a, lower.tail = lt, log.p = lg)
+          ptr_2 <- ptrunc(q_hi, fam, sz, pb, a = a, lower.tail = lt, log.p = lg)
+          # because pt will have been rounded
+          if (q_trunc[ii] > 0L && q_lo > a) {
+            if (lt) {
+              expect_gte(pt[ii], ptr_1)
+              expect_lte(pt[ii], ptr_2)
+            } else {
+              expect_lte(pt[ii], ptr_1)
+              expect_gte(pt[ii], ptr_2)
+            }
+          }
+        }
+      }
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {

diff --git a/tests/testthat/test-qtrunc-truncated-ab.R b/tests/testthat/test-qtrunc-truncated-ab.R
@@ -7,20 +7,19 @@ test_that("qtrunc() works as expected (beta)", {
         shp1 <- sample(1:10, 1L)
         shp2 <- sample(1:10, 1L)
         pt <- runif(i)
-        ab <- c(runif(100L), pt)
-        b <- qtrunc(max(pt), "beta", shp1, shp2, lower.tail = lt, log.p = FALSE)
-        a <- qtrunc(min(pt), "beta", shp1, shp2, lower.tail = lt, log.p = FALSE)
+        qt <- c(runif(100L), pt)
+        a <- min(qt) - rchisq(1L, 5L)
+        b <- max(qt) + rchisq(1L, 5L)
         if (lg) pt <- log(pt)
         q_trunc <- qtrunc(
-          pt, "beta", shp1, shp2, b = b, lower.tail = lt, log.p = lg
+          pt, "beta", shp1, shp2, a = a, b = b, lower.tail = lt, log.p = lg
         )
-        q_stats <- qbeta(pt, shp1, shp2, lower.tail = lt, log.p = lg)
-        expect_length(pt, i)
         expect_length(q_trunc, i)
         for (ii in seq_along(pt)) {
           # Working back to p from q
           ptr <- ptrunc(
-            q_trunc[ii], "beta", shp1, shp2, lower.tail = lt, log.p = lg, b = b
+            q_trunc[ii], "beta", shp1, shp2, lower.tail = lt, log.p = lg,
+            a = a, b = b
           )
           expect_equal(pt[ii], ptr)
         }
@@ -29,6 +28,44 @@ test_that("qtrunc() works as expected (beta)", {
   }
 })
 
+test_that("qtrunc() works as expected (binomial)", {
+  fam <- "binomial"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        sz <- sample(1:10, 1L)
+        pb <- runif(1)
+        pt <- runif(i)
+        ab_probs <- c(runif(100L), pt)
+        b <- qtrunc(max(ab_probs), fam, sz, pb, lower.tail = TRUE, log.p = FALSE)
+        a <- qtrunc(min(ab_probs), fam, sz, pb, lower.tail = TRUE, log.p = FALSE)
+        if (lg) pt <- log(pt)
+        q_trunc <- qtrunc(pt, fam, sz, pb, a = a, b = b, lower.tail = lt, log.p = lg)
+        q_stats <- qbinom(pt, sz, pb, lower.tail = lt, log.p = lg)
+        expect_length(pt, i)
+        expect_length(q_trunc, i)
+        for (ii in seq_along(pt)) {
+          # Working back to p from q
+          q_lo <- max(q_trunc[ii] - 1L, 0L, a)
+          q_hi <- min(q_trunc[ii] + 1L, sz, b)
+          ptr_1 <- ptrunc(q_lo, fam, sz, pb, a = a, b = b, lower.tail = lt, log.p = lg)
+          ptr_2 <- ptrunc(q_hi, fam, sz, pb, a = a, b = b, lower.tail = lt, log.p = lg)
+          # because pt will have been rounded
+          if (q_trunc[ii] > 0L && q_hi < b && q_lo > a) {
+            if (lt) {
+              expect_gte(pt[ii], ptr_1)
+              expect_lte(pt[ii], ptr_2)
+            } else {
+              expect_lte(pt[ii], ptr_1)
+              expect_gte(pt[ii], ptr_2)
+            }
+          }
+        }
+      }
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {
@@ -44,8 +81,6 @@ test_that("qtrunc() works as expected (normal)", {
           pt, "normal", mean = mn, sd = sg, a = a, b = b,
           lower.tail = lt, log.p = lg
         )
-        q_norm <- qnorm(pt, mean = mn, sd = sg, lower.tail = lt, log.p = lg)
-        expect_length(pt, i)
         expect_length(q_trunc, i)
         for (ii in seq_along(pt)) {
           # Working back to p from q

diff --git a/tests/testthat/test-qtrunc-truncated-b.R b/tests/testthat/test-qtrunc-truncated-b.R
@@ -30,6 +30,45 @@ test_that("qtrunc() works as expected (beta)", {
   }
 })
 
+test_that("qtrunc() works as expected (binomial)", {
+  fam <- "binomial"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        sz <- sample(1:10, 1L)
+        pb <- runif(1)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        b <- qtrunc(
+          max(runif(10L, pt)), fam, sz, pb, lower.tail = lt, log.p = FALSE
+        )
+        q_trunc <- qtrunc(pt, fam, sz, pb, b = b, lower.tail = lt, log.p = lg)
+        q_stats <- qbinom(pt, sz, pb, lower.tail = lt, log.p = lg)
+        expect_length(pt, i)
+        expect_length(q_trunc, i)
+        for (ii in seq_along(pt)) {
+          expect_lte(q_trunc[ii], q_stats[ii])
+          # Working back to p from q
+          q_lo <- max(q_trunc[ii] - 1L, 0L)
+          q_hi <- min(q_trunc[ii] + 1L, sz, b)
+          ptr_1 <- ptrunc(q_lo, fam, sz, pb, b = b, lower.tail = lt, log.p = lg)
+          ptr_2 <- ptrunc(q_hi, fam, sz, pb, b = b, lower.tail = lt, log.p = lg)
+          # because pt will have been rounded
+          if (q_trunc[ii] > 0L && q_hi < b) {
+            if (lt) {
+              expect_gte(pt[ii], ptr_1)
+              expect_lte(pt[ii], ptr_2)
+            } else {
+              expect_lte(pt[ii], ptr_1)
+              expect_gte(pt[ii], ptr_2)
+            }
+          }
+        }
+      }
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {

diff --git a/tests/testthat/test-qtrunc-untruncated.R b/tests/testthat/test-qtrunc-untruncated.R
@@ -25,6 +25,39 @@ test_that("qtrunc() works as expected (beta)", {
   }
 })
 
+test_that("qtrunc() works as expected (binomial)", {
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        sz <- sample(1:10, 1L)
+        pb <- runif(1)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        q_trunc <- qtrunc(pt, "binomial", sz, pb, lower.tail = lt, log.p = lg)
+        q_stats <- qbinom(pt, sz, pb, lower.tail = lt, log.p = lg)
+        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
+          q_lo <- max(q_trunc[ii] - 1L, 0L)
+          q_hi <- min(q_trunc[ii] + 1L, sz)
+          ptr_1 <- ptrunc(q_lo, "binomial", sz, pb, lower.tail = lt, log.p = lg)
+          ptr_2 <- ptrunc(q_hi, "binomial", sz, pb, lower.tail = lt, log.p = lg)
+          # because pt will have been rounded
+          if (q_trunc[ii] > 0L && lt) {
+            expect_gte(pt[ii], ptr_1)
+            expect_lte(pt[ii], ptr_2)
+          } else if (q_trunc[ii] > 0L && !lt) {
+            expect_lte(pt[ii], ptr_1)
+            expect_gte(pt[ii], ptr_2)
+          }
+        }
+      }
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {