Skip to content

Commit

Permalink
Change behavior to USE exact when needed instead of stopping and prom…
Browse files Browse the repository at this point in the history 
…pting user. Update and add tests.
  • Loading branch information
@aadler
aadler committed Apr 4, 2024
1 parent 77ee9e0 commit 830615c
Show file tree
Hide file tree
Showing 2 changed files with 87 additions and 44 deletions.
48 changes: 26 additions & 22 deletions R/Delaporte.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,37 +40,41 @@ qdelap <- function(p, alpha, beta, lambda, lower.tail = TRUE, log.p = FALSE,
alpha <- as.double(alpha)
beta <- as.double(beta)
lambda <- as.double(lambda)
if (lower.tail) lt_f <- 1L else lt_f <- 0L
if (log.p) lp_f <- 1L else lp_f <- 0L
if (exact) {
if (lower.tail) lt_f <- 1L else lt_f <- 0L
if (log.p) lp_f <- 1L else lp_f <- 0L
QDLAP <- .Call(qdelap_C, p, alpha, beta, lambda, lt_f, lp_f,
getDelapThreads())
} else {
if (length(alpha) > 1L || length(beta) > 1L || length(lambda) > 1L ||
anyNA(p)) {
stop("Quantile approximation relies on pooling and is not accurate when",
"passed vector-valued parameters, NaNs, or NAs. Please use exact",
"version.")
}
if (any(alpha <= 0) || any(beta <= 0) || any(lambda <= 0)) {
QDLAP <- rep.int(NaN, length(p))
warning("Quantile approximation relies on pooling and is not accurate ",
"when passed vector-valued parameters, NaNs, or NAs. Using ",
"exact version instead.")
QDLAP <- .Call(qdelap_C, p, alpha, beta, lambda, lt_f, lp_f,
getDelapThreads())
} else {
if (log.p) p <- exp(p)
if (!lower.tail) p <- 1 - p
pValid <- p[p > 0 & p < 1]
pNeg <- p[p < 0]
p0 <- p[p == 0]
pInf <- p[p >= 1]
n <- min(10 ^ (ceiling(log(alpha * beta + lambda, 10)) + 5), 1e7)
shiftedGammas <- rgamma(n, shape = alpha, scale = beta)
DP <- rpois(n, lambda = (shiftedGammas + lambda))
qValid <- as.vector(quantile(DP, pValid, na.rm = TRUE, type = 8))
qNeg <- rep.int(NaN, times = length(pNeg))
q0 <- rep.int(0, times = length(p0))
qInf <- rep.int(Inf, times = length(pInf))
QDLAP <- as.vector(c(qNeg, q0, qValid, qInf), mode = "double")
if (any(alpha <= 0) || any(beta <= 0) || any(lambda <= 0)) {
QDLAP <- rep.int(NaN, length(p))
} else {
if (log.p) p <- exp(p)
if (!lower.tail) p <- 1 - p
pValid <- p[p > 0 & p < 1]
pNeg <- p[p < 0]
p0 <- p[p == 0]
pInf <- p[p >= 1]
n <- min(10 ^ (ceiling(log(alpha * beta + lambda, 10)) + 5), 1e7)
shiftedGammas <- rgamma(n, shape = alpha, scale = beta)
DP <- rpois(n, lambda = (shiftedGammas + lambda))
qValid <- as.vector(quantile(DP, pValid, na.rm = TRUE, type = 8))
qNeg <- rep.int(NaN, times = length(pNeg))
q0 <- rep.int(0, times = length(p0))
qInf <- rep.int(Inf, times = length(pInf))
QDLAP <- as.vector(c(qNeg, q0, qValid, qInf), mode = "double")
}
}
}

if (any(is.nan(QDLAP))) warning("NaNs produced")
return(QDLAP)
}
Expand Down
83 changes: 61 additions & 22 deletions inst/tinytest/test-qdelap.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@ setDelapThreads(2L)

tol <- 1e-12
nanWarn <- "NaNs produced"
inpErr <- "Quantile approximation relies on pooling"
inpWarn <- "Quantile approximation relies on pooling"

