From 7dcd5cd8420e05e7e4d19cc779d25e8056966935 Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Fri, 5 Jul 2024 12:20:20 +0200 Subject: [PATCH 1/2] Implemented `qtrunc.chisq()` (#54) --- R/qtrunc.R | 8 ++++++++ tests/testthat/test-qtrunc-truncated-a.R | 23 +++++++++++++++++++++++ tests/testthat/test-qtrunc-truncated-ab.R | 23 +++++++++++++++++++++++ tests/testthat/test-qtrunc-truncated-b.R | 23 +++++++++++++++++++++++ tests/testthat/test-qtrunc-untruncated.R | 23 +++++++++++++++++++++++ 5 files changed, 100 insertions(+) diff --git a/R/qtrunc.R b/R/qtrunc.R index 31eb6d8..ada9872 100644 --- 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 index ced7ec2..454e7d4 100644 --- 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 index cf2b0d9..21ba48a 100644 --- 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 index e17f967..02d1412 100644 --- 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 index 9e32ca4..e7754ba 100644 --- 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)) { From 012d16757ff5bc766186b08985ff37101dfc900f Mon Sep 17 00:00:00 2001 From: Waldir Leoncio Date: Fri, 5 Jul 2024 12:33:29 +0200 Subject: [PATCH 2/2] Increment version number to 1.1.1.9018 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index b093395..049de63 100644 --- 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(