truncnorm/0000755000176200001440000000000014406151262012302 5ustar liggesuserstruncnorm/NAMESPACE0000644000176200001440000000025414375011071013520 0ustar liggesusersexport(dtruncnorm) export(ptruncnorm) export(qtruncnorm) export(rtruncnorm) export(etruncnorm) export(vtruncnorm) useDynLib(truncnorm, .registration = TRUE, .fixes = "C_") truncnorm/README.md0000644000176200001440000000105614375011071013561 0ustar liggesusers# truncnorm R package implementing density, probability, quantile and random number generation functions for the truncated normal distribution. ## Install from github Run this in R to install the current GitHub version (requires the `devtools` package): ```splus library("devtools") install_github("olafmersmann/truncnorm") ``` [![CRAN Status Badge](http://www.r-pkg.org/badges/version/truncnorm)](https://cran.r-project.org/package=truncnorm) [![CRAN Downloads](http://cranlogs.r-pkg.org/badges/truncnorm)](https://cran.r-project.org/package=truncnorm) truncnorm/man/0000755000176200001440000000000014375011071013053 5ustar liggesuserstruncnorm/man/dtruncnorm.Rd0000644000176200001440000000456214375011071015544 0ustar liggesusers\name{truncnorm} \alias{dtruncnorm} \alias{ptruncnorm} \alias{qtruncnorm} \alias{rtruncnorm} \alias{etruncnorm} \alias{vtruncnorm} \title{The Truncated Normal Distribution} \description{ Density, distribution function, quantile function, random generation and expected value function for the truncated normal distribution with mean equal to 'mean' and standard deviation equal to 'sd'. } \usage{ dtruncnorm(x, a=-Inf, b=Inf, mean = 0, sd = 1) ptruncnorm(q, a=-Inf, b=Inf, mean = 0, sd = 1) qtruncnorm(p, a=-Inf, b=Inf, mean = 0, sd = 1) rtruncnorm(n, a=-Inf, b=Inf, mean = 0, sd = 1) etruncnorm(a=-Inf, b=Inf, mean=0, sd=1) vtruncnorm(a=-Inf, b=Inf, mean=0, sd=1) } \arguments{ \item{x,q}{vector of quantiles.} \item{p}{vector of probabilites.} \item{n}{number of observations. If 'length(n) > 1', the length is taken to be the number required.} \item{a}{vector of lower bounds. These may be \code{-Inf}} \item{b}{vector of upper bounds. These may be \code{Inf}} \item{mean}{vector of means.} \item{sd}{vector of standard deviations.} } \details{ If \code{mean} or \code{sd} are not specified they assume the default values of \code{0} and \code{1}, respectively. The values of \code{a}, \code{b}, \code{mean} and \code{sd} are recycled as needed. The numerical arguments other than \code{n} are recycled to the length of the result. } \value{ 'dtruncnorm' gives the density, 'ptruncnorm' gives the distribution function, 'qtruncnorm' gives the quantile function, 'rtruncnorm' generates random deviates, 'etruncnorm' gives the expected value and 'vtruncnorm' the variance of the distribution. } \references{ The accept-reject sampler follows the description given in Geweke, J. (1991). \emph{Efficient simulation from the multivariate normal and student-t distributions subject to linear constraints}. In Computing Science and Statistics: Proceedings of the 23rd Symposium on the Interface, Ed. E. Keramidas and S. Kaufman, pp. 571-8. Fairfax Station, VA: Interface Foundation of North America. } \author{ Heike Trautmann \email{trautmann@statistik.tu-dortmund.de}, Detlef Steuer \email{steuer@hsu-hamburg.de}, Olaf Mersmann \email{olafm@statistik.tu-dortmund.de} and Björn Bornkamp \email{bornkamp@statistik.tu-dortmund.de} who donated a much improved \code{rtruncnorm} implementation using an accept-reject sampler. } \keyword{distribution} truncnorm/DESCRIPTION0000644000176200001440000000165714406151262014021 0ustar liggesusersPackage: truncnorm Version: 1.0-9 Title: Truncated Normal Distribution Description: Density, probability, quantile and random number generation functions for the truncated normal distribution. Authors@R: c(person("Olaf", "Mersmann", role=c("aut", "cre"), email="olafm@p-value.net"), person("Heike", "Trautmann", role=c("aut")), person("Detlef", "Steuer", role=c("aut")), person("Björn", "Bornkamp", role=c("aut"))) URL: https://github.com/olafmersmann/truncnorm BugReports: https://github.com/olafmersmann/truncnorm/issues Depends: R (>= 3.4.0) Suggests: testthat License: GPL (>= 2) Encoding: UTF-8 NeedsCompilation: yes Packaged: 2023-03-20 11:15:55 UTC; olafm Author: Olaf Mersmann [aut, cre], Heike Trautmann [aut], Detlef Steuer [aut], Björn Bornkamp [aut] Maintainer: Olaf Mersmann Repository: CRAN Date/Publication: 2023-03-20 21:40:02 UTC truncnorm/tests/0000755000176200001440000000000014375011071013442 5ustar liggesuserstruncnorm/tests/testthat/0000755000176200001440000000000014406151262015304 5ustar liggesuserstruncnorm/tests/testthat/test-bug-zero_len.R0000644000176200001440000000477414375015627021021 0ustar liggesuserscontext("bug-zero_len") test_that("dtruncnorm", { n = numeric(0) expect_equal(dtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(dtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(dtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(dtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(dtruncnorm(0, 0, Inf, 0, n), NULL) n = NULL expect_equal(dtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(dtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(dtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(dtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(dtruncnorm(0, 0, Inf, 0, n), NULL) }) test_that("ptruncnorm", { n = numeric(0) expect_equal(qtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, 0, n), NULL) n = NULL expect_equal(qtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, 0, n), NULL) }) test_that("qtruncnorm", { n = numeric(0) expect_equal(qtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, 0, n), NULL) n = NULL expect_equal(qtruncnorm(n, 0, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, n, Inf, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, n, 0, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, n, 1), NULL) expect_equal(qtruncnorm(0, 0, Inf, 0, n), NULL) }) test_that("etruncnorm", { n = numeric(0) expect_equal(etruncnorm(n, Inf, 0, 1), NULL) expect_equal(etruncnorm(0, n, 0, 1), NULL) expect_equal(etruncnorm(0, Inf, n, 1), NULL) expect_equal(etruncnorm(0, Inf, 0, n), NULL) n = NULL expect_equal(etruncnorm(n, Inf, 0, 1), NULL) expect_equal(etruncnorm(0, n, 0, 1), NULL) expect_equal(etruncnorm(0, Inf, n, 1), NULL) expect_equal(etruncnorm(0, Inf, 0, n), NULL) }) test_that("vtruncnorm", { n = numeric(0) expect_equal(vtruncnorm(n, Inf, 0, 1), NULL) expect_equal(vtruncnorm(0, n, 0, 1), NULL) expect_equal(vtruncnorm(0, Inf, n, 1), NULL) expect_equal(vtruncnorm(0, Inf, 0, n), NULL) n = NULL expect_equal(vtruncnorm(n, Inf, 0, 1), NULL) expect_equal(vtruncnorm(0, n, 0, 1), NULL) expect_equal(vtruncnorm(0, Inf, n, 1), NULL) expect_equal(vtruncnorm(0, Inf, 0, n), NULL) }) truncnorm/tests/testthat/test-reg-arg_checks.R0000644000176200001440000000011014375011071021236 0ustar liggesusers## ## Check arguments for length and type ## context("reg-arg_checks") truncnorm/tests/testthat/test-reg-recylce.R0000644000176200001440000000160414375011071020604 0ustar liggesuserscontext("reg-recycle") test_that("recylcing x in dtruncnorm", { means <- c(-1, 0, 1) x <- 1 r1 <- dtruncnorm(x, 0, Inf, means, 1) expect_equal(r1[1], dtruncnorm(x, 0, Inf, means[1], 1)) expect_equal(r1[2], dtruncnorm(x, 0, Inf, means[2], 1)) expect_equal(r1[3], dtruncnorm(x, 0, Inf, means[3], 1)) }) test_that("recylcing p in ptruncnorm", { means <- c(-1, 0, 1) q <- 0.5 r1 <- ptruncnorm(q, 0, Inf, means, 1) expect_equal(r1[1], ptruncnorm(q, 0, Inf, means[1], 1)) expect_equal(r1[2], ptruncnorm(q, 0, Inf, means[2], 1)) expect_equal(r1[3], ptruncnorm(q, 0, Inf, means[3], 1)) }) test_that("recylcing p in qtruncnorm", { means <- c(-1, 0, 1) p <- 0.5 r1 <- qtruncnorm(p, 0, Inf, means, 1) expect_equal(r1[1], qtruncnorm(p, 0, Inf, means[1], 1)) expect_equal(r1[2], qtruncnorm(p, 0, Inf, means[2], 1)) expect_equal(r1[3], qtruncnorm(p, 0, Inf, means[3], 1)) }) truncnorm/tests/testthat/test-reg-segfault.R0000644000176200001440000000036714375011071020775 0ustar liggesusers## ## Don't segfault! ## context("reg-segfault") expect_error(rtruncnorm(1, numeric(0), 1, 0, 1)) expect_error(rtruncnorm(1, 0, numeric(0), 0, 1)) expect_error(rtruncnorm(1, 0, 1, numeric(0), 1)) expect_error(rtruncnorm(1, 0, 1, 0, numeric(0))) truncnorm/tests/testthat/test-sanity_checks.R0000644000176200001440000001004114406023531021224 0ustar liggesuserscontext("sanity checks") ################################################################################ ## Check d/e/vtruncnorm all in one function: check_dev <- function(a, b, mean=0, sd=1) { prefix <- sprintf("DEV: a=%f, b=%f, mean=%f, sd=%f", a, b, mean, sd) e <- etruncnorm(a, b, mean, sd) v <- vtruncnorm(a, b, mean, sd) id <- integrate(function(x) dtruncnorm(x, a, b, mean, sd), a, b)$value ee <- integrate(function(x) x * dtruncnorm(x, a, b, mean, sd), a, b)$value ev <- integrate(function(x) (x-ee)^2 * dtruncnorm(x, a, b, mean, sd), a, b)$value test_that(prefix, { expect_equal(id, 1.0, tolerance=0.00005) expect_equal(e, ee, tolerance=0.00005) expect_equal(v, ev, tolerance=0.00005) }) } ## Left truncated: check_dev(-3, Inf, 0, 1) check_dev(-2, Inf, 1, 1) check_dev( 2, Inf, 0, 1) check_dev( 3, Inf, 1, 1) check_dev(-3, Inf, 0, 2) check_dev(-2, Inf, 1, 2) check_dev( 2, Inf, 0, 2) check_dev( 3, Inf, 1, 2) ## Doubly truncated: check_dev(-3.0, -2.5, 0, 1) check_dev(-3.0, -1.5, 0, 1) check_dev(-3.0, -0.5, 0, 1) check_dev(-3.0, 0.5, 0, 1) check_dev(0.0, 0.5, 0, 1) check_dev(0.0, 1.5, 0, 1) check_dev(0.0, 2.5, 0, 1) check_dev(0.0, 3.5, 0, 1) ## Extreme cases: check_dev( 0.0, 1.0, 0.0, 10.0) check_dev( 0.0, 1.0, 5.0, 1.0) check_dev(-1.0, 0.0, 0.0, 10.0) check_dev( 0.0, 1.0, -5.0, 1.0) check_dev( 0.0, 1.0, 5.0, 0.1) ## Integer arguments: check_dev(0L, 1L, 0L, 10L) ################################################################################ ## Sanity checks on random number generators check_r <- function(a, b, mean, sd, n=10000) { prefix <- sprintf("R: a=%f, b=%f, mean=%f, sd=%f", a, b, mean, sd) x <- rtruncnorm(n, a, b, mean, sd) e.x <- mean(x) e <- etruncnorm(a, b, mean, sd) true_sd <- sqrt(vtruncnorm(a, b, mean, sd)) ## FIXME: Really sample from open intervall? test_that(prefix, { expect_true(all(x > a)) expect_true(all(x < b)) expect_equal(mean(x), e, tolerance=0.05, scale=sd) expect_equal(sd(x), true_sd, tolerance=0.05, scale=sd) }) } ## rtruncnorm == rnorm: check_r(-Inf, Inf, 0, 1) ## 0 in (a, b): check_r(-1, 1, 0, 1) check_r(-1, 1, 1, 1) check_r(-1, 1, 0, 2) ## 0 < (a, b): check_r(1, 2, 0, 1) check_r(1, 2, 1, 1) check_r(1, 2, 0, 2) ## 0 > (a, b): check_r(-2, -1, 0, 1) check_r(-2, -1, 1, 1) check_r(-2, -1, 0, 2) ## left truncation: check_r(-2, Inf, 0, 1) check_r(-2, Inf, 1, 1) check_r(-2, Inf, 0, 2) check_r( 0, Inf, 0, 1) check_r( 0, Inf, 1, 1) check_r( 0, Inf, 0, 2) check_r( 2, Inf, 0, 1) check_r( 2, Inf, 1, 1) check_r( 2, Inf, 0, 2) check_r(-0.2, Inf, 0, 1) check_r(-0.2, Inf, 1, 1) check_r(-0.2, Inf, 0, 2) check_r( 0.0, Inf, 0, 1) check_r( 0.0, Inf, 1, 1) check_r( 0.0, Inf, 0, 2) check_r( 0.2, Inf, 0, 1) check_r( 0.2, Inf, 1, 1) check_r( 0.2, Inf, 0, 2) ## Right truncation: check_r(-Inf, -2, 0, 1) check_r(-Inf, -2, 1, 1) check_r(-Inf, -2, 0, 2) check_r(-Inf, 0, 0, 1) check_r(-Inf, 0, 1, 1) check_r(-Inf, 0, 0, 2) check_r(-Inf, 2, 0, 1) check_r(-Inf, 2, 1, 1) check_r(-Inf, 2, 0, 2) check_r(-Inf, -0.2, 0, 1) check_r(-Inf, -0.2, 1, 1) check_r(-Inf, -0.2, 0, 2) check_r(-Inf, 0.0, 0, 1) check_r(-Inf, 0.0, 1, 1) check_r(-Inf, 0.0, 0, 2) check_r(-Inf, 0.2, 0, 1) check_r(-Inf, 0.2, 1, 1) check_r(-Inf, 0.2, 0, 2) ## Extreme examples: check_r(-5, -4, 0, 1) ## Integer examples: check_r(-5L, -4L, 0L, 1L) ################################################################################ check_pq <- function(a, b, mean, sd) { prefix <- sprintf("PQ: a=%f, b=%f, mean=%f, sd=%f", a, b, mean, sd) test_that(prefix, { for (p in runif(500)) { q <- qtruncnorm(p, a, b, mean, sd) pp <- ptruncnorm(q, a, b, mean, sd) expect_equal(pp, p, tolerance=0.00001) } }) } check_pq(-1, 0, 0, 1) check_pq(-1, 1, 0, 1) check_pq( 1, 2, 0, 1) check_pq(-1, 0, 4, 1) check_pq(-1, 1, 4, 1) check_pq( 1, 2, 4, 1) check_pq(-1, 0, 0, 3) check_pq(-1, 1, 0, 3) check_pq( 1, 2, 0, 3) check_pq(-1, Inf, 0, 1) check_pq(-1, Inf, 4, 1) check_pq(-1, Inf, 0, 3) check_pq(-Inf, 1, 0, 1) check_pq(-Inf, 1, 4, 1) check_pq(-Inf, 1, 0, 3) ## Integer examples: check_pq(1L, 2L, 0L, 3L) truncnorm/tests/testthat.R0000644000176200001440000000006314375011071015424 0ustar liggesusersif (require("testthat")) test_check("truncnorm") truncnorm/src/0000755000176200001440000000000014406040153013065 5ustar liggesuserstruncnorm/src/exports.c0000644000176200001440000000171714375011071014745 0ustar liggesusers#include #include #include #include #include #include // optional #define CALLDEF(name, n) {#name, (DL_FUNC) &name, n} extern SEXP do_dtruncnorm(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP do_ptruncnorm(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP do_qtruncnorm(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP do_rtruncnorm(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP do_etruncnorm(SEXP, SEXP, SEXP, SEXP); extern SEXP do_vtruncnorm(SEXP, SEXP, SEXP, SEXP); static const R_CallMethodDef R_CallDef[] = { CALLDEF(do_dtruncnorm, 5), CALLDEF(do_ptruncnorm, 5), CALLDEF(do_qtruncnorm, 5), CALLDEF(do_rtruncnorm, 5), CALLDEF(do_etruncnorm, 4), CALLDEF(do_vtruncnorm, 4), {NULL, NULL, 0} }; void attribute_visible R_init_truncnorm(DllInfo *dll) { R_registerRoutines(dll, NULL, R_CallDef, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } truncnorm/src/zeroin.h0000644000176200001440000000067414375011071014555 0ustar liggesusers#ifndef __zeroin_h__ #define __zeroin_h__ double truncnorm_zeroin( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double fa, double fb, /* f(a), f(b) */ double (*f)(double x, void *info), /* Function under investigation */ void *info, /* Add'l info passed on to f */ double *Tol, /* Acceptable tolerance */ int *Maxit); #endif truncnorm/src/sexp_macros.h0000644000176200001440000000336614375011071015573 0ustar liggesusers/* * sexp_macros.h - helper macros for SEXPs * * Collection of useful macros to handle S expressions. Most of these * are used to unpack arguments passed in via the .Call() or * .External() interface. * * Author: * Olaf Mersmann (OME) */ #if !defined(__SEXP_MACROS_H__) #define __SEXP_MACROS_H__ #include #include #define CHECK_ARG_IS_REAL_MATRIX(A) \ if (!isReal(A) || !isMatrix(A)) \ error("Argument '" #A "' is not a real matrix."); #define CHECK_ARG_IS_REAL_VECTOR(A) \ if (!isReal(A) || !isVector(A)) \ error("Argument '" #A "' is not a real vector."); #define CHECK_ARG_IS_INT_VECTOR(A) \ if (!isInteger(A) || !isVector(A)) \ error("Argument '" #A "' is not an integer vector."); /* * Unpack a real matrix stored in SEXP S. */ #define UNPACK_REAL_MATRIX(S, D, N, K) \ CHECK_ARG_IS_REAL_MATRIX(S); \ double *D = REAL(S); \ const R_len_t N = nrows(S); \ const R_len_t K = ncols(S); /* * Unpack a real vector stored in SEXP S. */ #define UNPACK_REAL_VECTOR(S, D, N) \ CHECK_ARG_IS_REAL_VECTOR(S); \ double *D = REAL(S); \ const R_len_t N = length(S); /* * Unpack a single real stored in SEXP S. */ #define UNPACK_REAL(S, D) \ CHECK_ARG_IS_REAL_VECTOR(S); \ double D = REAL(S)[0]; \ /* * Unpack an integer vector stored in SEXP S. */ #define UNPACK_INT_VECTOR(S, I, N) \ CHECK_ARG_IS_INT_VECTOR(S); \ int *I = INTEGER(S); \ const R_len_t N = length(S); /* * Unpack a single integer stored in SEXP S. */ #define UNPACK_INT(S, I) \ CHECK_ARG_IS_INT_VECTOR(S); \ int I = INTEGER(S)[0]; \ #endif truncnorm/src/truncnorm.c0000644000176200001440000002622114375014226015272 0ustar liggesusers/* * truncnorm.c - Implementation of truncated normal distribution * * Authors: * Heike Trautmann * Detlef Steuer * Olaf Mersmann */ #include #include #include #include #include "sexp_macros.h" #include "zeroin.h" #define ALLOC_REAL_VECTOR(S, D, N) \ SEXP S; \ PROTECT(S = allocVector(REALSXP, N)); \ double *D = REAL(S); #ifndef MAX #define MAX(A, B) ((A > B) ? (A) : (B)) #endif #ifndef MIN #define MIN(A, B) ((A < B) ? (A) : (B)) #endif /* * These routines calculate the expected value and variance of the * left, right and doubly truncated normal distribution. The only * tricky bit is the calculation of the variance of the doubly * truncated normal distribution. We use a decompostion of the * variance of a mixture of distributions to here for numerical * reasons. For details see: * * Foulley JL. A completion simulator for the two-sided truncated * normal distribution. Genetics, selection, evolution 2000 * Nov-Dec;32(6): p. 631-635. */ static R_INLINE double e_lefttruncnorm(double a, double mean, double sd) { const double alpha = (a - mean) / sd; const double phi_a = dnorm(alpha, 0.0, 1.0, TRUE); const double Phi_a = pnorm(alpha, 0.0, 1.0, FALSE, TRUE); double res = mean + sd * exp(phi_a - Phi_a); return res; } static R_INLINE double e_truncnorm(double a, double b, double mean, double sd) { /* Special case numerically instable case when (a, b) is far away from the * center of mass. */ if (b < mean - 6.0 * sd || a > mean + 6.0 * sd) return (a + b) / 2.0; double delta_phi = 0.0, delta_Phi = 0.0; const double alpha = (a - mean) / sd; const double beta = (b - mean) / sd; const double phi_a = dnorm(alpha, 0.0, 1.0, TRUE); const double Phi_a = pnorm(alpha, 0.0, 1.0, TRUE, TRUE); const double phi_b = dnorm(beta, 0.0, 1.0, TRUE); const double Phi_b = pnorm(beta, 0.0, 1.0, TRUE, TRUE); if (phi_b < phi_a) { delta_phi = logspace_sub(phi_a, phi_b); } else { sd = -sd; delta_phi = logspace_sub(phi_b, phi_a); } if (Phi_b > Phi_a) { sd = -sd; delta_Phi = logspace_sub(Phi_b, Phi_a); } else { delta_Phi = logspace_sub(Phi_a, Phi_b); } return mean + sd * -exp(delta_phi - delta_Phi); } static R_INLINE double e_righttruncnorm(double b, double mean, double sd) { const double beta = (b - mean) / sd; const double phi_b = dnorm(beta, 0.0, 1.0, TRUE); const double Phi_b = pnorm(beta, 0.0, 1.0, TRUE, TRUE); return mean + sd * -exp(phi_b - Phi_b); } static R_INLINE double v_lefttruncnorm(double a, double mean, double sd) { const double alpha = (a - mean) / sd; const double phi_a = dnorm(alpha, 0.0, 1.0, FALSE); const double Phi_a = pnorm(alpha, 0.0, 1.0, TRUE, FALSE); const double lambda = phi_a / (1.0 - Phi_a); return (sd * sd * (1.0 - lambda * (lambda - alpha))); } static R_INLINE double v_righttruncnorm(double b, double mean, double sd) { return (v_lefttruncnorm(-b, -mean, sd)); } static R_INLINE double v_truncnorm(double a, double b, double mean, double sd) { /* Special case numerically instable cases. These arise when (a, b) is far * away from mean +/- 6*sd */ if (b < mean - 6.0 * sd || a > mean + 6.0 * sd) return 1.0 / 12 * (b - a) * (b - a); const double v = sd * sd; const double pi1 = pnorm(a, mean, sd, TRUE, FALSE); const double pi2 = pnorm(b, mean, sd, TRUE, FALSE) - pnorm(a, mean, sd, TRUE, FALSE); const double pi3 = pnorm(b, mean, sd, FALSE, FALSE); /* 1 - F(b) */ const double e1 = e_righttruncnorm(a, mean, sd); const double e2 = e_truncnorm(a, b, mean, sd); const double e3 = e_lefttruncnorm(b, mean, sd); const double v1 = v_righttruncnorm(a, mean, sd); const double v3 = v_lefttruncnorm(b, mean, sd); const double c1 = pi1 * (v1 + (e1 - mean) * (e1 - mean)); const double c3 = pi3 * (v3 + (e3 - mean) * (e3 - mean)); const double cd = pi2 - (e2 - mean) * (e2 - mean); return (v - c1 - c3) / pi2 - (e2 - mean) * (e2 - mean); } static R_INLINE double ptruncnorm(const double q, const double a, const double b, const double mean, const double sd) { if (q < a) { return 0.0; } else if (q > b) { return 1.0; } else { const double c1 = pnorm(q, mean, sd, TRUE, FALSE); const double c2 = pnorm(a, mean, sd, TRUE, FALSE); const double c3 = pnorm(b, mean, sd, TRUE, FALSE); return (c1 - c2) / (c3 - c2); } } typedef struct { double a, b, mean, sd, p; } qtn; /* qtmin - helper function to calculate quantiles of the truncated * normal distribution. * * The root of this function is the desired quantile, given that *p * defines a truncated normal distribution and the desired * quantile. This function increases monotonically in x and is * positive for x=a and negative for x=b if 0 < p < 1. */ double qtmin(double x, void *p) { qtn *t = (qtn *)p; return ptruncnorm(x, t->a, t->b, t->mean, t->sd) - t->p; } SEXP do_dtruncnorm(SEXP s_x, SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, n; UNPACK_REAL_VECTOR(s_x, x, n_x); UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); n = MIN(MIN(MIN(n_x, n_a), MIN(n_b, n_mean)), n_sd); if (n == 0) { return R_NilValue; } n = MAX(MAX(MAX(n_x, n_a), MAX(n_b, n_mean)), n_sd); ALLOC_REAL_VECTOR(s_ret, ret, n); for (i = 0; i < n; ++i) { const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cx = x[i % n_x]; if (ca <= cx && cx <= cb) { /* In range: */ const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; const double c1 = pnorm(ca, cmean, csd, TRUE, FALSE); const double c2 = pnorm(cb, cmean, csd, TRUE, FALSE); const double c3 = csd * (c2 - c1); const double c4 = dnorm((cx - cmean) / csd, 0.0, 1.0, TRUE); if (!isfinite(log(c3))) { ret[i] = 1.0 / (cb - ca); } else { ret[i] = exp(c4 - log(c3)); } } else { /* Truncated: */ ret[i] = 0.0; } R_CheckUserInterrupt(); } UNPROTECT(1); /* s_ret */ return s_ret; } SEXP do_ptruncnorm(SEXP s_q, SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, n; UNPACK_REAL_VECTOR(s_q, q, n_q); UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); n = MIN(MIN(MIN(n_q, n_a), MIN(n_b, n_mean)), n_sd); if (n == 0) { return R_NilValue; } n = MAX(MAX(MAX(n_q, n_a), MAX(n_b, n_mean)), n_sd); ALLOC_REAL_VECTOR(s_ret, ret, n); for (i = 0; i < n; ++i) { const double cq = q[i % n_q]; const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; ret[i] = ptruncnorm(cq, ca, cb, cmean, csd); R_CheckUserInterrupt(); } UNPROTECT(1); /* s_ret */ return s_ret; } SEXP do_qtruncnorm(SEXP s_p, SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, n; qtn t; double tol; int maxit; UNPACK_REAL_VECTOR(s_p, p, n_p); UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); n = MIN(MIN(MIN(n_p, n_a), MIN(n_b, n_mean)), n_sd); if (n == 0) { return R_NilValue; } n = MAX(MAX(MAX(n_p, n_a), MAX(n_b, n_mean)), n_sd); ALLOC_REAL_VECTOR(s_ret, ret, n); for (i = 0; i < n; ++i) { const double cp = p[i % n_p]; const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; if (cp == 0.0) { ret[i] = ca; } else if (cp == 1.0) { ret[i] = cb; } else if (cp < 0.0 || cp > 1.0) { ret[i] = R_NaN; } else if (ca == R_NegInf && cb == R_PosInf) { ret[i] = qnorm(cp, cmean, csd, TRUE, FALSE); } else { /* We need to possible adjust ca and cb for R_zeroin(), * because R_zeroin() requires finite bounds and ca or cb (but * not both, see above) may be infinite. In that case, we use * a simple stepping out procedure to find a lower or upper * bound from which to begin the search. */ double lower = ca, upper = cb; if (lower == R_NegInf) { lower = -1; while (ptruncnorm(lower, ca, cb, cmean, csd) - cp >= 0) lower *= 2.0; } else if (upper == R_PosInf) { upper = 1; while (ptruncnorm(upper, ca, cb, cmean, csd) - cp <= 0) upper *= 2.0; } t.a = ca; t.b = cb; t.mean = cmean; t.sd = csd; t.p = cp; maxit = 200; tol = 0.0; /* Set tolerance! */ ret[i] = truncnorm_zeroin(lower, upper, qtmin(lower, &t), qtmin(upper, &t), &qtmin, &t, &tol, &maxit); } R_CheckUserInterrupt(); } UNPROTECT(1); /* s_ret */ return s_ret; } SEXP do_etruncnorm(SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, n; UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); n = MIN(MIN(n_a, n_b), MIN(n_mean, n_sd)); if (n == 0) { return R_NilValue; } n = MAX(MAX(n_a, n_b), MAX(n_mean, n_sd)); ALLOC_REAL_VECTOR(s_ret, ret, n); for (i = 0; i < n; ++i) { const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; if (R_FINITE(ca) && R_FINITE(cb)) { ret[i] = e_truncnorm(ca, cb, cmean, csd); } else if (R_NegInf == ca && R_FINITE(cb)) { ret[i] = e_righttruncnorm(cb, cmean, csd); } else if (R_FINITE(ca) && R_PosInf == cb) { ret[i] = e_lefttruncnorm(ca, cmean, csd); } else if (R_NegInf == ca && R_PosInf == cb) { ret[i] = cmean; } else { ret[i] = NA_REAL; } R_CheckUserInterrupt(); } UNPROTECT(1); /* s_ret */ return s_ret; } SEXP do_vtruncnorm(SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, n; UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); n = MIN(MIN(n_a, n_b), MIN(n_mean, n_sd)); if (n == 0) { return R_NilValue; } n = MAX(MAX(n_a, n_b), MAX(n_mean, n_sd)); ALLOC_REAL_VECTOR(s_ret, ret, n); for (i = 0; i < n; ++i) { const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; if (R_FINITE(ca) && R_FINITE(cb)) { ret[i] = v_truncnorm(ca, cb, cmean, csd); } else if (R_NegInf == ca && R_FINITE(cb)) { ret[i] = v_righttruncnorm(cb, cmean, csd); } else if (R_FINITE(ca) && R_PosInf == cb) { ret[i] = v_lefttruncnorm(ca, cmean, csd); } else if (R_NegInf == ca && R_PosInf == cb) { ret[i] = csd * csd; } else { ret[i] = NA_REAL; } R_CheckUserInterrupt(); } UNPROTECT(1); /* s_ret */ return s_ret; } truncnorm/src/zeroin.c0000644000176200001440000001557514375011071014556 0ustar liggesusers/* This code was taken from the main R distribution. */ /* * R : A Computer Language for Statistical Data Analysis * Copyright (C) 1999, 2001 the R Core Team * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, a copy is available at * http://www.r-project.org/Licenses/ */ /* from NETLIB c/brent.shar with max.iter, add'l info and convergence details hacked in by Peter Dalgaard */ /************************************************************************* * C math library * function ZEROIN - obtain a function zero within the given range * * Input * double zeroin(ax,bx,f,info,Tol,Maxit) * double ax; Root will be seeked for within * double bx; a range [ax,bx] * double (*f)(double x, void *info); Name of the function whose zero * will be seeked for * void *info; Add'l info passed to f * double *Tol; Acceptable tolerance for the root * value. * May be specified as 0.0 to cause * the program to find the root as * accurate as possible * * int *Maxit; Max. iterations * * * Output * Zeroin returns an estimate for the root with accuracy * 4*EPSILON*abs(x) + tol * *Tol returns estimated precision * *Maxit returns actual # of iterations, or -1 if maxit was * reached without convergence. * * Algorithm * G.Forsythe, M.Malcolm, C.Moler, Computer methods for mathematical * computations. M., Mir, 1980, p.180 of the Russian edition * * The function makes use of the bisection procedure combined with * the linear or quadric inverse interpolation. * At every step program operates on three abscissae - a, b, and c. * b - the last and the best approximation to the root * a - the last but one approximation * c - the last but one or even earlier approximation than a that * 1) |f(b)| <= |f(c)| * 2) f(b) and f(c) have opposite signs, i.e. b and c confine * the root * At every step Zeroin selects one of the two new approximations, the * former being obtained by the bisection procedure and the latter * resulting in the interpolation (if a,b, and c are all different * the quadric interpolation is utilized, otherwise the linear one). * If the latter (i.e. obtained by the interpolation) point is * reasonable (i.e. lies within the current interval [b,c] not being * too close to the boundaries) it is accepted. The bisection result * is used in the other case. Therefore, the range of uncertainty is * ensured to be reduced at least by the factor 1.6 */ #include #include #define EPSILON DBL_EPSILON double truncnorm_zeroin( /* An estimate of the root */ double ax, /* Left border | of the range */ double bx, /* Right border| the root is seeked*/ double fa, double fb, /* f(a), f(b) */ double (*f)( double x, void *info), /* Function under investigation */ void *info, /* Add'l info passed on to f */ double *Tol, /* Acceptable tolerance */ int *Maxit) /* Max # of iterations */ { double a, b, c, fc; /* Abscissae, descr. see above, f(c) */ double tol; int maxit; a = ax; b = bx; c = a; fc = fa; maxit = *Maxit + 1; tol = *Tol; /* First test if we have found a root at an endpoint */ if (fa == 0.0) { *Tol = 0.0; *Maxit = 0; return a; } if (fb == 0.0) { *Tol = 0.0; *Maxit = 0; return b; } while (maxit--) /* Main iteration loop */ { double prev_step = b - a; /* Distance from the last but one to the last approximation */ double tol_act; /* Actual tolerance */ double p; /* Interpolation step is calcu- */ double q; /* lated in the form p/q; divi- * sion operations is delayed * until the last moment */ double new_step; /* Step at this iteration */ if (fabs(fc) < fabs(fb)) { /* Swap data for b to be the */ a = b; b = c; c = a; /* best approximation */ fa = fb; fb = fc; fc = fa; } tol_act = 2 * EPSILON * fabs(b) + tol / 2; new_step = (c - b) / 2; if (fabs(new_step) <= tol_act || fb == (double)0) { *Maxit -= maxit; *Tol = fabs(c - b); return b; /* Acceptable approx. is found */ } /* Decide if the interpolation can be tried */ if (fabs(prev_step) >= tol_act /* If prev_step was large enough*/ && fabs(fa) > fabs(fb)) { /* and was in true direction, * Interpolation may be tried */ register double t1, cb, t2; cb = c - b; if (a == c) { /* If we have only two distinct */ /* points linear interpolation */ t1 = fb / fa; /* can only be applied */ p = cb * t1; q = 1.0 - t1; } else { /* Quadric inverse interpolation*/ q = fa / fc; t1 = fb / fc; t2 = fb / fa; p = t2 * (cb * q * (q - t1) - (b - a) * (t1 - 1.0)); q = (q - 1.0) * (t1 - 1.0) * (t2 - 1.0); } if (p > (double)0) /* p was calculated with the */ q = -q; /* opposite sign; make p positive */ else /* and assign possible minus to */ p = -p; /* q */ if (p < (0.75 * cb * q - fabs(tol_act * q) / 2) /* If b+p/q falls in [b,c]*/ && p < fabs(prev_step * q / 2)) /* and isn't too large */ new_step = p / q; /* it is accepted * If p/q is too large then the * bisection procedure can * reduce [b,c] range to more * extent */ } if (fabs(new_step) < tol_act) { /* Adjust the step to be not less*/ if (new_step > (double)0) /* than tolerance */ new_step = tol_act; else new_step = -tol_act; } a = b; fa = fb; /* Save the previous approx. */ b += new_step; fb = (*f)(b, info); /* Do step to a new approxim. */ if ((fb > 0 && fc > 0) || (fb < 0 && fc < 0)) { /* Adjust c for it to have a sign opposite to that of b */ c = a; fc = fa; } } /* failed! */ *Tol = fabs(c - b); *Maxit = -1; return b; } truncnorm/src/rtruncnorm.c0000644000176200001440000001270714375011071015453 0ustar liggesusers/* * rtruncnorm.c - Random truncated normal number generator. * * Authors: * Björn Bornkamp * Olaf Mersmann */ #include #include #include #include #include #include #include "sexp_macros.h" #define ALLOC_REAL_VECTOR(S, D, N) \ SEXP S; \ PROTECT(S = allocVector(REALSXP, N)); \ double *D = REAL(S); #ifndef MAX #define MAX(A, B) ((A > B) ? (A) : (B)) #endif #include #include #include #include #include #include #include #ifdef DEBUG #define SAMPLER_DEBUG(N, A, B) Rprintf("%8s(%f, %f)\n", N, A, B) #else #define SAMPLER_DEBUG(N, A, B) #endif static const double t1 = 0.15; static const double t2 = 2.18; static const double t3 = 0.725; static const double t4 = 0.45; /* Exponential rejection sampling (a,inf) */ static R_INLINE double ers_a_inf(double a) { SAMPLER_DEBUG("ers_a_inf", a, R_PosInf); const double ainv = 1.0 / a; double x, rho; do { x = rexp(ainv) + a; /* rexp works with 1/lambda */ rho = exp(-0.5 * pow((x - a), 2)); } while (runif(0, 1) > rho); return x; } /* Exponential rejection sampling (a,b) */ static R_INLINE double ers_a_b(double a, double b) { SAMPLER_DEBUG("ers_a_b", a, b); const double ainv = 1.0 / a; double x, rho; do { x = rexp(ainv) + a; /* rexp works with 1/lambda */ rho = exp(-0.5 * pow((x - a), 2)); } while (runif(0, 1) > rho || x > b); return x; } /* Normal rejection sampling (a,b) */ static R_INLINE double nrs_a_b(double a, double b) { SAMPLER_DEBUG("nrs_a_b", a, b); double x = -DBL_MAX; while (x < a || x > b) { x = rnorm(0, 1); } return x; } /* Normal rejection sampling (a,inf) */ static R_INLINE double nrs_a_inf(double a) { SAMPLER_DEBUG("nrs_a_inf", a, R_PosInf); double x = -DBL_MAX; while (x < a) { x = rnorm(0, 1); } return x; } /* Half-normal rejection sampling */ double hnrs_a_b(double a, double b) { SAMPLER_DEBUG("hnrs_a_b", a, b); double x = a - 1.0; while (x < a || x > b) { x = rnorm(0, 1); x = fabs(x); } return x; } /* Uniform rejection sampling */ static R_INLINE double urs_a_b(double a, double b) { SAMPLER_DEBUG("urs_a_b", a, b); const double phi_a = dnorm(a, 0.0, 1.0, FALSE); double x = 0.0, u = 0.0; /* Upper bound of normal density on [a, b] */ const double ub = a < 0 && b > 0 ? M_1_SQRT_2PI : phi_a; do { x = runif(a, b); } while (runif(0, 1) * ub > dnorm(x, 0, 1, 0)); return x; } /* Previously this was refered to as type 1 sampling: */ static inline double r_lefttruncnorm(double a, double mean, double sd) { const double alpha = (a - mean) / sd; if (alpha < t4) { return mean + sd * nrs_a_inf(alpha); } else { return mean + sd * ers_a_inf(alpha); } } static R_INLINE double r_righttruncnorm(double b, double mean, double sd) { const double beta = (b - mean) / sd; /* Exploit symmetry: */ return mean - sd * r_lefttruncnorm(-beta, 0.0, 1.0); } static R_INLINE double r_truncnorm(double a, double b, double mean, double sd) { const double alpha = (a - mean) / sd; const double beta = (b - mean) / sd; const double phi_a = dnorm(alpha, 0.0, 1.0, FALSE); const double phi_b = dnorm(beta, 0.0, 1.0, FALSE); if (beta <= alpha) { return NA_REAL; } else if (alpha <= 0 && 0 <= beta) { /* 2 */ if (phi_a <= t1 || phi_b <= t1) { /* 2 (a) */ return mean + sd * nrs_a_b(alpha, beta); } else { /* 2 (b) */ return mean + sd * urs_a_b(alpha, beta); } } else if (alpha > 0) { /* 3 */ if (phi_a / phi_b <= t2) { /* 3 (a) */ return mean + sd * urs_a_b(alpha, beta); } else { if (alpha < t3) { /* 3 (b) */ return mean + sd * hnrs_a_b(alpha, beta); } else { /* 3 (c) */ return mean + sd * ers_a_b(alpha, beta); } } } else { /* 3s */ if (phi_b / phi_a <= t2) { /* 3s (a) */ return mean - sd * urs_a_b(-beta, -alpha); } else { if (beta > -t3) { /* 3s (b) */ return mean - sd * hnrs_a_b(-beta, -alpha); } else { /* 3s (c) */ return mean - sd * ers_a_b(-beta, -alpha); } } } } SEXP do_rtruncnorm(SEXP s_n, SEXP s_a, SEXP s_b, SEXP s_mean, SEXP s_sd) { R_len_t i, nn; UNPACK_INT(s_n, n); if (NA_INTEGER == n) error("n is NA - aborting."); UNPACK_REAL_VECTOR(s_a, a, n_a); UNPACK_REAL_VECTOR(s_b, b, n_b); UNPACK_REAL_VECTOR(s_mean, mean, n_mean); UNPACK_REAL_VECTOR(s_sd, sd, n_sd); nn = MAX(n, MAX(MAX(n_a, n_b), MAX(n_mean, n_sd))); ALLOC_REAL_VECTOR(s_ret, ret, nn); GetRNGstate(); for (i = 0; i < nn; ++i) { const double ca = a[i % n_a]; const double cb = b[i % n_b]; const double cmean = mean[i % n_mean]; const double csd = sd[i % n_sd]; if (R_FINITE(ca) && R_FINITE(cb)) { ret[i] = r_truncnorm(ca, cb, cmean, csd); } else if (R_NegInf == ca && R_FINITE(cb)) { ret[i] = r_righttruncnorm(cb, cmean, csd); } else if (R_FINITE(ca) && R_PosInf == cb) { ret[i] = r_lefttruncnorm(ca, cmean, csd); } else if (R_NegInf == ca && R_PosInf == cb) { ret[i] = rnorm(cmean, csd); } else { ret[i] = NA_REAL; } R_CheckUserInterrupt(); } PutRNGstate(); UNPROTECT(1); /* s_ret */ return s_ret; } truncnorm/R/0000755000176200001440000000000014406032470012502 5ustar liggesuserstruncnorm/R/truncnorm.R0000644000176200001440000000266014406032470014660 0ustar liggesusers## ## truncnorm.R - Interface to truncnorm.c ## ## Authors: ## Heike Trautmann ## Detlef Steuer ## Olaf Mersmann ## dtruncnorm <- function(x, a=-Inf, b=Inf, mean=0, sd=1) .Call(C_do_dtruncnorm, as.numeric(x), as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) ptruncnorm <- function(q, a=-Inf, b=Inf, mean=0, sd=1) .Call(C_do_ptruncnorm, as.numeric(q), as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) qtruncnorm <- function(p, a=-Inf, b=Inf, mean=0, sd=1) .Call(C_do_qtruncnorm, as.numeric(p), as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) rtruncnorm <- function(n, a=-Inf, b=Inf, mean=0, sd=1) { stopifnot(length(a) > 0, length(b) > 0, length(mean) > 0, length(sd) > 0) if (length(n) > 1) n <- length(n) else if (!is.numeric(n)) stop("non-numeric argument n.") else if (n == 0) return(NULL) .Call(C_do_rtruncnorm, as.integer(n), as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) } etruncnorm <- function(a=-Inf, b=Inf, mean=0, sd=1) .Call(C_do_etruncnorm, as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) vtruncnorm <- function(a=-Inf, b=Inf, mean=0, sd=1) .Call(C_do_vtruncnorm, as.numeric(a), as.numeric(b), as.numeric(mean), as.numeric(sd)) truncnorm/MD50000644000176200001440000000163714406151262012621 0ustar liggesuserse5dbabc36b26e8152c816ba3760fe5f3 *DESCRIPTION a95b827f0cc60b398b13b7b80914a13a *NAMESPACE 22c4df0a4f8e438816741044b6a3826b *R/truncnorm.R 9903554c50b4b4616af4d697f3a68b35 *README.md a7615b55774e8617a2e78e32411f4213 *man/dtruncnorm.Rd a169e007e2b7bdbb66d50216e74b7a9b *src/exports.c f39c3ccf3fe4d33f5779dcbdff83d9d0 *src/rtruncnorm.c 7c8d34cbe1c7a0e2783663e7ffb9327b *src/sexp_macros.h 4d9df0fd333845299d5e7515a7993ad1 *src/truncnorm.c ffb8e91e83770c395451fbdbd325ec5e *src/zeroin.c dd074a0f18f05dda52777a57fd481e51 *src/zeroin.h e0383602928861c97f81e7f6621edf36 *tests/testthat.R dd2db03ef257a9fcb3c2d52a1e6f88f2 *tests/testthat/test-bug-zero_len.R 4c17ab5336d63a3fc7ddab6217869bab *tests/testthat/test-reg-arg_checks.R 17eca482e23350f13ff7f882d4573b4b *tests/testthat/test-reg-recylce.R 3bc4ba8a8e422d3a64156e7b213c6090 *tests/testthat/test-reg-segfault.R 6a0bef92f4f48feb155562167300f51b *tests/testthat/test-sanity_checks.R