add truncated negative binomial

DESCRIPTION

@@ -1,10 +1,18 @@
 Package: extraDistr
 Type: Package
 Title: Additional Univariate and Multivariate Distributions
-Version: 1.9.1
-Date: 2020-08-20
-Author: Tymoteusz Wolodzko
-Maintainer: Tymoteusz Wolodzko <[email protected]>
+Version: 1.9.2
+Date: 2022-06-25
+Authors@R:  
+    c(person(given = "Tymoteusz",
+             family = "Wolodzko",
+             role = c("aut", "cre"),
+             email = "[email protected]"),
+      person(given = "Mervin",
+             family = "Fansler",
+             role = c("aut"),
+             email = "[email protected]",
+             comment = c(ORCID = "0000-0002-4108-4218"))) 
 Description: Density, distribution function, quantile function
     and random generation for a number of univariate
     and multivariate distributions. This package implements the
@@ -20,9 +28,10 @@ Description: Density, distribution function, quantile function
     hypergeometric, multinomial, negative hypergeometric, 
     non-standard beta, normal mixture, Poisson mixture, Pareto,
     power, reparametrized beta, Rayleigh, shifted Gompertz, Skellam,
-    slash, triangular, truncated binomial, truncated normal,
-    truncated Poisson, Tukey lambda, Wald, zero-inflated binomial,
-    zero-inflated negative binomial, zero-inflated Poisson.
+    slash, triangular, truncated binomial, truncated negative binomial,
+    truncated normal, truncated Poisson, Tukey lambda, Wald, 
+    zero-inflated binomial, zero-inflated negative binomial, 
+    zero-inflated Poisson.
 License: GPL-2
 URL: https://github.com/twolodzko/extraDistr
 BugReports: https://github.com/twolodzko/extraDistr/issues
@@ -33,4 +42,4 @@ LinkingTo: Rcpp
 Imports: Rcpp
 Suggests: testthat, LaplacesDemon, VGAM, evd, hoa, skellam, triangle, actuar
 SystemRequirements: C++11
-RoxygenNote: 7.1.1
+RoxygenNote: 7.2.0

NAMESPACE

@@ -47,6 +47,7 @@ export(dsgomp)
 export(dskellam)
 export(dslash)
 export(dtbinom)
+export(dtnbinom)
 export(dtnorm)
 export(dtpois)
 export(dtriang)
@@ -94,6 +95,7 @@ export(prayleigh)
 export(psgomp)
 export(pslash)
 export(ptbinom)
+export(ptnbinom)
 export(ptnorm)
 export(ptpois)
 export(ptriang)
@@ -131,6 +133,7 @@ export(qprop)
 export(qrayleigh)
 export(qtbinom)
 export(qtlambda)
+export(qtnbinom)
 export(qtnorm)
 export(qtpois)
 export(qtriang)
@@ -187,6 +190,7 @@ export(rskellam)
 export(rslash)
 export(rtbinom)
 export(rtlambda)
+export(rtnbinom)
 export(rtnorm)
 export(rtpois)
 export(rtriang)

NEWS.md

@@ -1,3 +1,7 @@
+### 1.9.2
+
+* Adds truncated negative binomial distribution.
+
 ### 1.9.1
 
 * Generated header file, `inst/include/extraDistr.h`, to make C++ code callable 

R/RcppExports.R

@@ -637,6 +637,38 @@ cpp_rtbinom <- function(n, size, prob, lower, upper) {
     .Call(`_extraDistr_cpp_rtbinom`, n, size, prob, lower, upper)
 }
 