# Singleton exact function accuracy
expect_equal(qdelap(0.4, 1, 4, 2), 4, tolerance = tol)
Expand Down Expand Up @@ -59,8 +59,8 @@ expect_warning(qdelap(1, 1, 4, -9e-4, exact = FALSE), nanWarn)

# Singleton approx bad inputs
expect_warning(qdelap(-1, 2, 3, 4, exact = FALSE), nanWarn)
expect_error(qdelap(c(0.2, NaN), 2, 3, 4, exact = FALSE), inpErr)
expect_error(qdelap(c(0.3, NA), 2, 3, 4, exact = FALSE), inpErr)
expect_warning(qdelap(c(0.2, NaN), 2, 3, 4, exact = FALSE), inpWarn)
expect_warning(qdelap(c(0.3, NA), 2, 3, 4, exact = FALSE), inpWarn)

# Vector exact function accuracy
expect_equal(qdelap(c(0.4, 0.07), c(1, 2), c(4, 1), c(2, 5)), c(4, 3),
Expand Down Expand Up @@ -100,21 +100,51 @@ expect_warning(qdelap(c(5, NaN), c(1, 3), 1, 6), nanWarn)
# Vector approx bad parameters
t2 <- 1:2 / 10
t3 <- 1:3 / 10
expect_error(qdelap(t2, c(0, 1), 1, 2, exact = FALSE), inpErr)
expect_error(qdelap(t2, c(1, -1), 1, 2, exact = FALSE), inpErr)
expect_error(qdelap(t2, 1, c(2, 0), 2, exact = FALSE), inpErr)
expect_error(qdelap(t2, 1, c(-8, 3), 2, exact = FALSE), inpErr)
expect_error(qdelap(t2, 3, 1, c(2, 0), exact = FALSE), inpErr)
expect_error(qdelap(t2, 3, 1, c(-4e-5, 12), exact = FALSE), inpErr)
expect_error(qdelap(t3, c(0, 1, 2), c(1, 0, 2), c(1, 2, 0), exact = FALSE),
inpErr)
expect_error(qdelap(t3 / 10, c(6, 1, 2), c(1, 4, 2), c(1, 2, -1),
exact = FALSE), inpErr)
expect_warning(qdelap(t2, c(0, 1), 1, 2, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, c(0, 1), 1, 2, exact = FALSE)),
suppressWarnings(qdelap(t2, c(0, 1), 1, 2)))
expect_warning(qdelap(t2, c(1, -1), 1, 2, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, c(1, -1), 1, 2, exact = FALSE)),
suppressWarnings(qdelap(t2, c(1, -1), 1, 2)))
expect_warning(qdelap(t2, 1, c(2, 0), 2, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, 1, c(2, 0), 2, exact = FALSE)),
suppressWarnings(qdelap(t2, 1, c(2, 0), 2)))
expect_warning(qdelap(t2, 1, c(-8, 3), 2, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, 1, c(-8, 3), 2, exact = FALSE)),
suppressWarnings(qdelap(t2, 1, c(-8, 3), 2)))
expect_warning(qdelap(t2, 3, 1, c(2, 0), exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, 3, 1, c(2, 0), exact = FALSE)),
suppressWarnings(qdelap(t2, 3, 1, c(2, 0))))
expect_warning(qdelap(t2, 3, 1, c(-4e-5, 12), exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t2, 3, 1, c(-4e-5, 12),
exact = FALSE)),
suppressWarnings(qdelap(t2, 3, 1, c(-4e-5, 12))))
expect_warning(qdelap(t3, c(0, 1, 2), c(1, 0, 2), c(1, 2, 0), exact = FALSE),
inpWarn)
expect_identical(suppressWarnings(qdelap(t3, c(0, 1, 2), c(1, 0, 2), c(1, 2, 0),
exact = FALSE)),
suppressWarnings(qdelap(t3, c(0, 1, 2), c(1, 0, 2),
c(1, 2, 0))))
expect_warning(qdelap(t3 / 10, c(6, 1, 2), c(1, 4, 2), c(1, 2, -1),
exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(t3 / 10, c(6, 1, 2), c(1, 4, 2),
c(1, 2, -1), exact = FALSE)),
suppressWarnings(qdelap(t3 / 10, c(6, 1, 2), c(1, 4, 2),
c(1, 2, -1))))

