Skip to content

Commit

Permalink
Merge branch 'pqtrunc-alias' into develop
Browse files Browse the repository at this point in the history 
* pqtrunc-alias:
  Increment version number to 1.1.1.9022
  Added alias and tests for qtrunc (#54)
  Properly documented ptrunc aliases (#54)
  Added unit tests for ptrunc aliases (#54)
  Added aliases for #54
  • Loading branch information
@wleoncio
wleoncio committed Aug 21, 2024
2 parents 4cc5705 + f047c7e commit a005774
Show file tree
Hide file tree
Showing 7 changed files with 589 additions and 27 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: TruncExpFam
Title: Truncated Exponential Family
Version: 1.1.1.9021
Version: 1.1.1.9022
Date: 2024-02-26
Authors@R:
c(
Expand Down
24 changes: 24 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -95,7 +95,31 @@ export(natural2parameters)
export(parameters2natural)
export(probdist)
export(ptrunc)
export(ptruncbeta)
export(ptruncbinom)
export(ptruncchisq)
export(ptrunccontbern)
export(ptruncexp)
export(ptruncgamma)
export(ptruncinvgamma)
export(ptruncinvgauss)
export(ptrunclnorm)
export(ptruncnbinom)
export(ptruncnorm)
export(ptruncpois)
export(qtrunc)
export(qtruncbeta)
export(qtruncbinom)
export(qtruncchisq)
export(qtrunccontbern)
export(qtruncexp)
export(qtruncgamma)
export(qtruncinvgamma)
export(qtruncinvgauss)
export(qtrunclnorm)
export(qtruncnbinom)
export(qtruncnorm)
export(qtruncpois)
export(rtrunc)
export(rtrunc.beta)
export(rtrunc_direct)
Expand Down
82 changes: 71 additions & 11 deletions R/ptrunc.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,7 @@ ptrunc.generic <- function(q, ..., lower.tail, log.p) {
}

ptrunc.normal <- function(
q, mean = 0, sd = 1, a = -Inf, b = Inf, ..., lower.tail, log.p
q, mean = 0, sd = 1, a = -Inf, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
p_q <- pnorm(q, mean, sd, lower.tail = TRUE, log.p)
Expand All @@ -43,8 +43,13 @@ ptrunc.normal <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncnorm <- ptrunc.normal

ptrunc.beta <- function(
q, shape1, shape2, a = 0, b = 1, ..., lower.tail, log.p
q, shape1, shape2, a = 0, b = 1, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
p_q <- pbeta(q, shape1, shape2, ncp = 0, lower.tail = TRUE, log.p)
Expand All @@ -53,8 +58,13 @@ ptrunc.beta <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncbeta <- ptrunc.beta

ptrunc.binomial <- function(
q, size, prob, a = 0, b = size, ..., lower.tail, log.p
q, size, prob, a = 0, b = size, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
p_q <- pbinom(q, size, prob, lower.tail = TRUE, log.p)
Expand All @@ -63,8 +73,13 @@ ptrunc.binomial <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncbinom <- ptrunc.binomial

ptrunc.poisson <- function(
q, lambda, a = 0, b = Inf, ..., lower.tail, log.p
q, lambda, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
p_q <- ppois(q, lambda, lower.tail = TRUE, log.p)
Expand All @@ -73,14 +88,24 @@ ptrunc.poisson <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

ptrunc.chisq <- function(q, df, a = 0, b = Inf, ..., lower.tail, log.p) {
#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncpois <- ptrunc.poisson

ptrunc.chisq <- function(q, df, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE) {
validate_q_a_b(q, a, b)
p_q <- pchisq(q, df, ncp = 0, lower.tail = TRUE, log.p)
p_a <- pchisq(a - 1L, df, ncp = 0, lower.tail = TRUE, log.p)
p_b <- pchisq(b, df, ncp = 0, lower.tail = TRUE, log.p)
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncchisq <- ptrunc.chisq

ptrunc.contbern <- function(q, lambda, a = 0, b = 1, ...) {
validate_q_a_b(q, a, b)
p_q <- pcontbern(q, lambda)
Expand All @@ -89,16 +114,26 @@ ptrunc.contbern <- function(q, lambda, a = 0, b = 1, ...) {
return(truncated_p(p_q, p_a, p_b, lower.tail = TRUE, log.p = FALSE))
}

ptrunc.exp <- function(q, rate = 1, a = 0, b = Inf, ..., lower.tail, log.p) {
#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptrunccontbern <- ptrunc.contbern

ptrunc.exp <- function(q, rate = 1, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE) {
validate_q_a_b(q, a, b)
p_q <- pexp(q, rate, lower.tail = TRUE, log.p)
p_a <- pexp(a, rate, lower.tail = TRUE, log.p)
p_b <- pexp(b, rate, lower.tail = TRUE, log.p)
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncexp <- ptrunc.exp

ptrunc.gamma <- function(
q, shape, rate = 1, scale = 1 / rate, a = 0, b = Inf, ..., lower.tail, log.p
q, shape, rate = 1, scale = 1 / rate, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
if (!missing(rate) && !missing(scale)) {
Expand All @@ -110,8 +145,13 @@ ptrunc.gamma <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncgamma <- ptrunc.gamma

ptrunc.invgamma <- function(
q, shape, rate = 1, scale = 1 / rate, a = 0, b = Inf, ..., lower.tail, log.p
q, shape, rate = 1, scale = 1 / rate, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
if (!missing(rate) && !missing(scale)) {
Expand All @@ -123,6 +163,11 @@ ptrunc.invgamma <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncinvgamma <- ptrunc.invgamma

ptrunc.invgauss <- function(q, m, s, a = 0, b = Inf, ...) {
validate_q_a_b(q, a, b)
p_q <- pinvgauss(q, m, s)
Expand All @@ -131,8 +176,13 @@ ptrunc.invgauss <- function(q, m, s, a = 0, b = Inf, ...) {
return(truncated_p(p_q, p_a, p_b, lower.tail = TRUE, log.p = FALSE))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncinvgauss <- ptrunc.invgauss

ptrunc.lognormal <- function(
q, meanlog = 0, sdlog = 1, a = 0, b = Inf, ..., lower.tail, log.p
q, meanlog = 0, sdlog = 1, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
validate_q_a_b(q, a, b)
p_q <- plnorm(q, meanlog, sdlog, lower.tail = TRUE, log.p)
Expand All @@ -141,8 +191,13 @@ ptrunc.lognormal <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptrunclnorm <- ptrunc.lognormal

ptrunc.nbinom <- function(
q, size, prob, mu, a = 0, b = Inf, ..., lower.tail, log.p
q, size, prob, mu, a = 0, b = Inf, ..., lower.tail = TRUE, log.p = FALSE
) {
if (missing(prob)) {
prob <- size / (size + mu) # from help("pnbinom")
Expand All @@ -155,7 +210,12 @@ ptrunc.nbinom <- function(
return(truncated_p(p_q, p_a, p_b, lower.tail, log.p))
}

truncated_p <- function(p_q, p_a, p_b, lower.tail, log.p) {
#' @export
#' @rdname ptrunc
#' @inheritParams rtrunc
ptruncnbinom <- ptrunc.nbinom

truncated_p <- function(p_q, p_a, p_b, lower.tail = TRUE, log.p = FALSE) {
# Usual cases --------------------------------------------------------------
if (log.p) {
p <- log((exp(p_q) - exp(p_a)) / (exp(p_b) - exp(p_a)))
Expand Down
Loading

0 comments on commit a005774

Please sign in to comment.