Merge branch 'issue-54' into develop

* issue-54: Increment version number to 1.1.1.9018 Implemented `qtrunc.chisq()` (#54)
ocbe-uio · Jul 5, 2024 · 5a32fea · 5a32fea
2 parents 5d8ee90 + 012d167
commit 5a32fea
Show file tree

Hide file tree

Showing 6 changed files with 101 additions and 1 deletion.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: TruncExpFam
 Title: Truncated Exponential Family
-Version: 1.1.1.9017
+Version: 1.1.1.9018
 Date: 2024-02-26
 Authors@R:
 	c(

diff --git a/R/qtrunc.R b/R/qtrunc.R
@@ -53,6 +53,14 @@ qtrunc.binomial <- function(
   return(q)
 }
 
+qtrunc.chisq <- function(p, df, a = 0, b = Inf, ..., lower.tail, log.p) {
+  F_a <- pchisq(a - 1L, df, ncp = 0, lower.tail, FALSE)
+  F_b <- pchisq(b, df, ncp = 0, lower.tail, FALSE)
+  rescaled_p <- rescale_p(p, F_a, F_b, lower.tail, log.p)
+  q <- qchisq(rescaled_p, df, ncp = 0, 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
@@ -65,6 +65,29 @@ test_that("qtrunc() works as expected (binomial)", {
   }
 })
 
+test_that("qtrunc() works as expected (chisq)", {
+  fam <- "chisq"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        df <- sample(1:10, 1L)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        a <- min(qtrunc(pt, fam, df, lower.tail = lt, log.p = lg) / 2)
+        q_trunc <- qtrunc(pt, fam, df, lower.tail = lt, log.p = lg, a = a)
+        q_stats <- qchisq(pt, df, lower.tail = lt, log.p = lg)
+        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
+          ptr <- ptrunc(q_trunc[ii], fam, df, lower.tail = lt, log.p = lg, 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)) {

diff --git a/tests/testthat/test-qtrunc-truncated-ab.R b/tests/testthat/test-qtrunc-truncated-ab.R
@@ -66,6 +66,29 @@ test_that("qtrunc() works as expected (binomial)", {
   }
 })
 
+test_that("qtrunc() works as expected (chisq)", {
+  fam <- "chisq"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        df <- sample(1:10, 1L)
+        pt <- runif(i)
+        a <- min(qtrunc(pt, fam, df, lower.tail = lt, log.p = FALSE) / 2000)
+        b <- max(qtrunc(pt, fam, df, lower.tail = lt, log.p = FALSE) * 2000)
+        if (lg) pt <- log(pt)
+        q_trunc <- qtrunc(pt, fam, df, lower.tail = lt, log.p = lg, a = a, b = b)
+        q_stats <- qchisq(pt, df, lower.tail = lt, log.p = lg)
+        expect_length(q_trunc, i)
+        for (ii in seq_along(pt)) {
+          # Working back to p from q
+          ptr <- ptrunc(q_trunc[ii], fam, df, lower.tail = lt, log.p = lg, 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)) {

diff --git a/tests/testthat/test-qtrunc-truncated-b.R b/tests/testthat/test-qtrunc-truncated-b.R
@@ -69,6 +69,29 @@ test_that("qtrunc() works as expected (binomial)", {
   }
 })
 
+test_that("qtrunc() works as expected (chisq)", {
+  fam <- "chisq"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        df <- sample(1:10, 1L)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        b <- max(qtrunc(pt, fam, df, lower.tail = lt, log.p = lg) * 2)
+        q_trunc <- qtrunc(pt, fam, df, lower.tail = lt, log.p = lg, b = b)
+        q_stats <- qchisq(pt, df, lower.tail = lt, log.p = lg)
+        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
+          ptr <- ptrunc(q_trunc[ii], fam, df, lower.tail = lt, log.p = lg, 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)) {

diff --git a/tests/testthat/test-qtrunc-untruncated.R b/tests/testthat/test-qtrunc-untruncated.R
@@ -58,6 +58,29 @@ test_that("qtrunc() works as expected (binomial)", {
   }
 })
 
+test_that("qtrunc() works as expected (chisq)", {
+  fam <- "chisq"
+  for (lg in c(FALSE, TRUE)) {
+    for (lt in c(TRUE, FALSE)) {
+      for (i in seq_len(3L)) {
+        df <- sample(1:10, 1L)
+        pt <- runif(i)
+        if (lg) pt <- log(pt)
+        q_trunc <- qtrunc(pt, fam, df, lower.tail = lt, log.p = lg)
+        q_stats <- qchisq(pt, df, 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
+          ptr <- ptrunc(q_trunc[ii], fam, df, lower.tail = lt, log.p = lg)
+          expect_equal(pt[ii], ptr)
+        }
+      }
+    }
+  }
+})
+
 test_that("qtrunc() works as expected (normal)", {
   for (lg in c(FALSE, TRUE)) {
     for (lt in c(TRUE, FALSE)) {