+cpp_dtnbinom <- function(x, size, prob, lower, upper, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_dtnbinom`, x, size, prob, lower, upper, log_prob)
+}
+
+cpp_dtnbinom_mu <- function(x, size, mu, lower, upper, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_dtnbinom_mu`, x, size, mu, lower, upper, log_prob)
+}
+
+cpp_ptnbinom <- function(x, size, prob, lower, upper, lower_tail = TRUE, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_ptnbinom`, x, size, prob, lower, upper, lower_tail, log_prob)
+}
+
+cpp_ptnbinom_mu <- function(x, size, mu, lower, upper, lower_tail = TRUE, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_ptnbinom_mu`, x, size, mu, lower, upper, lower_tail, log_prob)
+}
+
+cpp_qtnbinom <- function(p, size, prob, lower, upper, lower_tail = TRUE, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_qtnbinom`, p, size, prob, lower, upper, lower_tail, log_prob)
+}
+
+cpp_qtnbinom_mu <- function(p, size, mu, lower, upper, lower_tail = TRUE, log_prob = FALSE) {
+    .Call(`_extraDistr_cpp_qtnbinom_mu`, p, size, mu, lower, upper, lower_tail, log_prob)
+}
+
+cpp_rtnbinom <- function(n, size, prob, lower, upper) {
+    .Call(`_extraDistr_cpp_rtnbinom`, n, size, prob, lower, upper)
+}
+
+cpp_rtnbinom_mu <- function(n, size, mu, lower, upper) {
+    .Call(`_extraDistr_cpp_rtnbinom_mu`, n, size, mu, lower, upper)
+}
+
 cpp_dtnorm <- function(x, mu, sigma, lower, upper, log_prob = FALSE) {
     .Call(`_extraDistr_cpp_dtnorm`, x, mu, sigma, lower, upper, log_prob)
 }

R/truncated-negative-binomial-distribution.R

@@ -0,0 +1,123 @@
+
+
+#' Truncated negative binomial distribution
+#'
+#' Density, distribution function, quantile function and random generation
+#' for the truncated negative binomial distribution.
+#'
+#' @param x,q	            vector of quantiles.
+#' @param p	              vector of probabilities.
+#' @param n	              number of observations. If \code{length(n) > 1},
+#'                        the length is taken to be the number required.
+#' @param size	          target for number of successful trials, or dispersion
+#'                        parameter (the shape parameter of the gamma mixing
+#'                        distribution). Must be strictly positive, need not be
+#'                        integer.
+#' @param prob            probability of success in each trial. \code{0 < prob <= 1}.
+#' @param mu              alternative parameterization via mean
+#' @param a,b             lower and upper truncation points (\code{a < x <= b}).
+#' @param log,log.p	      logical; if TRUE, probabilities p are given as log(p).
+#' @param lower.tail	    logical; if TRUE (default), probabilities are \eqn{P[X \le x]}
+#'                        otherwise, \eqn{P[X > x]}.
+#'
+#' @references
+#' Hilbe, J. (2011). Censored and truncated count models. In 
+#' *Negative Binomial Regression* (pp. 387-406). Cambridge: Cambridge University 
+#' Press. \url{https://doi.org/10.1017/CBO9780511973420.013}
+#' 
+#' @seealso \code{\link[stats]{NegBinomial}}
+#' 
+#' @examples 
+#' 
+#' # Right-truncated negative binomial
+#' ## random sample
+#' x <- rtnbinom(1e5, size = 2, prob = 0.1, b = 25)
+#' plot(prop.table(table(x)))
+#' 
+#' ## distribution
+#' xx <- seq(-1, 30)
+#' lines(xx, dtnbinom(xx, size = 2, prob = 0.1, b = 25), col = "red")
+#' 
+#' hist(ptnbinom(x, size = 2, prob = 0.1, b = 25), breaks = 35)
+#' 
+#' xx <- seq(0, 30, by = 0.01)
+#' plot(ecdf(x))
+#' lines(xx, ptnbinom(xx, size = 2, prob = 0.1, b = 25), col = "red", lwd = 2)
+#' 
+#' uu <- seq(0, 1, by = 0.001)
+#' lines(qtnbinom(uu, size = 2, prob = 0.1, b = 25), uu, col = "blue", lty = 2)
+#' 
+#' # Zero-truncated negative binomial (mu parameterization)
+#' ## random sample
+#' x <- rtnbinom(1e5, size = 2, mu = 5, a = 0)
+#' plot(prop.table(table(x)))
+#' 
+#' ## distribution
+#' xx <- seq(-1, 50)
+#' lines(xx, dtnbinom(xx, size = 2, mu = 5, a = 0), col = "red")
+#' hist(ptnbinom(x, size = 2, mu = 5, a = 0))
+#' 
+#' xx <- seq(0, 50, by = 0.01)
+#' plot(ecdf(x))
+#' lines(xx, ptnbinom(xx, size = 2, mu = 5, a = 0), col = "red", lwd = 2)
+#' lines(qtnbinom(uu, size = 2, mu = 5, a = 0), uu, col = "blue", lty = 2)
+#'
+#' @name TruncNegBinom
+#' @aliases TruncNegBinom
+#' @aliases TruncNB
+#' @aliases dtnbinom
+#' 
+#' @keywords distribution
+#' @concept Univariate
+#' @concept Discrete
+#'
+#' @export
+
+dtnbinom <- function(x, size, prob, mu, a = -Inf, b = Inf, log = FALSE) {
+  if (!missing(mu)) {
+    if(!missing(prob))
+      stop("'prob' and 'mu' both specified")
+    cpp_dtnbinom_mu(x, size, mu, a, b, log)
+  }
+  else cpp_dtnbinom(x, size, prob, a, b, log)
+}
+
+
+#' @rdname TruncNegBinom
+#' @export
+
+ptnbinom <- function(q, size, prob, mu, a = -Inf, b = Inf, lower.tail = TRUE, log.p = FALSE) {
+  if (!missing(mu)) {
+    if(!missing(prob))
+      stop("'prob' and 'mu' both specified")
+    cpp_ptnbinom_mu(q, size, mu, a, b, lower.tail[1L], log.p[1L])
+  }
+  else cpp_ptnbinom(q, size, prob, a, b, lower.tail[1L], log.p[1L])
+}
+
+
+#' @rdname TruncNegBinom
+#' @export
+
+qtnbinom <- function(p, size, prob, mu, a = -Inf, b = Inf, lower.tail = TRUE, log.p = FALSE) {
+  if (!missing(mu)) {
+    if (!missing(prob)) 
+      stop("'prob' and 'mu' both specified")
+    cpp_qtnbinom_mu(p, size, mu, a, b, lower.tail[1L], log.p[1L])
+  }
+  else cpp_qtnbinom(p, size, prob, a, b, lower.tail[1L], log.p[1L])
+}
+
+
+#' @rdname TruncNegBinom
+#' @export
+
+rtnbinom <- function(n, size, prob, mu, a = -Inf, b = Inf) {
+  if (length(n) > 1) n <- length(n)
+  if (!missing(mu)) {
+    if (!missing(prob)) 
+      stop("'prob' and 'mu' both specified")
+    cpp_rtnbinom_mu(n, size, mu, a, b)
+  }
+  else cpp_rtnbinom(n, size, prob, a, b)
+}