# Vector exact bad inputs
expect_error(qdelap(c(-1, 3), c(1, 3), 1, 6, exact = FALSE), inpErr)
expect_error(qdelap(c(NA, 4), c(1, 3), 1, 6, exact = FALSE), inpErr)
expect_error(qdelap(c(5, NaN), c(1, 3), 1, 6, exact = FALSE), inpErr)
expect_warning(qdelap(c(-1, 3), c(1, 3), 1, 6, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(c(-1, 3), c(1, 3), 1, 6,
exact = FALSE)),
suppressWarnings(qdelap(c(-1, 3), c(1, 3), 1, 6)))
expect_warning(qdelap(c(NA, 4), c(1, 3), 1, 6, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(c(NA, 4), c(1, 3), 1, 6,
exact = FALSE)),
suppressWarnings(qdelap(c(NA, 4), c(1, 3), 1, 6)))
expect_warning(qdelap(c(5, NaN), c(1, 3), 1, 6, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(c(5, NaN), c(1, 3), 1, 6,
exact = FALSE)),
suppressWarnings(qdelap(c(5, NaN), c(1, 3), 1, 6)))

# Singleton Inf
expect_true(is.infinite(qdelap(1, 3, 1, 2)))
Expand All @@ -128,18 +158,27 @@ expect_identical(is.infinite(qdelap(c(1, 3), 3, 1, 2, exact = FALSE)),
expect_identical(is.infinite(qdelap(1:2, 3, c(1, 1), 2)), rep(TRUE, 2))
expect_identical(is.infinite(qdelap(1:3, c(2, 1, 2), c(1, 6, 2), c(1, 2, 0.4))),
rep(TRUE, 3))
expect_error(qdelap(1:2, 3, c(1, 1), 2, exact = FALSE), inpErr)
expect_error(qdelap(1:3, c(2, 1, 2), c(1, 6, 2), c(1, 2, 0.4), exact = FALSE),
inpErr)
expect_warning(qdelap(1:2, 3, c(1, 1), 2, exact = FALSE), inpWarn)
expect_identical(suppressWarnings(qdelap(1:2, 3, c(1, 1), 2, exact = FALSE)),
qdelap(1:2, 3, c(1, 1), 2))
expect_warning(qdelap(1:3, c(2, 1, 2), c(1, 6, 2), c(1, 2, 0.4), exact = FALSE),
inpWarn)
expect_identical(suppressWarnings(qdelap(1:3, c(2, 1, 2), c(1, 6, 2),
c(1, 2, 0.4), exact = FALSE)),
qdelap(1:3, c(2, 1, 2), c(1, 6, 2), c(1, 2, 0.4)))

# Approximate throws error when nonpositive is passed
expect_warning(qdelap(0.1, 0, 2, 3, exact = FALSE), nanWarn)
expect_warning(qdelap(0.1, 1, 0, 3, exact = FALSE), nanWarn)
expect_warning(qdelap(0.1, 1, 2, -3, exact = FALSE), nanWarn)

# Approximate throws error when parameter vectors are passed
expect_error(qdelap(c(0.4, 0.07), c(1, 2), c(4, 1), c(2, 5), exact = FALSE),
"Quantile approximation relies on pooling")
# Approximate throws warning when parameter vectors are passed and is equal to
# exact.
expect_warning(qdelap(c(0.4, 0.07), c(1, 2), c(4, 1), c(2, 5), exact = FALSE),
"Quantile approximation relies on pooling")
expect_identical(suppressWarnings(qdelap(c(0.4, 0.07), c(1, 2), c(4, 1),
c(2, 5), exact = FALSE)),
qdelap(c(0.4, 0.07), c(1, 2), c(4, 1), c(2, 5)))

# Non-double parameters converted
expect_equal(qdelap(0.25, 1L, 2L, 3L), qdelap(0.25, 1, 2, 3), tolerance = tol)
Expand Down

0 comments on commit 830615c

Please sign in to comment.