From 249e53599886501ed3f5607d207faa11f2887899 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Thu, 12 Sep 2013 09:42:50 +0100 Subject: [PATCH 01/19] replace rmath with julia code for some distributions --- src/specialfuns.jl | 10 ++++- src/univariate/cauchy.jl | 29 ++++++++----- src/univariate/geometric.jl | 81 ++++++++++++++++++++++++++++--------- src/univariate/logistic.jl | 34 +++++++++++----- src/univariate/lognormal.jl | 43 +++++++++++++------- src/univariate/normal.jl | 2 - src/univariate/uniform.jl | 65 ++++++++++++++++++++++------- src/univariate/weibull.jl | 68 +++++++++++++++---------------- 8 files changed, 228 insertions(+), 104 deletions(-) diff --git a/src/specialfuns.jl b/src/specialfuns.jl index 4ee44b788..56648b69e 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns.jl @@ -8,7 +8,15 @@ # NOTE: different than Maechler (2012), no negation inside parantheses log1mexp(x::Real) = x >= -0.6931471805599453 ? log(-expm1(x)) : log1p(-exp(x)) # log(1+exp(x)) -log1pexp(x::Real) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x +log1pexp(x::Real) = log1p(exp(x)) +log1pexp(x::Float64) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x +log1pexp(x::Float32) = x <= 9f0 ? log1p(exp(x)) : x <= 16f0 ? x + exp(-x) : x +log1pexp(x::Integer) = log1pexp(float(x)) +# log(exp(x)-1) +logexpm1(x::Real) = log(expm1(x)) +logexpm1(x::Float64) = x <= 18.0 ? log(expm1(x)) : x <= 33.3 ? x - exp(-x) : x +logexpm1(x::Float32) = x <= 9f0 ? log(expm1(x)) : x <= 16f0 ? x - exp(-x) : x +logexpm1(x::Integer) = logexpm1(float(x)) φ(z::Real) = exp(-0.5*z*z)/√2π logφ(z::Real) = -0.5*(z*z + log2π) diff --git a/src/univariate/cauchy.jl b/src/univariate/cauchy.jl index cf3833053..5a1ebd68e 100644 --- a/src/univariate/cauchy.jl +++ b/src/univariate/cauchy.jl @@ -10,18 +10,30 @@ end Cauchy(l::Real) = Cauchy(l, 1.0) Cauchy() = Cauchy(0.0, 1.0) -@_jl_dist_2p Cauchy cauchy - -entropy(d::Cauchy) = log(d.scale) + log(4.0 * pi) - insupport(::Cauchy, x::Real) = isfinite(x) insupport(::Type{Cauchy}, x::Real) = isfinite(x) +mean(d::Cauchy) = NaN +median(d::Cauchy) = d.location +mode(d::Cauchy) = d.location +modes(d::Cauchy) = [mode(d)] + +var(d::Cauchy) = NaN +skewness(d::Cauchy) = NaN kurtosis(d::Cauchy) = NaN -mean(d::Cauchy) = NaN +entropy(d::Cauchy) = log(d.scale) + log(4.0 * pi) -median(d::Cauchy) = d.location +pdf(d::Cauchy, x::Real) = 1/(pi*d.scale*(1+((x-d.location)/d.scale)^2)) +logpdf(d::Cauchy, x::Real) = -log(pi) - log(d.scale) - log1p(((x-d.location)/d.scale)^2) + +cdf(d::Cauchy, x::Real) = atan2(one(x),-(x-d.location)/d.scale)/pi +ccdf(d::Cauchy, x::Real) = atan2(one(x),(x-d.location)/d.scale)/pi + +quantile(d::Cauchy, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.location - d.scale*cospi(p)/sinpi(p) +cquantile(d::Cauchy, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.location + d.scale*cospi(p)/sinpi(p) + +rand(d::Cauchy) = quantile(d,rand()) mgf(d::Cauchy, t::Real) = NaN @@ -29,12 +41,7 @@ function cf(d::Cauchy, t::Real) exp(im * t * d.location - d.scale * abs(t)) end -mode(d::Cauchy) = d.location -modes(d::Cauchy) = [mode(d)] -skewness(d::Cauchy) = NaN - -var(d::Cauchy) = NaN function fit_mle{T <: Real}(::Type{Cauchy}, x::Array{T}) l, u = iqr(x) diff --git a/src/univariate/geometric.jl b/src/univariate/geometric.jl index 2a934959c..df7a6b822 100644 --- a/src/univariate/geometric.jl +++ b/src/univariate/geometric.jl @@ -8,32 +8,73 @@ end Geometric() = Geometric(0.5) # Flips of a fair coin -@_jl_dist_1p Geometric geom +insupport(::Geometric, x::Real) = isinteger(x) && zero(x) <= x +insupport(::Type{Geometric}, x::Real) = isinteger(x) && zero(x) <= x -function cdf(d::Geometric, q::Real) - q < zero(q) ? 0.0 : -expm1(log1p(-d.prob) * (floor(q) + 1.0)) -end +mean(d::Geometric) = (1.0 - d.prob) / d.prob -function ccdf(d::Geometric, q::Real) - q < zero(q) ? 1.0 : exp(log1p(-d.prob) * (floor(q + 1e-7) + 1.0)) -end +median(d::Geometric) = -fld(0.6931471805599453,log1p(-d.prob)) - 1.0 + +mode(d::Geometric) = 0 +modes(d::Geometric) = [0] + +var(d::Geometric) = (1.0 - d.prob) / d.prob^2 +skewness(d::Geometric) = (2.0 - d.prob) / sqrt(1.0 - d.prob) +kurtosis(d::Geometric) = 6.0 + d.prob^2 / (1.0 - d.prob) entropy(d::Geometric) = (-xlogx(1.0 - d.prob) - xlogx(d.prob)) / d.prob -insupport(::Geometric, x::Real) = isinteger(x) && zero(x) <= x -insupport(::Type{Geometric}, x::Real) = isinteger(x) && zero(x) <= x -kurtosis(d::Geometric) = 6.0 + d.prob^2 / (1.0 - d.prob) +pdf(d::Geometric, x::Real) = insupport(d,x) ? d.prob*exp(log1p(-d.prob)*x) : 0.0 +logpdf(d::Geometric, x::Real) = insupport(d,x) ? log(d.prob) + log1p(-d.prob)*x : -Inf -mean(d::Geometric) = (1.0 - d.prob) / d.prob +cdf(d::Geometric, q::Real) = q < zero(q) ? 0.0 : -expm1(log1p(-d.prob) * (floor(q) + 1.0)) +ccdf(d::Geometric, q::Real) = q < zero(q) ? 1.0 : exp(log1p(-d.prob) * (floor(q) + 1.0)) +logcdf(d::Geometric, q::Real) = q < zero(q) ? -Inf : log1mexp(log1p(-d.prob) * (floor(q) + 1.0)) +logccdf(d::Geometric, q::Real) = q < zero(q) ? 0.0 : log1p(-d.prob) * (floor(q) + 1.0) -function median(d::Geometric) - iceil(-1.0 / log(2.0, 1.0 - d.prob)) - 1 +function quantile(d::Geometric, p::Real) + if isnan(p) || (p < zero(p)) || (p > one(p)) + return NaN + elseif p == zero(p) + return 0.0 + elseif p == one(p) + return Inf + end + -fld(-log1p(-p),log1p(-d.prob))-1.0 +end +function cquantile(d::Geometric, p::Real) + if isnan(p) || (p < zero(p)) || (p > one(p)) + return NaN + elseif p == zero(p) + return Inf + elseif p == one(p) + return 0.0 + end + -fld(-log(p),log1p(-d.prob))-1.0 +end +function invlogcdf(d::Geometric, p::Real) + if (p > zero(p)) || isnan(p) + return NaN + elseif isinf(p) + return 0.0 + elseif p == zero(p) + return Inf + end + -fld(-log1mexp(p),log1p(-d.prob))-1.0 +end +function invlogccdf(d::Geometric, p::Real) + if (p > zero(p)) || isnan(p) + return NaN + elseif isinf(p) + return Inf + elseif p == zero(p) + return 0.0 + end + -fld(-p,log1p(-d.prob))-1.0 end -mode(d::Geometric) = 0 -modes(d::Geometric) = [0] - + function mgf(d::Geometric, t::Real) p = d.prob if t >= -log(1.0 - p) @@ -47,9 +88,13 @@ function cf(d::Geometric, t::Real) (p * exp(im * t)) / (1.0 - (1.0 - p) * exp(im * t)) end -skewness(d::Geometric) = (2.0 - d.prob) / sqrt(1.0 - d.prob) -var(d::Geometric) = (1.0 - d.prob) / d.prob^2 +function rand(d::Geometric) + e = Base.Random.randmtzig_exprnd() + fld(e,-log1p(-d.prob)) +end + + ## Fit model diff --git a/src/univariate/logistic.jl b/src/univariate/logistic.jl index ff26d15ee..c2ac6e3ef 100644 --- a/src/univariate/logistic.jl +++ b/src/univariate/logistic.jl @@ -9,24 +9,40 @@ immutable Logistic <: ContinuousUnivariateDistribution Logistic() = new(0.0, 1.0) end -@_jl_dist_2p Logistic logis - -entropy(d::Logistic) = log(d.scale) + 2.0 - insupport(::Logistic, x::Real) = isfinite(x) insupport(::Type{Logistic}, x::Real) = isfinite(x) -kurtosis(d::Logistic) = 1.2 mean(d::Logistic) = d.location - median(d::Logistic) = d.location - mode(d::Logistic) = d.location modes(d::Logistic) = [d.location] +std(d::Logistic) = pi * d.scale / sqrt(3.0) +var(d::Logistic) = (pi * d.scale)^2 / 3.0 + skewness(d::Logistic) = 0.0 +kurtosis(d::Logistic) = 1.2 -std(d::Logistic) = pi * d.scale / sqrt(3.0) +entropy(d::Logistic) = log(d.scale) + 2.0 -var(d::Logistic) = (pi * d.scale)^2 / 3.0 +function pdf(d::Logistic, x::Real) + a = exp(-abs((x-d.location)/d.scale)) + a / (d.scale * (1+a)^2) +end +function logpdf(d::Logistic, x::Real) + u = -abs((x-d.location)/d.scale) + u - 2*log1pexp(u) - log(d.scale) +end + +cdf(d::Logistic, x::Real) = logistic((x-d.location)/d.scale) +ccdf(d::Logistic, x::Real) = logistic((d.location-x)/d.scale) +logcdf(d::Logistic, x::Real) = -log1pexp((d.location-x)/d.scale) +logccdf(d::Logistic, x::Real) = -log1pexp((x-d.location)/d.scale) + +quantile(d::Logistic, p::Real) = d.location + d.scale*logit(p) +cquantile(d::Logistic, p::Real) = d.location - d.scale*logit(p) +invlogcdf(d::Logistic, lp::Real) = d.location - d.scale*logexpm1(-lp) +invlogccdf(d::Logistic, lp::Real) = d.location + d.scale*logexpm1(-lp) + +rand(d::Logistic) = quantile(d, rand()) diff --git a/src/univariate/lognormal.jl b/src/univariate/lognormal.jl index 54e4b34dc..428f5e99a 100644 --- a/src/univariate/lognormal.jl +++ b/src/univariate/lognormal.jl @@ -10,37 +10,50 @@ end LogNormal(ml::Real) = LogNormal(ml, 1.0) LogNormal() = LogNormal(0.0, 1.0) -@_jl_dist_2p LogNormal lnorm - -entropy(d::LogNormal) = 0.5 + 0.5 * log(2.0 * pi * d.sdlog^2) + d.meanlog - insupport(::LogNormal, x::Real) = zero(x) < x < Inf insupport(::Type{LogNormal}, x::Real) = zero(x) < x < Inf -function kurtosis(d::LogNormal) - exp(4.0 * d.sdlog^2) + 2.0 * exp(3.0 * d.sdlog^2) + - 3.0 * exp(2.0 * d.sdlog^2) - 6.0 -end - mean(d::LogNormal) = exp(d.meanlog + d.sdlog^2 / 2) median(d::LogNormal) = exp(d.meanlog) -# mgf(d::LogNormal) -# cf(d::LogNormal) - mode(d::LogNormal) = exp(d.meanlog - d.sdlog^2) modes(d::LogNormal) = [mode(d)] +function var(d::LogNormal) + sigsq = d.sdlog^2 + (exp(sigsq) - 1) * exp(2d.meanlog + sigsq) +end + function skewness(d::LogNormal) (exp(d.sdlog^2) + 2.0) * sqrt(exp(d.sdlog^2) - 1.0) end -function var(d::LogNormal) - sigsq = d.sdlog^2 - (exp(sigsq) - 1) * exp(2d.meanlog + sigsq) +function kurtosis(d::LogNormal) + exp(4.0 * d.sdlog^2) + 2.0 * exp(3.0 * d.sdlog^2) + + 3.0 * exp(2.0 * d.sdlog^2) - 6.0 end +# mgf(d::LogNormal) +# cf(d::LogNormal) + +entropy(d::LogNormal) = 0.5 + 0.5 * log(2.0 * pi * d.sdlog^2) + d.meanlog + +pdf(d::LogNormal, x::Real) = pdf(Normal(d.meanlog,d.sdlog),log(x))/x +logpdf(d::LogNormal, x::Real) = (lx = log(x); logpdf(Normal(d.meanlog,d.sdlog),lx)-lx) + +cdf(d::LogNormal, q::Real) = q <= zero(q) ? 0.0 : cdf(Normal(d.meanlog,d.sdlog),log(q)) +ccdf(d::LogNormal, q::Real) = q <= zero(q) ? 1.0 : ccdf(Normal(d.meanlog,d.sdlog),log(q)) +logcdf(d::LogNormal, q::Real) = q <= zero(q) ? -Inf : logcdf(Normal(d.meanlog,d.sdlog),log(q)) +logccdf(d::LogNormal, q::Real) = q <= zero(q) ? 0.0 : logccdf(Normal(d.meanlog,d.sdlog),log(q)) + +quantile(d::LogNormal, p::Real) = exp(quantile(Normal(d.meanlog,d.sdlog),p)) +cquantile(d::LogNormal, p::Real) = exp(cquantile(Normal(d.meanlog,d.sdlog),p)) +invlogcdf(d::LogNormal, p::Real) = exp(invlogcdf(Normal(d.meanlog,d.sdlog),p)) +invlogccdf(d::LogNormal, p::Real) = exp(invlogccdf(Normal(d.meanlog,d.sdlog),p)) + +rand(d::LogNormal) = exp(rand(Normal(d.meanlog,d.sdlog))) + function fit_mle{T <: Real}(::Type{LogNormal}, x::Array{T}) lx = log(x) LogNormal(mean(lx), std(lx)) diff --git a/src/univariate/normal.jl b/src/univariate/normal.jl index d743e701c..6480a1420 100644 --- a/src/univariate/normal.jl +++ b/src/univariate/normal.jl @@ -9,8 +9,6 @@ end Normal(μ::Real) = Normal(float64(μ), 1.0) Normal() = Normal(0.0, 1.0) -@_jl_dist_2p Normal norm - const Gaussian = Normal zval(d::Normal, x::Real) = (x - d.μ)/d.σ diff --git a/src/univariate/uniform.jl b/src/univariate/uniform.jl index b862bc0fc..2bfc3bd2b 100644 --- a/src/univariate/uniform.jl +++ b/src/univariate/uniform.jl @@ -8,21 +8,65 @@ immutable Uniform <: ContinuousUnivariateDistribution Uniform() = new(0.0, 1.0) end -@_jl_dist_2p Uniform unif +insupport(d::Uniform, x::Real) = d.a <= x <= d.b min(d::Uniform) = d.a - max(d::Uniform) = d.b +mean(d::Uniform) = (d.a + d.b) / 2.0 + +median(d::Uniform) = (d.a + d.b) / 2.0 + +mode(d::Uniform) = d.a +modes(d::Uniform) = error("The uniform distribution has no modes") + +function var(d::Uniform) + w = d.b - d.a + return w * w / 12.0 +end + +skewness(d::Uniform) = 0.0 +kurtosis(d::Uniform) = -1.2 + entropy(d::Uniform) = log(d.b - d.a) -insupport(d::Uniform, x::Real) = d.a <= x <= d.b +pdf(d::Uniform, x::Real) = insupport(d,x) ? 0.0 : 1/(d.b-d.a) +logpdf(d::Uniform, x::Real) = insupport(d,x) ? -Inf : -log(d.b-d.a) -kurtosis(d::Uniform) = -6.0 / 5.0 +function cdf(d::Uniform, q::Real) + if isnan(q) + return NaN + elseif q <= d.a + return 0.0 + elseif q >= d.b + return 1.0 + end + (q-d.a)/(d.b-d.a) +end +function ccdf(d::Uniform, q::Real) + if isnan(q) + return NaN + elseif q <= d.a + return 1.0 + elseif q >= d.b + return 0.0 + end + (d.b-q)/(d.b-d.a) +end -mean(d::Uniform) = (d.a + d.b) / 2.0 +function quantile(d::Uniform, p::Real) + if isnan(p) || (p < zero(p)) || (p > one(p)) + return NaN + end + d.a + p*(d.b-d.a) +end +function cquantile(d::Uniform, p::Real) + if isnan(p) || (p < zero(p)) || (p > one(p)) + return NaN + end + d.b + p*(d.a-d.b) +end -median(d::Uniform) = (d.a + d.b) / 2.0 function mgf(d::Uniform, t::Real) a, b = d.a, d.b @@ -34,17 +78,10 @@ function cf(d::Uniform, t::Real) return (exp(im * t * b) - exp(im * t * a)) / (im * t * (b - a)) end -mode(d::Uniform) = d.a -modes(d::Uniform) = error("The uniform distribution has no modes") - rand(d::Uniform) = d.a + (d.b - d.a) * rand() -skewness(d::Uniform) = 0.0 -function var(d::Uniform) - w = d.b - d.a - return w * w / 12.0 -end + # fit model diff --git a/src/univariate/weibull.jl b/src/univariate/weibull.jl index dece1c6ce..ca171ad8a 100644 --- a/src/univariate/weibull.jl +++ b/src/univariate/weibull.jl @@ -9,23 +9,24 @@ end Weibull(sh::Real) = Weibull(sh, 1.0) -@_jl_dist_2p Weibull weibull +insupport(::Weibull, x::Real) = zero(x) <= x < Inf +insupport(::Type{Weibull}, x::Real) = zero(x) <= x < Inf -function cdf(d::Weibull, x::Real) - if 0.0 < x - return 1.0 - exp(-((x / d.scale)^d.shape)) - else - 0.0 - end -end -function entropy(d::Weibull) - k, l = d.shape, d.scale - return ((k - 1.0) / k) * -digamma(1.0) + log(l / k) + 1.0 -end +mean(d::Weibull) = d.scale * gamma(1.0 + 1.0 / d.shape) +median(d::Weibull) = d.scale * log(2.0)^(1.0 / d.shape) -insupport(::Weibull, x::Real) = zero(x) <= x < Inf -insupport(::Type{Weibull}, x::Real) = zero(x) <= x < Inf +mode(d::Weibull) = d.shape > 1.0 ? (ik = 1.0/d.shape; d.scale * (1.0-ik)^ik) : 0.0 +modes(d::Weibull) = [mode(d)] + +var(d::Weibull) = d.scale^2 * gamma(1.0 + 2.0 / d.shape) - mean(d)^2 + +function skewness(d::Weibull) + tmp = gamma(1.0 + 3.0 / d.shape) * d.scale^3 + tmp -= 3.0 * mean(d) * var(d) + tmp -= mean(d)^3 + return tmp / std(d)^3 +end function kurtosis(d::Weibull) λ, k = d.scale, d.shape @@ -39,30 +40,29 @@ function kurtosis(d::Weibull) return den / num - 3.0 end -mean(d::Weibull) = d.scale * gamma(1.0 + 1.0 / d.shape) +function entropy(d::Weibull) + k, l = d.shape, d.scale + return ((k - 1.0) / k) * -digamma(1.0) + log(l / k) + 1.0 +end -median(d::Weibull) = d.scale * log(2.0)^(1.0 / d.shape) -function modes(d::Weibull) - if d.shape <= 1.0 - return [0.0] - else - return [d.scale * ((d.shape - 1.0) / d.shape)^(1.0 / d.shape)] - end +function pdf(d::Weibull, x::Real) + a = x/d.scale + d.shape/d.scale * a^(d.shape-1.0) * exp(-a^d.shape) end - -function skewness(d::Weibull) - tmp = gamma(1.0 + 3.0 / d.shape) * d.scale^3 - tmp -= 3.0 * mean(d) * var(d) - tmp -= mean(d)^3 - return tmp / std(d)^3 +function logpdf(d::Weibull, x::Real) + a = x/d.scale + log(d.shape/d.scale) + (d.shape-1.0)*log(a) - a^d.shape end -var(d::Weibull) = d.scale^2 * gamma(1.0 + 2.0 / d.shape) - mean(d)^2 +cdf(d::Weibull, x::Real) = x <= 0.0 ? 0.0 : 1-exp(-((x / d.scale)^d.shape)) +ccdf(d::Weibull, x::Real) = x <= 0.0 ? 1.0 : exp(-((x / d.scale)^d.shape)) +logcdf(d::Weibull, x::Real) = x <= 0.0 ? -Inf : log1mexp(-((x / d.scale)^d.shape)) +logccdf(d::Weibull, x::Real) = x <= 0.0 ? 0.0 : -(x / d.scale)^d.shape -function mode(d::Weibull) - inv_k = 1.0 / d.shape - d.shape > 1.0 ? d.scale * (1.0 - inv_k) ^ inv_k : 0.0 -end +quantile(d::Weibull, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.scale*(-log1p(-p))^(1/d.shape) +cquantile(d::Weibull, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.scale*(-log(p))^(1/d.shape) +invlogcdf(d::Weibull, lp::Real) = lp > zero(lp) ? NaN : d.scale*(-log1mexp(lp))^(1/d.shape) +invlogccdf(d::Weibull, lp::Real) = lp > zero(lp) ? NaN : d.scale*(-lp)^(1/d.shape) -modes(d::Weibull) = [mode(d)] +rand(d::Weibull) = d.scale*Base.Random.randmtzig_exprnd()^(1/d.shape) From 4b49c07eacd0e3a2abf513c59fd07cd7a1047637 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Fri, 13 Sep 2013 15:59:56 +0100 Subject: [PATCH 02/19] binomial and Poisson pdfs, and associated special functions --- src/specialfuns.jl | 128 ++++++++++++++++++++++++++++++++++++- src/univariate/binomial.jl | 80 ++++++++++++++++++----- src/univariate/ksdist.jl | 16 +---- src/univariate/poisson.jl | 9 +++ test/discrete.jl | 9 +-- test/univariate_stats.jl | 1 + 6 files changed, 207 insertions(+), 36 deletions(-) diff --git a/src/specialfuns.jl b/src/specialfuns.jl index 56648b69e..ebf577c9a 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns.jl @@ -31,6 +31,9 @@ import Base.Math.@horner # Rational approximations for the inverse cdf, from: # Wichura, M.J. (1988) Algorithm AS 241: The Percentage Points of the Normal Distribution # Journal of the Royal Statistical Society. Series C (Applied Statistics), Vol. 37, No. 3, pp. 477-484 +Φinv(p::Integer) = Φinv(float(p)) +logΦinv(p::Integer) = logΦinv(float(p)) + for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) @eval begin function $fn($arg::Float32) @@ -95,7 +98,7 @@ for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) end end - function $fn($arg::Real) + function $fn($arg::Float64) if $(fn == :Φinv) q = p - 0.5 else @@ -183,3 +186,126 @@ for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) end end end + + +# log(x) - x + 1 +# fallback +logmxp1(x) = log(x) - x + one(x) +logmxp1(x::Integer) = logmxp1(float(x)) + +# negative of NSWC DRLOG +function logmxp1(x::Float64) + if (x < 0.61) || (x > 1.57) + return log(x) - (x-1.0) + end + if x < 0.82 + u = (x-0.7)/0.7 + up2 = u+2.0 + w1 = 0.566749439387323789126387112411845e-01 - u*0.3 + elseif x > 1.18 + t = 0.75*(x-1.0) + u = t-0.25 + up2 = t+1.75 + w1 = 0.456512608815524058941143273395059e-01 + u/3.0 + else + u = x-1.0 + up2 = x+1.0 + w1 = 0.0 + end + r = u/up2 + t = r*r + z = @horner(t, + 0.7692307692307692307680e-01, + -0.1505958055914600184836e+00, + 0.9302355725278521726994e-01, + -0.1787900022182327735804e-01) / + @horner(t,1.0, + -0.2824412139355646910683e+01, + 0.2892424216041495392509e+01, + -0.1263560605948009364422e+01, + 0.1966769435894561313526e+00) + w = @horner(t, + 0.333333333333333333333333333333333e+00, + 0.200000000000000000000000000000000e+00, + 0.142857142857142857142857142857143e+00, + 0.111111111111111111111111111111111e+00, + 0.909090909090909090909090909090909e-01, + z) + return r*(2.0*t*w-u) - w1 +end + +# negative of NSWC RLOG +function logmxp1(x::Float32) + if (x < 0.61f0) || (x > 1.57f0) + return log(x) - (x-1f0) + end + if x < 0.82f0 + u = (x-0.7f0)/0.7f0 + up2 = u+2f0 + w1 = 0.566749439387324f-01 - u*0.3f0 + elseif x > 1.18f0 + t = 0.75f0*(x-1f0) + u = t-0.25f0 + up2 = t+1.75f0 + w1 = 0.456512608815524f-01 + u/3f0 + else + u = x-1f0 + up2 = x+1f0 + w1 = 0f0 + end + r = u/up2 + t = r*r + w = @horner(t, + 0.333333333333333f+00, + -.224696413112536f+00, + 0.620886815375787f-02) / + @horner(t, 1f0, + -.127408923933623f+01, + 0.354508718369557f+00) + return r*(2f0*t*w-u) - w1 +end + + + +# Stirling series for the gamma function +# +# stirling(x) = gamma(x) * e^x / (x^(x-0.5) * √2π) +# = 1 + 1/(12x) + 1/(288x^2) - 139/(51_840z^3) + ... + +# TODO: create dedicated function, as working in +# log-space will lose a few bits of precision. +stirling(x) = exp(lstirling(x)) + +# lstirling(x) = log(stirling(x)) +# = lgamma(x) + x - (x-0.5)*log(x) - 0.5*log2π +# = 1/(12x) - 1/(360x^3) + 1/(1260x^5) + ... + +# fallback +lstirling(x) = lgamma(x)- (x-0.5)*log(x) + x - 0.5*oftype(x,log2π) +lstirling(x::Integer) = lstirling(float(x)) +# based on NSWC DPDEL: only valid for values >= 10 +# Float32 version? +function lstirling(x::Float64) + if x <= 10.0 + return lgamma(x) - (x-0.5)*log(x) + x - 0.5*log2π + else + u = 10.0/x + t = u*u + return @horner(t, + .833333333333333333333333333333e-01, + -.277777777777777777777777752282e-04, + .793650793650793650791732130419e-07, + -.595238095238095232389839236182e-09, + .841750841750832853294451671990e-11, + -.191752691751854612334149171243e-12, + .641025640510325475730918472625e-14, + -.295506514125338232839867823991e-15, + .179643716359402238723287696452e-16, + -.139228964661627791231203060395e-17, + .133802855014020915603275339093e-18, + -.154246009867966094273710216533e-19, + .197701992980957427278370133333e-20, + -.234065664793997056856992426667e-21, + .171348014966398575409015466667e-22) / x + end +end diff --git a/src/univariate/binomial.jl b/src/univariate/binomial.jl index 6e60779c2..fba76b582 100644 --- a/src/univariate/binomial.jl +++ b/src/univariate/binomial.jl @@ -11,10 +11,23 @@ end Binomial(size::Integer) = Binomial(size, 0.5) Binomial() = Binomial(1, 0.5) +insupport(d::Binomial, x::Real) = isinteger(x) && 0 <= x <= d.size + min(d::Binomial) = 0 max(d::Binomial) = d.size -@_jl_dist_2p Binomial binom +mean(d::Binomial) = d.size * d.prob + +median(d::Binomial) = iround(d.size * d.prob) + +# TODO: May need to subtract 1 sometimes +# possible to get two equal modes (e.g. prob=0.5, n odd) +mode(d::Binomial) = iround((d.size + 1.0) * d.prob) +modes(d::Binomial) = [mode(d)] + +var(d::Binomial) = d.size * d.prob * (1.0 - d.prob) +skewness(d::Binomial) = (1.0 - 2.0 * d.prob) / std(d) +kurtosis(d::Binomial) = (1.0 - 6.0 * d.prob * (1.0 - d.prob)) / var(d) function entropy(d::Binomial; approx::Bool=false) n = d.size @@ -34,17 +47,60 @@ function entropy(d::Binomial; approx::Bool=false) -s end -insupport(d::Binomial, x::Real) = isinteger(x) && 0 <= x <= d.size +@_jl_dist_2p Binomial binom -kurtosis(d::Binomial) = (1.0 - 6.0 * d.prob * (1.0 - d.prob)) / var(d) +# Based on: +# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" +# available from: +# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf +# Uses slightly different form for D(x;n,p) function +function pdf(d::Binomial, x::Real) + n, p = d.size, d.prob + q = 1.0-p + y = n-x + if x == 0 + return q^n # should this be exp(n*log1p(-p)) ? + elseif y == 0 + return p^n + end + sqrt(n/(2.0*pi*x*y))*exp((lstirling(n) - lstirling(x) - lstirling(y)) + + x*logmxp1(n*p/x) + y*logmxp1(n*q/y)) +end -mean(d::Binomial) = d.size * d.prob +function logpdf(d::Binomial, x::Real) + n, p = d.size, d.prob + q = 1.0-p + y = n-x + if x == 0 + return n*log1p(-p) + elseif y ==0 + return n*log(p) + end + (lstirling(n) - lstirling(x) - lstirling(y)) + + x*logmxp1(n*p/x) + y*logmxp1(n*q/y) + 0.5*(log(n/(x*y))-log2π) +end -median(d::Binomial) = iround(d.size * d.prob) -# TODO: May need to subtract 1 sometimes -mode(d::Binomial) = iround((d.size + 1.0) * d.prob) -modes(d::Binomial) = [mode(d)] +function quantile(d::Binomial, p::Real) + # Edgeworth approximation + x = round(quantile(EdgeworthSum(d,1), p)) + if cdf(d,x) >= p + # search down + xl = x-1.0 + while cdf(d,xl) >= p + x = xl + xl -= 1.0 + end + else + # search up + x += 1.0 + while cdf(d,x) < p + x += 1.0 + end + end + x +end + function mgf(d::Binomial, t::Real) p = d.prob @@ -56,14 +112,6 @@ function cf(d::Binomial, t::Real) (1.0 - p + p * exp(im * t))^d.size end -modes(d::Binomial) = iround([d.size * d.prob]) - -# TODO: rand() is totally screwed up - -skewness(d::Binomial) = (1.0 - 2.0 * d.prob) / std(d) - -var(d::Binomial) = d.size * d.prob * (1.0 - d.prob) - ## Fit model immutable BinomialStats <: SufficientStats diff --git a/src/univariate/ksdist.jl b/src/univariate/ksdist.jl index 122910ec6..a0eedbc62 100644 --- a/src/univariate/ksdist.jl +++ b/src/univariate/ksdist.jl @@ -91,7 +91,7 @@ function cdf_durbin(d::KSDist,x::Float64) end Q = H^n s = Q[k,k] - s*stirling(n) + s*sqrt(2.0*pi*n)*stirling(n) end # Miller (1956) approximation @@ -116,17 +116,3 @@ function ceil_rems_mult(n,x) return convert(typeof(n),cl), convert(typeof(x),lrem), convert(typeof(x),urem) end -# n!*(e/n)^n -function stirling(n) - if n < 500 - s = 1.0 - for i = 1:n - s *= i/n*e - end - return s - else - # 3rd-order Stirling's approximation more accurate for large n - twn = 12.0*n - return sqrt(2.0*pi*n)*(1.0 + twn\(1 + (2.0*twn)\(1 - (15.0*twn)\139.0))) - end -end diff --git a/src/univariate/poisson.jl b/src/univariate/poisson.jl index f6708be00..89afcae0f 100644 --- a/src/univariate/poisson.jl +++ b/src/univariate/poisson.jl @@ -51,6 +51,15 @@ skewness(d::Poisson) = 1.0 / sqrt(d.lambda) var(d::Poisson) = d.lambda +# Based on: +# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" +# available from: +# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf +# Uses slightly different forms instead of D0 function +pdf(d::Poisson, x::Real) = exp(x*logmxp1(d.lambda/x)-lstirling(x))/(√2π*sqrt(x)) +logpdf(d::Poisson, x::Real) = x*logmxp1(d.lambda/x)-lstirling(x)-0.5*(log2π+log(x)) + + function fit_mle(::Type{Poisson}, x::Array) for i in 1:length(x) if !insupport(Poisson(), x[i]) diff --git a/test/discrete.jl b/test/discrete.jl index 9c853c082..b162637f8 100644 --- a/test/discrete.jl +++ b/test/discrete.jl @@ -26,7 +26,8 @@ for d in [ DiscreteUniform(2.0, 5.0), Binomial(1, 0.5), Binomial(100, 0.1), - Binomial(100, 0.9)] + Binomial(100, 0.9), + Binomial(10000, 0.03)] # println(d) @@ -104,9 +105,9 @@ for d in [ lc[i] = logcdf(d, x[i]) lcc[i] = logccdf(d, x[i]) - @test_approx_eq_eps lp[i] log(p[i]) 1.0e-12 - @test_approx_eq_eps lc[i] log(c[i]) 1.0e-12 - @test_approx_eq_eps lcc[i] log(cc[i]) 1.0e-12 + @test_approx_eq_eps exp(lp[i]) p[i] 1.0e-12 + @test_approx_eq_eps exp(lc[i]) c[i] 1.0e-12 + @test_approx_eq_eps exp(lcc[i]) cc[i] 1.0e-12 if !isa(d, Binomial) @test quantile(d, c[i] - 1.0e-8) == x[i] diff --git a/test/univariate_stats.jl b/test/univariate_stats.jl index 158c9c991..96a0d6671 100644 --- a/test/univariate_stats.jl +++ b/test/univariate_stats.jl @@ -44,6 +44,7 @@ for d in [ Binomial(1, 0.5), Binomial(100, 0.1), Binomial(100, 0.9), + Binomial(10000, 0.03), Categorical([0.1, 0.9]), Categorical([0.5, 0.5]), Categorical([0.9, 0.1]), From 857811a49614e0c70e8de6a9b6a8b30a66594157 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Fri, 13 Sep 2013 18:57:54 +0100 Subject: [PATCH 03/19] pdf for negative binomial --- src/univariate/binomial.jl | 14 +++++-- src/univariate/negativebinomial.jl | 63 ++++++++++++++++++++++-------- 2 files changed, 57 insertions(+), 20 deletions(-) diff --git a/src/univariate/binomial.jl b/src/univariate/binomial.jl index fba76b582..0ff9ca9b0 100644 --- a/src/univariate/binomial.jl +++ b/src/univariate/binomial.jl @@ -55,19 +55,25 @@ end # http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf # Uses slightly different form for D(x;n,p) function function pdf(d::Binomial, x::Real) + if !insupport(d,x) + return 0.0 + end n, p = d.size, d.prob - q = 1.0-p - y = n-x if x == 0 - return q^n # should this be exp(n*log1p(-p)) ? - elseif y == 0 + return exp(n*log1p(-p)) + elseif x == n return p^n end + q = 1.0-p + y = n-x sqrt(n/(2.0*pi*x*y))*exp((lstirling(n) - lstirling(x) - lstirling(y)) + x*logmxp1(n*p/x) + y*logmxp1(n*q/y)) end function logpdf(d::Binomial, x::Real) + if !insupport(d,x) + return -Inf + end n, p = d.size, d.prob q = 1.0-p y = n-x diff --git a/src/univariate/negativebinomial.jl b/src/univariate/negativebinomial.jl index ffc0f74fe..3de89541b 100644 --- a/src/univariate/negativebinomial.jl +++ b/src/univariate/negativebinomial.jl @@ -17,26 +17,20 @@ immutable NegativeBinomial <: DiscreteUnivariateDistribution NegativeBinomial() = new(1.0, 0.5) end -@_jl_dist_2p NegativeBinomial nbinom - insupport(::NegativeBinomial, x::Real) = isinteger(x) && zero(x) <= x insupport(::Type{NegativeBinomial}, x::Real) = isinteger(x) && zero(x) <= x -function mgf(d::NegativeBinomial, t::Real) - r, p = d.r, d.prob - return ((1.0 - p) * exp(t))^r / (1.0 - p * exp(t))^r -end - -function cf(d::NegativeBinomial, t::Real) - r, p = d.r, d.prob - return ((1.0 - p) * exp(im * t))^r / (1.0 - p * exp(im * t))^r -end - function mean(d::NegativeBinomial) p = d.prob (1.0 - p) * d.r / p end +function mode(d::NegativeBinomial) + p = d.prob + ifloor((1.0 - p) * (d.r - 1.) / p) +end +modes(d::NegativeBinomial) = [mode(d)] + function var(d::NegativeBinomial) p = d.prob (1.0 - p) * d.r / (p * p) @@ -57,9 +51,46 @@ function kurtosis(d::NegativeBinomial) 6.0 / d.r + (p * p) / ((1.0 - p) * d.r) end -function mode(d::NegativeBinomial) - p = d.prob - ifloor((1.0 - p) * (d.r - 1.) / p) + +@_jl_dist_2p NegativeBinomial nbinom + + +function pdf(d::NegativeBinomial, x::Real) + if !insupport(d,x) + return 0.0 + end + r, p = d.r, d.prob + if x == 0 + return exp(r*log1p(-p)) + end + q = 1.0-p + n = x+r + sqrt(r/(2.0*pi*x*n)) * exp((lstirling(n) - lstirling(x) - lstirling(r)) + + x*logmxp1(n*p/x) + r*logmxp1(n*q/r)) +end +function logpdf(d::NegativeBinomial, x::Real) + if !insupport(d,x) + return -Inf + end + r, p = d.r, d.prob + if x == 0 + return r*log1p(-p) + end + q = 1.0-p + n = x+r + (lstirling(n) - lstirling(x) - lstirling(r)) + + x*logmxp1(n*p/x) + r*logmxp1(n*q/r) + 0.5*(log(r/(x*n))-log2π) end -modes(d::NegativeBinomial) = [mode(d)] + + + +function mgf(d::NegativeBinomial, t::Real) + r, p = d.r, d.prob + return ((1.0 - p) * exp(t))^r / (1.0 - p * exp(t))^r +end + +function cf(d::NegativeBinomial, t::Real) + r, p = d.r, d.prob + return ((1.0 - p) * exp(im * t))^r / (1.0 - p * exp(im * t))^r +end From 12d5aea1d9bea01e4883c120dc870dcf8912ecf9 Mon Sep 17 00:00:00 2001 From: Andreas Noack Jensen Date: Sat, 17 Aug 2013 07:31:46 +0200 Subject: [PATCH 04/19] Add regularized incomplete beta and gamma functions. Use them and their auxiliary functions as much possible. --- src/fallbacks.jl | 42 + src/specialfuns.jl | 3478 ++++++++++++++++++++++++++++++++++++ src/univariate/beta.jl | 8 +- src/univariate/binomial.jl | 14 +- src/univariate/gamma.jl | 9 + src/univariate/poisson.jl | 7 +- test/discrete.jl | 2 +- test/univariate.jl | 5 +- 8 files changed, 3552 insertions(+), 13 deletions(-) diff --git a/src/fallbacks.jl b/src/fallbacks.jl index 870c7c6de..20d323ba5 100644 --- a/src/fallbacks.jl +++ b/src/fallbacks.jl @@ -69,6 +69,47 @@ logccdf(d::Distribution, q::Real) = log(ccdf(d,q)) invlogccdf(d::Distribution, lp::Real) = quantile(d, -expm1(lp)) invlogcdf(d::Distribution, lp::Real) = quantile(d, exp(lp)) +function quantile(d::ContinuousUnivariateDistribution, α::Real) + + if α < 0 || α > 1 return NaN end + if α == 0 return 0.0 end + if α == 1 return 1.0 end + + cc = 10eps() + e = sqrt(eps()) + x = mode(d) + while true + dx = (cdf(d, x)::Float64 - α)/max(e,pdf(d, x)::Float64) + if abs(dx) < cc + x -= dx + return x + end + t = x - dx + while !insupport(d, t) + dx *= 0.5 + t = x - dx + end + x = t + end +end + +function quantile(d::DiscreteUnivariateDistribution, α::Real) + if α < 0 || α > 1 return NaN end + if α == 0 return 0 end + if α == 1 return d.size end + qc = itrunc(quantile(Normal(mean(d), std(d)), α)) + if α < cdf(d, qc) + qc -= 1 + while α < cdf(d, qc) + qc -= 1 + end + return qc + 1 + end + while α > cdf(d, qc) + qc += 1 + end + return qc +end #### insupport #### @@ -102,6 +143,7 @@ function insupport(d::MatrixDistribution, X::Array) return true end +rand(d::UnivariateDistribution) = quantile(d, rand()) #### log likelihood #### diff --git a/src/specialfuns.jl b/src/specialfuns.jl index 2383217b4..4d2ad5e25 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns.jl @@ -176,6 +176,3484 @@ for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) end end +# The regularized incomplete gamma function +# Translated from the NSWC Library +function gratio(a::Float32, x::Float32, ind::Integer) +#----------------------------------------------------------------------- +# +# EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +# P(A,X) AND Q(A,X) +# +# ---------- +# +# IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X +# ARE NOT BOTH 0. +# +# ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE +# P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. +# IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS +# POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF +# IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE +# 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY +# IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. +# +# ERROR RETURN ... +# +# ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, +# WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. +# P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN +# X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. +# +#----------------------------------------------------------------------- +# WRITTEN BY ALFRED H. MORRIS, JR. +# NAVAL SURFACE WARFARE CENTER +# DAHLGREN, VIRGINIA +# REVISED ... DEC 1991 +#------------------------- +# REAL J, L, ACC0(3), BIG(3), E0(3), X0(3), WK(20) + wk = Array(Float32, 20) +# REAL A0(4), A1(4), A2(2), A3(2), A4(2), A5(2), A6(2), A7(2), +# * A8(2) +# REAL B0(6), B1(4), B2(5), B3(5), B4(4), B5(3), B6(2), B7(2) +# REAL D0(6), D1(4), D2(2), D3(2), D4(1), D5(1), D6(1) +#------------------------- + acc0 = [5.f-15, 5.f-7, 5.f-4] + big = [25.0f0, 14.0f0, 10.0f0] + e0 = [.25f-3, .25f-1, .14f0] + x0 = [31.0f0, 17.0f0, 9.7f0] +#------------------------- +# ALOG10 = LN(10) +# RT2PIN = 1/SQRT(2*PI) +# RTPI = SQRT(PI) +#------------------------- + alog10 = 2.30258509299405f0 + rt2pin = .398942280401433f0 + rtpi = 1.77245385090552f0 +#------------------------- +# +# COEFFICIENTS FOR MINIMAX APPROXIMATIONS +# FOR C0,...,C8 +# +#------------------------- +#------------------------- +# +# ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST +# FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +# + e = eps(Float32) +#------------------------- + if a < 0.0 || x < 0.0 throw(DomainError()) end # go to 400 + if a == 0.0 && x == 0.0 throw(DomainError()) end # go to 400 + if a*x == 0.0 # go to 331 + if x < a return 0.0f0, 1.0f0 end + return 1.0f0, 0.0f0 + end + + iop = ind + 1 + if iop != 1 && iop != 2 iop = 3 end + acc = max(acc0[iop],e) + +# SELECT THE APPROPRIATE ALGORITHM + + if a < 1.0 # go to 10 + if a == 0.5 # go to 320 + if x < 0.25 # go to 321 + ans = erf(sqrt(x)) + return ans, 0.5f0 + (0.5f0 - ans) + end + qans = erfc(sqrt(x)) + return 0.5f0 + (0.5f0 - qans), qans + end + if x < 1.1 # go to 110 + +# TAYLOR SERIES FOR P(A,X)/X**A + + l = 3.0f0 + c = x + sum = x/(a + 3.0f0) + tol = 3.0f0*acc/(a + 1.0f0) + while true + l += 1.0f0 + c *= -(x/l) + t = c/(a + l) + sum += t + if abs(t) <= tol break end + end + j = a*x*((sum/6.0f0 - 0.5f0/(a + 2.0f0))*x + 1.0f0/(a + 1.0f0)) + + z = a*log(x) + h = gam1(a) + g = 1.0f0 + h + if x >= 0.25 # go to 120 + if a < x/2.59f0 # go to 135 + l = expm1(z) + w = 0.5f0 + (0.5f0 + l) + qans = (w*j - l)*g - h + if qans < 0.0 return 1.0f0, 0.0f0 end # go to 310 + return 0.5f0 + (0.5f0 - qans), qans + end + w = exp(z) + ans = w*g*(0.5f0 + (0.5f0 - j)) + return ans, 0.5f0 + (0.5f0 - ans) + end + if z <= -.13394 # go to 135 + w = exp(z) + ans = w*g*(0.5f0 + (0.5f0 - j)) + return ans, 0.5f0 + (0.5f0 - ans) + end + l = expm1(z) + w = 0.5f0 + (0.5f0 + l) + qans = (w*j - l)*g - h + if qans < 0.0 return 1.0f0, 0.0f0 end # go to 310 + return 0.5f0 + (0.5f0 - qans), qans + end + r = rcomp(a, x) + if r == 0.0 return 1.0f0, 0.0f0 end # go to 310 + +# CONTINUED FRACTION EXPANSION + + tol = max(8.0f0*e,4.0f0*acc) + a2nm1 = 1.0f0 + a2n = 1.0f0 + b2nm1 = x + b2n = x + (1.0f0 - a) + c = 1.0f0 + while true + a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + c += 1.0f0 + t = c - a + a2n = a2nm1 + t*a2n + b2n = b2nm1 + t*b2n + + a2nm1 /= b2n + b2nm1 /= b2n + a2n /= b2n + b2n = 1.0f0 + if abs(a2n - a2nm1/b2nm1) < tol*a2n break end + end + + qans = r*a2n + return 0.5f0 + (0.5f0 - qans), qans + end + + if a >= big[iop] # go to 20 + l = x/a + if l == 0.0 return 0.0f0, 1.0f0 end # go to 300 + s = 0.5f0 + (0.5f0 - l) + z = rlog(l) + if z >= 700.0f0/a # go to 330 + if abs(s) <= 2.0f0*e error() end # go to 400 + if x <= a return 0.0f0, 1.0f0 end # go to 300 + return 1.0f0, 0.0f0 + end + y = a*z + rta = sqrt(a) + if abs(s) <= e0[iop]/rta # go to 250 + +# TEMME EXPANSION FOR L = 1 + + if a*e*e > 3.28f-3 error() end # go to 400 + c = 0.5f0 + (0.5f0 - y) + w = (0.5f0 - sqrt(y)*(0.5f0 + (0.5f0 - y/3.0f0))/rtpi)/c + u = 1.0f0/a + z = sqrt(z + z) + if l < 1.0 z = -z end + if iop < 2 # 260,270,280 + c0 = @horner(z, -.333333333333333f+00, + .833333333333333f-01, + -.148148148148148f-01, + .115740740740741f-02) + c1 = @horner(z, -.185185185185185f-02, + -.347222222222222f-02, + .264550264550265f-02, + -.990226337448560f-03) + c2 = @horner(z, .413359788359788f-02, + -.268132716049383f-02, + .771604938271605f-03) + c3 = @horner(z, .649434156378601f-03, + .229472093621399f-03, + -.469189494395256f-03) + c4 = @horner(z, -.861888290916712f-03, + .784039221720067f-03) + c5 = @horner(z, -.336798553366358f-03, + -.697281375836586f-04) + c6 = @horner(z, .531307936463992f-03, + -.592166437353694f-03) + t = (((((((-.652623918595309f-03*u + .344367606892378f-03)*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 + elseif iop == 2 + c0 = @horner(z, -.333333333333333f+00, + .833333333333333f-01, + -.148148148148148f-01) + c1 = @horner(z, -.185185185185185f-02, + -.347222222222222f-02) + t = (d20*u + c1)*u + c0 + else + t = @horner(z, -.333333333333333f+00, + .833333333333333f-01) + end # go to 240 + if l >= 1.0 # go to 241 + qans = c*(w + rt2pin*t/rta) + return 0.5f0 + (0.5f0 - qans), qans + end + ans = c*(w - rt2pin*t/rta) + return ans, 0.5f0 + (0.5f0 - ans) + end + if abs(s) <= 0.4 # go to 200 + if abs(s) <= 2.0f0*e && a*e*e > 3.28e-3 error() end # go to 400 + c = exp(-y) + w = 0.5f0*erfcx(sqrt(y)) + u = 1.0f0/a + z = sqrt(z + z) + if l < 1.0 z = -z end + if iop < 2 # 210,220,230 + + if abs(s) <= 1.e-3 # go to 260 + c0 = @horner(z, -.333333333333333f+00, + .833333333333333f-01, + -.148148148148148f-01, + .115740740740741f-02) + c1 = @horner(z, -.185185185185185f-02, + -.347222222222222f-02, + .264550264550265f-02, + -.990226337448560f-03) + c2 = @horner(z, .413359788359788f-02, + -.268132716049383f-02, + .771604938271605f-03) + c3 = @horner(z, .649434156378601f-03, + .229472093621399f-03, + -.469189494395256f-03) + c4 = @horner(z, -.861888290916712f-03, + .784039221720067f-03) + c5 = @horner(z, -.336798553366358f-03, + -.697281375836586f-04) + c6 = @horner(z, .531307936463992f-03, + -.592166437353694f-03) + t = (((((((-.652623918595309f-03*u + .344367606892378f-03)*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 + else + +# using the minimax approximations + + c0 = @horner(z,-.333333333333333f+00, + -.159840143443990f+00, + -.335378520024220f-01, + -.231272501940775f-02)/ + @horner(z,1.0f0, + .729520430331981f+00, + .238549219145773f+00, + .376245718289389f-01, + .239521354917408f-02, + -.939001940478355f-05, + .633763414209504f-06) + c1 = @horner(z,-.185185185184291f-02, + -.491687131726920f-02, + -.587926036018402f-03, + -.398783924370770f-05)/ + @horner(z,1.0f0, + .780110511677243f+00, + .283344278023803f+00, + .506042559238939f-01, + .386325038602125f-02) + c2 = @horner(z, .413359788442192f-02, + .669564126155663f-03)/ + @horner(z,1.0f0, + .810647620703045f+00, + .339173452092224f+00, + .682034997401259f-01, + .650837693041777f-02, + .421924263980656f-03) + c3 = @horner(z, .649434157619770f-03, + .810586158563431f-03)/ + @horner(z,1.0f0, + .894800593794972f+00, + .406288930253881f+00, + .906610359762969f-01, + .905375887385478f-02, + -.632276587352120f-03) + c4 = @horner(z,-.861888301199388f-03, + -.105014537920131f-03)/ + @horner(z,1.0f0, + .103151890792185f+01, + .591353097931237f+00, + .178295773562970f+00, + .322609381345173f-01) + c5 = @horner(z,-.336806989710598f-03, + -.435211415445014f-03)/ + @horner(z,1.0f0, + .108515217314415f+01, + .600380376956324f+00, + .178716720452422f+00) + c6 = @horner(z, .531279816209452f-03, + -.182503596367782f-03)/ + @horner(z,1.0f0, + .770341682526774f+00, + .345608222411837f+00) + c7 = @horner(z, .344430064306926f-03, + .443219646726422f-03)/ + @horner(z,1.0f0, + .115029088777769f+01, + .821824741357866f+00) + c8 = .878371203603888f-03*z - .686013280418038f-03 + t = (((((((c8*u + c7)*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 + end + elseif iop == 2 + +# temme expansion + + c0 = @horner(z, -.333333333333333f+00, + .833333333333333f-01, + -.148148148148148f-01, + .115740740740741f-02, + .352733686067019f-03, + -.178755144032922f-03, + .391926317852244f-04) + c1 = @horner(z, -.185185185185185f-02, + -.347222222222222f-02, + .264550264550265f-02, + -.990226337448560f-03, + .205761316872428f-03) + c2 = @horner(z, .413359788359788f-02, + -.268132716049383f-02) + t = (c2*u + c1)*u + c0 + else + t = @horner(z, -.333333333333333f+00, + .833333333333333f-01, + -.148148148148148f-01, + .115740740740741f-02) + end + if l >= 1.0 # go to 241 + qans = c*(w + rt2pin*t/rta) + return 0.5f0 + (0.5f0 - qans), qans + end + ans = c*(w - rt2pin*t/rta) + return ans, 0.5f0 + (0.5f0 - ans) + end + end + if a <= x && x < x0[iop] # go to 30 + twoa = a + a + m = int(twoa) + if twoa == m # go to 30 + i = div(m,2) + if a == i # go to 140 + +# FINITE SUMS FOR Q WHEN A .GE. 1 +# AND 2*A IS AN INTEGER + + sum = exp(-x) + t = sum + n = 1 + c = 0.0f0 + else + rtx = sqrt(x) + sum = erfc(rtx) + t = exp(-x)/(rtpi*rtx) + n = 0 + c = -0.5f0 + end + while n != i # go to 161 + n += 1 + c += 1.0f0 + t = (x*t)/c + sum += t + end + return 0.5f0 + (0.5f0 - sum), sum + end + end + + r = rcomp(a, x) + if r == 0.0 # go to 331 + if x < a return 0.0f0, 1.0f0 end + return 0.0f0, 1.0f0 + end + if x > max(a, alog10) # go to 50 + if x < x0[iop] # go to 170 + +# CONTINUED FRACTION EXPANSION + + tol = max(8.0f0*e,4.0f0*acc) + a2nm1 = 1.0f0 + a2n = 1.0f0 + b2nm1 = x + b2n = x + (1.0f0 - a) + c = 1.0f0 + while true + a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + c += 1.0f0 + t = c - a + a2n = a2nm1 + t*a2n + b2n = b2nm1 + t*b2n + + a2nm1 /= b2n + b2nm1 /= b2n + a2n /= b2n + b2n = 1.0f0 + if abs(a2n - a2nm1/b2nm1) < tol*a2n break end + end + + qans = r*a2n + return 0.5f0 + (0.5f0 - qans), qans + end + +# ASYMPTOTIC EXPANSION + + amn = a - 1.0f0 + t = amn/x + wk[1] = t + n = 0 + for n = 2:20 + amn -= 1.0f0 + t *= amn/x + if abs(t) <= 1.f-3 break end # go to 90 + wk[n] = t + end + sum = t + while abs(t) >= acc # go to 100 + amn -= 1.0f0 + t *= amn/x + sum += t + end + + mx = n - 1 + for m = 1:mx + n -= 1 + sum += wk[n] + end + qans = (r/x)*(1.0f0 + sum) + return 0.5f0 + (0.5f0 - qans), qans + end + +# TAYLOR SERIES FOR P/R + + apn = a + 1.0f0 + t = x/apn + wk[1] = t + n = 0 + for n = 2:20 + apn += 1.0f0 + t *= x/apn + if t <= 1.f-3 break end # go to 60 + wk[n] = t + end + sum = t + tol = 0.5f0*acc + while true + apn += 1.0f0 + t *= x/apn + sum += t + if t <= tol break end # go to 61 + end + + mx = n - 1 + for m = 1:mx + n -= 1 + sum += wk[n] + end + ans = (r/a)*(1.0f0 + sum) + return ans, 0.5f0 + (0.5f0 - ans) +end + +function dgrat(a::Real, x::Real) +#----------------------------------------------------------------------- +# +# EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +# P(A,X) AND Q(A,X) +# +#----------------------------------------------------------------------- +# WRITTEN BY ALFRED H. MORRIS, JR. +# NAVAL SURFACE WARFARE CENTER +# DAHLGREN, VIRGINIA +# REVISED ... JAN 1992 +#------------------------- +# DOUBLE PRECISION A, X, ANS, QANS +# DOUBLE PRECISION AMN, ALOG10, APN, A2N, A2NM1, BIG, B2N, +# * B2NM1, C, E, G, H, J, L, R, RTA, RTPI, RTX, S, +# * SUM, T, TOL, TWOA, U, X0, Y, Z, WK(20) + wk = Array(Float64, 20) +# DOUBLE PRECISION DPMPAR, DRLOG, DREXP +# DOUBLE PRECISION DERF, DERFC1, DGAM1, DRCOMP +#------------------------- +# ALOG10 = LN(10) +# RTPI = DSQRT(PI) +#------------------------- + alog10 = 2.30258509299404568401799145468e0 + rtpi = 1.77245385090551602729816748334e0 +#------------------------- +# +# ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST +# FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +# + e = eps(typeof(float(x))) + n = 0 + s = 1.0 + r = 0.0 +# +#------------------------- + if a < 0.0 || x < 0.0 throw(DomainError()) end + if a == 0.0 && x == 0.0 throw(DomainError()) end + if a*x == 0.0 # go to 331 + if x <= a return 0.0, 1.0 end + return 1.0, 0.0 + end + + e = max(e,1.e-30) + if e < 1.e-17 + big = 50.0 + x0 = 68.0 + else + big = 30.0 + x0 = 45.0 + end + + +# SELECT THE APPROPRIATE ALGORITHM + while true + if a < 1.0 # go to 10 + if a == 0.5 # go to 320 + if x < 0.25 # go to 321 + ans = erf(sqrt(x)) + return ans, 0.5 + (0.5 - ans) + end + qans = erfc(sqrt(x)) + return 0.5 + (0.5 - qans), qans + end + if x <= 2.0 # go to 110 + # taylor series for p(a,x)/x**a + l = 3.0 + c = x + sum = x/(a + 3.0) + tol = 3.0*e/(a + 1.0) + while true + l += 1.0 + c *= -(x/l) + t = c/(a + l) + sum += t + if abs(t) <= tol break end + end + j = a*x*((sum/6.0 - 0.5/(a + 2.0))*x + 1.0/(a + 1.0)) + + z = a*log(x) + u = exp(z) + h = dgam1(a) + g = 1.0 + h + ans = u*g*(0.5 + (0.5 - j)) + qans = 0.5 + (0.5 - ans) + if ans <= 0.9 return ans, qans end + + l = expm1(z) + qans = (u*j - l)*g - h + if qans <= 0.0 return 1.0, 0.0 end + return 0.5 + (0.5 - qans), qans + end + r = drcomp(a,x) + if r == 0.0 return 1.0, 0.0 end + break + end # go to 170 + while true + if a < big # go to 20 + if a > x || x >= x0 break end# go to 30 + twoa = a + a + m = itrunc(twoa) + l = float(m) + if twoa != l break end # go to 30 + i = div(m,2) + l = float(i) + if a == l # go to 140 + sum = exp(-x) + t = sum + n = 1 + c = 0.0 + else + rtx = sqrt(x) + sum = erfc(rtx) + t = exp(-x)/(rtpi*rtx) + n = 0 + c = -0.5 + end + while n != i # go to 161 + n += 1 + c += 1.0 + t = (x*t)/c + sum += t + end + qans = sum + return 0.5 + (0.5 - qans), qans + end + + l = x/a + if l == 0.0 return 0.0, 1.0 end + s = 0.5 + (0.5 - l) + z = drlog(l) + if z >= 700.0/a # go to 330 + if abs(s) <= 2.0*e error("ierr=3") end + if x < a return 0.0, 1.0 end + return 1.0, 0.0 + end + y = a*z + rta = sqrt(a) + if abs(s) <= 0.4 # go to 200 + if abs(s) <= 2.0*e && a*e*e > 3.28e-3 error("ierr=3") end + if e <= 1.e-17 return dgr29(a, y, l, z, rta) end + return dgr17(a, y, l, z, rta) + end + break + end + + r = drcomp(a,x) + if r == 0.0 # go to 331 + if abs(s) <= 2.0*e error("ierr=3") end + if x < a return 0.0, 1.0 end + return 1.0, 0.0 + end + if x > max(a,alog10) # go to 50 + if x < x0 break end# go to 170 + else # go to 80 + + # TAYLOR SERIES FOR P/R + + apn = a + 1.0 + t = x/apn + wk[1] = t + for n = 2:20 + apn += 1.0 + t *= x/apn + if t < 1.e-3 break end # go to 60 + wk[n] = t + end + + sum = t + tol = 0.5*e + while true + apn += 1.0 + t *= x/apn + sum += t + if t <= tol break end # go to 61 + end + + mx = n - 1 + for m = 1:mx + n -= 1 + sum += wk[n] + end + ans = (r/a)*(1.0 + sum) + return ans, 0.5 + (0.5 - ans) + end + + # ASYMPTOTIC EXPANS + amn = a - 1.0 + t = amn/x + wk[1] = t + for n = 2:20 + amn -= 1.0 + t *= amn/x + if abs(t) <= 1.e-3 break end # go to 90 + wk[n] = t + end + + sum = t + while abs(t) >= e # go to 100 + amn -= 1.0 + t *= amn/x + sum += t + end + + mx = n - 1 + for m = 1:mx + n -= 1 + sum += wk[n] + end + qans = (r/x)*(1.0 + sum) + return 0.5 + (0.5 - qans), qans + end + +# continued fraction expansion + + tol = 8.0*e + a2nm1 = 1.0 + a2n = 1.0 + b2nm1 = x + b2n = x + (1.0 - a) + c = 1.0 + while true + a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + c += 1.0 + t = c - a + a2n = a2nm1 + t*a2n + b2n = b2nm1 + t*b2n + a2nm1 = a2nm1/b2n + b2nm1 = b2nm1/b2n + a2n = a2n/b2n + b2n = 1.0 + if abs(a2n - a2nm1/b2nm1) < tol*a2n break end # go to 180 + end + qans = r*a2n + return 0.5 + (0.5 - qans), qans +end + +function rcomp(a::Float32, x::Float32) +#----------------------------------------------------------------------- +# EVALUATION OF EXP(-X)*X**A/GAMMA(A) +#----------------------------------------------------------------------- +# RT2PIN = 1/SQRT(2*PI) +#------------------------ + rt2pin = .398942280401433f0 +#------------------------ + if x == 0.0 return 0.0f0 end + if a < 20.0 # go to 20 + + t = a*log(x) - x + if t < exparg(true) return 0.0f0 end + if a < 1.0 # go to 10 + return (a*exp(t))*(1.0f0 + gam1(a)) + end + return exp(t)/gamma(a) + end + + u = x/a + if u == 0.0 return 0.0f0 end + t = (1.0f0/a)^2 + t1 = (((0.75f0*t - 1.0f0)*t + 3.5f0)*t - 105.0f0)/(a*1260.0f0) + t1 -= a*rlog(u) + if t1 >= exparg(true) return rt2pin*sqrt(a)*exp(t1) end +end + +function drcomp(a::Real, x::Real) +#----------------------------------------------------------------------- +# EVALUATION OF EXP(-X)*X**A/GAMMA(A) +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, X, C, T, W +# DOUBLE PRECISION DGAMMA, DGAM1, DPDEL, DRLOG, DXPARG +#-------------------------- +# C = 1/SQRT(2*PI) +#-------------------------- + c = .398942280401432677939946059934 +#-------------------------- + if x == 0.0 return 0.0 end + if a <= 20.0 # go to 20 + t = a*log(x) - x + if t < dxparg(true) return 0.0 end + if a < 1.0 # go to 10 + return (a*exp(t))*(1.0 + dgam1(a)) + end + return exp(t)/gamma(a) + end + + t = x/a + if t == 0.0 return 0.0 end + w = -(dpdel(a) + a*drlog(t)) + if w >= dxparg(true) + return c*sqrt(a)*exp(w) + else + return 0.0 + end +end + +function dpdel(x::Real) +#----------------------------------------------------------------------- +# +# COMPUTATION OF THE FUNCTION DEL(X) FOR X .GE. 10 WHERE +# LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X) +# +# -------- +# +# THE SERIES FOR DPDEL ON THE INTERVAL 0.0 TO 1.0 DERIVED BY +# A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY +# OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). +# +#----------------------------------------------------------------------- +# DOUBLE PRECISION X, A(15), T, W +#----------------------------------------------------------------------- + +#----------------------------------------------------------------------- + t = (10.0/x)^2 + w = Base.Math.@horner(t, .833333333333333333333333333333e-01, + -.277777777777777777777777752282e-04, + .793650793650793650791732130419e-07, + -.595238095238095232389839236182e-09, + .841750841750832853294451671990e-11, + -.191752691751854612334149171243e-12, + .641025640510325475730918472625e-14, + -.295506514125338232839867823991e-15, + .179643716359402238723287696452e-16, + -.139228964661627791231203060395e-17, + .133802855014020915603275339093e-18, + -.154246009867966094273710216533e-19, + .197701992980957427278370133333e-20, + -.234065664793997056856992426667e-21, + .171348014966398575409015466667e-22) + return w/x +end + +function rlog(x::Float32) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION X - 1 - LN(X) +#----------------------------------------------------------------------- +# A = RLOG (0.7) +# B = RLOG (4/3) +#------------------------ + a = .566749439387324f-01 + b = .456512608815524f-01 +#------------------------ + p0 = .333333333333333f+00 + p1 = -.224696413112536f+00 + p2 = .620886815375787f-02 + q1 = -.127408923933623f+01 + q2 = .354508718369557f+00 +#------------------------ + if x < 0.61 || x > 1.57 # go to 100 + r = (x - 0.5f0) - 0.5f0 + return r - log(x) + end + if x < 0.82 # go to 10 + u = (x - 0.7f0)/0.7f0 + up2 = u + 2.0f0 + w1 = a - u*0.3f0 + elseif x > 1.18 # go to 20 + t = 0.75f0*(x - 1.0f0) + u = t - 0.25f0 + up2 = t + 1.75f0 + w1 = b + u/3.0f0 + else +# ARGUMENT REDUCTION + + u = (x - 0.5f0) - 0.5f0 + up2 = u + 2.0f0 + w1 = 0.0f0 + end + +# SERIES EXPANSION + + r = u/up2 + t = r*r + w = ((p2*t + p1)*t + p0)/((q2*t + q1)*t + 1.0f0) + return r*(u - 2.0f0*t*w) + w1 +end + +function drlog(x::Real) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION X - 1 - LN(X) +#----------------------------------------------------------------------- +# DOUBLE PRECISION X +# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z +# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C1, C2, C3, C4, C5 +#------------------------- +# A = DRLOG (0.7) +# B = DRLOG (4/3) +#------------------------- + a = .566749439387323789126387112411845e-01 + b = .456512608815524058941143273395059e-01 +#------------------------- + p0 = .7692307692307692307680e-01 + p1 = -.1505958055914600184836e+00 + p2 = .9302355725278521726994e-01 + p3 = -.1787900022182327735804e-01 + q1 = -.2824412139355646910683e+01 + q2 = .2892424216041495392509e+01 + q3 = -.1263560605948009364422e+01 + q4 = .1966769435894561313526e+00 +#------------------------- +# CI = 1/(2I + 1) +#------------------------- + c1 = .333333333333333333333333333333333e+00 + c2 = .200000000000000000000000000000000e+00 + c3 = .142857142857142857142857142857143e+00 + c4 = .111111111111111111111111111111111e+00 + c5 = .909090909090909090909090909090909e-01 +#------------------------- + if x < 0.61 || x > 1.57 # go to 100 + r = (x - 0.5) - 0.5 + return r - log(x) + end + if x <= 1.18 # go to 20 + if x >= 0.82 # go to 10 + +# ARGUMENT REDUCTION + + u = (x - 0.5) - 0.5 + up2 = u + 2.0 + w1 = 0.0 + else + + u = (x - 0.7)/0.7 + up2 = u + 2.0 + w1 = a - u*0.3 + end + else + t = 0.75*(x - 1.0) + u = t - 0.25 + up2 = t + 1.75 + w1 = b + u/3.0 + end + +# SERIES EXPANSION + + r = u/up2 + t = r*r +# +# Z IS A MINIMAX APPROXIMATION OF THE SERIES +# +# C6 + C7*R**2 + C8*R**4 + ... +# +# FOR THE INTERVAL (0.0, 0.375). THE APPROX- +# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF +# THE 21-ST SIGNIFICANT DIGIT. +# + z = (((p3*t + p2)*t + p1)*t + p0)/((((q4*t + q3)*t + q2)*t + q1)*t + 1.0) + + w = ((((z*t + c5)*t + c4)*t + c3)*t + c2)*t + c1 + return r*(u - 2.0*t*w) + w1 +end + +function dgr17(a::Real, y::Real, l::Real, z::Real, rta::Real) +#----------------------------------------------------------------------- +# +# ALGORITHM USING MINIMAX APPROXIMATIONS +# FOR C0,...,C10 +# +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS +# DOUBLE PRECISION E, RT2PIN, T, U, W +# DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10 +# DOUBLE PRECISION A0(5), A1(4), A2(4), A3(4), A4(3), A5(2), +# * A6(2), A7(2), A8(2), A9(3), A10(2) +# DOUBLE PRECISION B0(6), B1(6), B2(5), B3(4), B4(4), B5(4), +# * B6(3), B7(3), B8(2) +# DOUBLE PRECISION DERFC1 +#------------------------ +# RT2PIN = 1/DSQRT(2*PI) +#------------------------ + rt2pin = .398942280401432678e0 +#------------------------ + e = exp(-y) + w = 0.5*erfcx(sqrt(y)) + u = 1.0/a + z = sqrt(z + z) + if l < 1.0 z = -z end + + c0 = Base.Math.@horner(z, -.33333333333333333e+00, + -.24232172943558393e+00, + -.76816029947195974e-01, + -.11758531313175796e-01, + -.73324404807556026e-03) + c0 /= Base.Math.@horner(z, 1.0, + .97696518830675185e+00, + .43024494247383254e+00, + .10288837674434487e+00, + .13250270182342259e-01, + .73121701584237188e-03, + .10555647473018528e-06) + c1 = Base.Math.@horner(z, -.18518518518518417e-02, + -.52949366601406939e-02, + -.16090334014223031e-02, + -.16746784557475121e-03) + c1 /= Base.Math.@horner(z, 1.0, + .98426579647613593e+00, + .45195109694529839e+00, + .11439610256504704e+00, + .15954049115266936e-01, + .98671953445602142e-03, + .12328086517283227e-05) + c2 = Base.Math.@horner(z, .41335978835983393e-02, + .15067356806896441e-02, + .13743853858711134e-03, + .12049855113125238e-04) + c2 /= Base.Math.@horner(z, 1.0, + .10131761625405203e+01, + .50379606871703058e+00, + .14009848931638062e+00, + .22316881460606523e-01, + .15927093345670077e-02) + c3 = Base.Math.@horner(z, .64943415637082551e-03, + .81804333975935872e-03, + .13012396979747783e-04, + .46318872971699924e-05) + c3 /= Base.Math.@horner(z, 1.0, + .90628317147366376e+00, + .42226789458984594e+00, + .10044290377295469e+00, + .12414068921653593e-01) + c4 = Base.Math.@horner(z, -.86188829773520181e-03, + -.82794205648271314e-04, + -.37567394580525597e-05) + c4 /= Base.Math.@horner(z, 1.0, + .10057375981227881e+01, + .57225859400072754e+00, + .16988291247058802e+00, + .31290397554562032e-01) + c5 = Base.Math.@horner(z, -.33679854644784478e-03, + -.43263341886764011e-03) + c5 /= Base.Math.@horner(z, 1.0, + .10775200414676195e+01, + .60019022026983067e+00, + .17081504060220639e+00, + .22714615451529335e-01) + + c6 = Base.Math.@horner(z, .53130115408837152e-03, + -.12962670089753501e-03) + c6 /= Base.Math.@horner(z, 1.0, + .87058903334443855e+00, + .45957439582639129e+00, + .65929776650152292e-01) + c7 = Base.Math.@horner(z, .34438428473168988e-03, + .47861364421780889e-03) + c7 /= Base.Math.@horner(z, 1.0, + .12396875725833093e+01, + .78991370162247144e+00, + .27176241899664174e+00) + c8 = Base.Math.@horner(z, -.65256615574219131e-03, + .27086391808339115e-03) + c8 /= Base.Math.@horner(z, 1.0, + .87002402612484571e+00, + .44207055629598579e+00) + c9 = Base.Math.@horner(z, -.60335050249571475e-03, + -.14838721516118744e-03, + .84725086921921823e-03) + c10 = Base.Math.@horner(z, .13324454494800656e-02, + -.19144384985654775e-02) + + + t = (((((((((c10*u + c9)*u + c8)*u + c7)*u + c6)*u + c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 + + if (l >= 1.0) # go to 10 + qans = e*(w + rt2pin*t/rta) + return 0.5 + (0.5 - qans), qans + end + ans = e*(w - rt2pin*t/rta) + return ans, 0.5 + (0.5 - ans) +end + +function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) +#----------------------------------------------------------------------- +# +# ALGORITHM USING MINIMAX APPROXIMATIONS +# +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS +# DOUBLE PRECISION A0(7), A1(7), A2(7), A3(7), A4(7), A5(7), A6(4), +# * A7(5), A8(5), A9(5), A10(4), A11(4), A12(4), +# * A13(3), A14(3), A15(2), A16(2), A17(1), A18(1) +# DOUBLE PRECISION B0(9), B1(9), B2(8), B3(8), B4(8), B5(7), B6(9), +# * B7(7), B8(7), B9(6), B10(6), B11(5), B12(4), +# * B13(4), B14(2), B15(2), B16(1) +# DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10, +# * C11, C12, C13, C14, C15, C16 +# DOUBLE PRECISION D0(7), E, RT2PIN, T, U, W +# DOUBLE PRECISION DERFC1 +#--------------------------- +# RT2PIN = 1/DSQRT(2*PI) +#--------------------------- + rt2pin = .398942280401432677939946059934e0 +#--------------------------- + + e = exp(-y) + w = 0.5*erfcx(sqrt(y)) + u = 1.0/a + z = sqrt(z + z) + if l < 1.0 z = -z end + + t = Base.Math.@horner(z,-.218544851067999216147364227e-05, + -.490033281596113358850307112e-05, + -.372722892959910688597417881e-05, + -.145717031728609218851588740e-05, + -.327874000161065050049103731e-06, + -.408902435641223939887180303e-07, + -.234443848930188413698825870e-08) + t /= Base.Math.@horner(z,1.0, + .139388806936391316154237713e+01, + .902581259032419042347458484e+00, + .349373447613102956696810725e+00, + .866750030433403450681521877e-01, + .138263099503103838517015533e-01, + .131659965062389880196860991e-02, + .597739416777031660496708557e-04, + .319268409139858531586963150e-08, + -.129786815987713980865910767e-09) + c0 = ((((((t*z + .391926317852243778169704095630e-04)*z + + -.178755144032921810699588477366e-03)*z + + .352733686067019400352733686067e-03)*z + + .115740740740740740740740740741e-02)*z + + -.148148148148148148148148148148e-01)*z + + .833333333333333333333333333333e-01)*z + + -.333333333333333333333333333333e+00 + c1 = Base.Math.@horner(z,-.185185185185185185185185200e-02, + -.627269388216833251971110268e-02, + -.462960105006279850867332060e-02, + -.167787748352827199882047653e-02, + -.334816794629374699945489443e-03, + -.359791514993122440319624428e-04, + -.162671127226300802902860047e-05) + c1 /= Base.Math.@horner(z,1.0, + .151225469637089956064399494e+01, + .109307843990990308990473663e+01, + .482173396010404307346794795e+00, + .140741499324744724262767201e+00, + .276755209895072417713430394e-01, + .356903970692700621824901511e-02, + .275463718595762102271929980e-03, + .974094440943696092434381137e-05, + .361538770500640888027927000e-09) + c2 = Base.Math.@horner(z, .413359788359788359788359644e-02, + .365985331203490698463644329e-02, + .138385867950361368914038461e-02, + .287368655528567495658887760e-03, + .351658023234640143803014403e-04, + .261809837060522545971782889e-05, + .100841467329617467204527243e-06) + c2 /= Base.Math.@horner(z,1.0, + .153405837991415136438992306e+01, + .114320896084982707537755002e+01, + .524238095721639512312120765e+00, + .160392471625881407829191009e+00, + .333036784835643463383606186e-01, + .457258679387716305283282667e-02, + .378705615967233119938297206e-03, + .144996224602847932479320241e-04) + c3 = Base.Math.@horner(z, .649434156378600823045102236e-03, + .141844584435355290321010006e-02, + .987931909328964685388525477e-03, + .331552280167649130371474456e-03, + .620467118988901865955998784e-04, + .695396758348887902366951353e-05, + .352304123782956092061364635e-06) + c3 /= Base.Math.@horner(z,1.0, + .183078413578083710405050462e+01, + .159678625605457556492814589e+01, + .856743428738899911100227393e+00, + .308149284260387354956024487e+00, + .760733201461716525855765749e-01, + .126418031281256648240652355e-01, + .130398975231883219976260776e-02, + .656342109234806261144233394e-04) + c4 = Base.Math.@horner(z, -.861888290916711698604710684e-03, + -.619343030286408407629007048e-03, + -.173138093150706317400323103e-03, + -.337525643163070607393381432e-04, + -.487392507564453824976295590e-05, + -.470448694272734954500324169e-06, + -.260879135093022176005540138e-07) + c4 /= Base.Math.@horner(z,1.0, + .162826466816694512158165085e+01, + .133507902144433100426436242e+01, + .686949677014349678482109368e+00, + .241580582651643837306299024e+00, + .590964360473404599955095091e-01, + .990129468337836044520381371e-02, + .104553622856827932853059322e-02, + .561738585657138771286755470e-04) + c5 = Base.Math.@horner(z, -.336798553366358151161633777e-03, + -.548868487607991087508092013e-03, + -.171902547619915856635305717e-03, + -.332229941748769925615918550e-04, + -.556701576804390213081214801e-05, + .506465072067030007394288471e-08, + -.116166342948098688243985652e-07) + c5 /= Base.Math.@horner(z,1.0, + .142263185288429590449288300e+01, + .103913867517817784825064299e+01, + .462890328922621047510807887e+00, + .136071713023783507468096673e+00, + .254669201041872409738119341e-01, + .280714123386276098548285440e-02, + .106576106868815233442641444e-03) + c6 = Base.Math.@horner(z, .531307936463992224884286210e-03, + .209213745619758030399432459e-03, + .694345283181981060040314140e-05, + .118384620224413424936260301e-04) + c6 /= Base.Math.@horner(z,1.0, + .150831585220968267709550582e+01, + .118432122801495778365352945e+01, + .571784440733980642101712125e+00, + .184699876959596092801262547e+00, + .384410125775084107229541456e-01, + .477475914272399601740818883e-02, + .151734058829700925162000373e-03, + -.248639208901374031411609873e-04, + -.633002360430352916354621750e-05) + c7 = Base.Math.@horner(z, .344367606892381545765962366e-03, + .605983804794748515383615779e-03, + .208913588225005764102252127e-03, + .462793722775687016808279009e-04, + .972342656522493967167788395e-05) + c7 /= Base.Math.@horner(z,1.0, + .160951809815647533045690195e+01, + .133753662990343866552766613e+01, + .682159830165959997577293001e+00, + .230812334251394761909158355e+00, + .497403555098433701440032746e-01, + .621296161441756044580440529e-02, + .215964480325937088444595990e-03) + c8 = Base.Math.@horner(z, -.652623918595320914510590273e-03, + -.353272052089782073130912603e-03, + -.282551884312564905942488077e-04, + -.192877995065652524742879002e-04, + -.231069438570167401077137510e-05) + c8 /= Base.Math.@horner(z,1.0, + .182765408802230546887514255e+01, + .172269407630659768618234623e+01, + .101702505946784412105505734e+01, + .407929996207245634766606879e+00, + .110127834209242088316741250e+00, + .189231675289329563916597032e-01, + .156052480203446255774109882e-02) + c9 = Base.Math.@horner(z, -.596761290192642722092337263e-03, + -.109151697941931403194363814e-02, + -.377126645910917006921076652e-03, + -.120148495117517992204095691e-03, + -.203007139532451428594124139e-04) + c9 /= Base.Math.@horner(z,1.0, + .170833470935668756293234818e+01, + .156222230858412078350692234e+01, + .881575022436158946373557744e+00, + .335555306170768573903990019e+00, + .803149717787956717154553908e-01, + .108808775028021530146610124e-01) + c10 =Base.Math.@horner(z, .133244544950730832649306319e-02, + .580375987713106460207815603e-03, + -.352503880413640910997936559e-04, + .475862254251166503473724173e-04) + c10/=Base.Math.@horner(z, 1.0, + .187235769169449339141968881e+01, + .183146436130501918547134176e+01, + .110810715319704031415255670e+01, + .448280675300097555552484502e+00, + .114651544043625219459951640e+00, + .161103572271541189817119144e-01) + c11 =Base.Math.@horner(z, .157972766214718575927904484e-02, + .246371734409638623215800502e-02, + .717725173388339108430635016e-05, + .121185049262809526794966703e-03) + c11/=Base.Math.@horner(z, 1.0, + .145670749780693850410866175e+01, + .116082103318559904744144217e+01, + .505939635317477779328000706e+00, + .131627017265860324219513170e+00, + .794610889405176143379963912e-02) + c12 =Base.Math.@horner(z, -.407251199495291398243480255e-02, + -.214376520139497301154749750e-03, + .650624975008642297405944869e-03, + -.246294151509758620837749269e-03) + c12/=Base.Math.@horner(z, 1.0, + .162497775209192630951344224e+01, + .140298208333879535577602171e+01, + .653453590771198550320727688e+00, + .168390445944818504703640731e+00) + c13 =Base.Math.@horner(z, -.594758070915055362667114240e-02, + -.109727312966041723997078734e-01, + -.159520095187034545391135461e-02) + c13/=Base.Math.@horner(z, 1.0, + .175409273929961597148916309e+01, + .158706682625067673596619095e+01, + .790935125477975506817064616e+00, + .207815761771742289849225339e+00) + c14 =Base.Math.@horner(z, .175722793448246103440764372e-01, + -.119636668153843644820445054e-01, + .245543970647383469794050102e-02) + c14/=Base.Math.@horner(z, 1.0, + .100158659226079685399214158e+01, + .676925518749829493412063599e+00) + c15 =Base.Math.@horner(z, .400765463491067514929787780e-01, + .588261033368548917447688791e-01) + c15/=Base.Math.@horner(z, 1.0, + .149189509890654955611528542e+01, + .124266359850901469771032599e+01) + c16 = (.119522261141925960204472459e+00*z + + -.100326700196947262548667584e+00) / + (.536462039767059451769400255e+00*z + 1.0) + + t = (.724036968309299822373280436e+00*u + + -.259949826752497731336860753e+00)*u + c16 + t = (((((((((((((((t*u + c15)*u + c14)*u + c13)*u + c12)*u + c11)*u + c10)*u + c9)*u + c8)*u + c7)*u + c6)*u + +c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 + + if l >= 1.0 # go to 10 + qans = e*(w + rt2pin*t/rta) + return 0.5 + (0.5 - qans), qans + end + ans = e*(w - rt2pin*t/rta) + return ans, 0.5 + (0.5 - ans) +end + +# The inverse incomplete Gamma ratio function +# Translated from NSWC +function dginv(a::Real, p::Real, q::Real) +#----------------------------------------------------------------------- +# +# DOUBLE PRECISION +# INVERSE INCOMPLETE GAMMA RATIO FUNCTION +# +# GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. +# THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER +# ITERATION IS EMPLOYED. +# +# ------------ +# +# X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, +# AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT +# NUMBER AVAILABLE. OTHERWISE, DGINV ATTEMPTS TO OBTAIN +# A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE +# IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. +# +# IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +# WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING +# VALUES ... +# +# IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS +# NOT USED. +# IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS +# WERE PERFORMED. +# IERR = -2 (INPUT ERROR) A .LE. 0 +# IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A +# IS TOO LARGE. +# IERR = -4 (INPUT ERROR) P OR Q IS NEGATIVE, OR +# P + Q .NE. 1. +# IERR = -6 10 ITERATIONS WERE PERFORMED. THE MOST +# RECENT VALUE OBTAINED FOR X IS GIVEN. +# (THIS SETTING SHOULD NEVER OCCUR.) +# IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. +# THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. +# IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE +# ROUTINE IS NOT CERTAIN OF ITS ACCURACY. +# ITERATION CANNOT BE PERFORMED IN THIS +# CASE. THIS SETTING CAN OCCUR ONLY WHEN +# P OR Q IS APPROXIMATELY 0. +# +#----------------------------------------------------------------------- +# WRITTEN BY ALFRED H. MORRIS, JR. +# NAVAL SURFACE WARFARE CENTER +# DAHLGREN, VIRGINIA +# WRITTEN ... JANUARY 1992 +#------------------------ + # DOUBLE PRECISION A, X, P, Q + # REAL P0, Q0, X0 + # DOUBLE PRECISION AM1, APN, AP1, AP2, AP3, B, C, C1, C2, C3, C4, + # * C5, D, E, EPS, G, H, LN10, PN, QG, QN, R, RTA, + # * S, SUM, S2, T, TOL, U, W, XMIN, XN, Y, Z, AMIN + # DOUBLE PRECISION DPMPAR, DLNREL, DGAMMA, DGAMLN, DGMLN1, DRCOMP +#------------------------ +# LN10 = LN(10) +# C = EULER CONSTANT +#------------------------ + ln10 = 2.302585 + c = γ +#------------------------ + tol = 1.e-10 +#------------------------ +# +# ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE +# SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN +# IS THE SMALLEST POSITIVE NUMBER. +# + e = eps(typeof(float(a))) + xmin = realmin(float(a)) +# +#------------------------ + x = 0.0 + if a <= 0.0 throw(DomainError()) end + if p < 0.0 || q < 0.0 throw(DomainError()) end + t = ((p + q) - 0.5) - 0.5 + if abs(t) > 5.0*max(e,1.e-30) throw(DomainError()) end + ierr = 0 + xmin /= e + if p/e <= xmin return 0.0 end + if q/e <= xmin return realmax() end + if a == 1.0 + if q >= 0.9 # go to 411 + return -dlnrel(-p) + end + return -log(q) + end + e = max(e, 1.e-30) + deps = 1.e3*e + amin = 5.e3 + if e < 1.e-17 amin = 2.e6 end + xn = 0.0 + useP = true + while true + if a < amin # go to 50 + +# GET AN INITIAL APPROXIMATION USING THE SINGLE +# PRECISION ARITHMETIC (IF THIS IS POSSIBLE) + + p0 = float32(p) + q0 = float32(q) + if p0 != 0.0 && q0 != 0.0 # go to 10 + x0, ier = gaminv(float32(a), 0.0f0, p0, q0) + if ier >= 0 || ier == -8 # go to 10 + ierr = max(ier,0) + if x0 <= 1.f34 # go to 10 + xn = float64(x0) + break + end + end + end + + if a <= 1.0 # go to 50 + xn = 0.0 + +# SELECTION OF THE INITIAL APPROXIMATION XN OF X +# WHEN A .LT. 1 + + g = gamma(a + 1.0) + qg = q*g + if qg == 0.0 return realmax() end + b = qg/a + if qg <= 0.6*a # go to 30 + if a < 0.30 && b >= 0.35 # go to 20 + t = exp(-(b + c)) + u = t*exp(t) + xn = t*exp(u) + break + end + end + if b < 0.45 # go to 30 + if b == 0.0 return realmax() end + y = -log(b) + s = 0.5 + (0.5 - a) + z = log(y) + t = y - s*z + if b >= 0.15 # go to 21 + xn = y - s*log(t) - log(1.0 + s/(t + 1.0)) + useP = false + break + end + if b > 1.e-2 # go to 22 + u = ((t + 2.0*(3.0 - a))*t + (2.0 - a)*(3.0 - a))/((t + (5.0 - a))*t + 2.0) + xn = y - s*log(t) - log(u) + useP = false + break + end + c1 = -s*z + c2 = -s*(1.0 + c1) + c3 = s*((0.5*c1 + (2.0 - a))*c1 + (2.5 - 1.5*a)) + c4 = -s*(((c1/3.0 + (2.5 - 1.5*a))*c1 + ((a - 6.0)*a + 7.0))*c1 + ((11.0*a - 46.0)*a + 47.0)/6.0) + c5 = -s*((((-c1/4.0 + (11.0*a - 17.0)/6.0)*c1 + ((-3.0*a + 13.0)*a - 13.0))*c1 + 0.5*(((2.0*a - 25.0)*a + 72.0)*a - 61.0))*c1 + (((25.0*a - 195.0)*a + 477.0)*a - 379.0)/12.0) + xn = ((((c5/y + c4)/y + c3)/y + c2)/y + c1) + y + useP = false + break + end + if b*q <= 1.0e-8 # go to 31 + xn = exp(-(q/a + c)) + elseif p > 0.9 # go to 32 + xn = exp((dlnrel(-q) + dgmln1(a))/a) + else + xn = exp(log(p*g)/a) + end + + if xn == 0.0 return 0.0 end # This one is in fact ierr=-3 in NSWC + t = 0.5 + (0.5 - xn/(a + 1.0)) + xn /= t + break + end + end + +# SELECTION OF THE INITIAL APPROXIMATION XN OF X +# WHEN A .GT. 1 + + s = p <= 0.5 ? Φinv(p) : -Φinv(q) + rta = sqrt(a) + s2 = s*s + xn = (((12.0*s2 - 243.0)*s2 - 923.0)*s2 + 1472.0)/204120.0 - s*(((3753.0*s2 + 4353.0)*s2 - 289517.0)*s2 - 289717.0)/(146966400.0*rta) + xn = (xn/a + s*((9.0*s2 + 256.0)*s2 - 433.0)/(38880.0*rta)) - ((3.0*s2 + 7.0)*s2 - 16.0)/810.0 + xn = a + s*rta + (s2 - 1.0)/3.0 + s*(s2 - 7.0)/(36.0*rta) + xn/a + xn = max(xn, 0.0) + if a >= amin # go to 60 + x = xn + d = 0.5 + (0.5 - x/a) + if abs(d) <= 1.e-1 # go to 60 + if abs(d) > 1.e-3 break end + return x + end + end + + if p > 0.5 # go to 70 + if xn < 3.*a + useP = false + break + end + w = log(q) + y = -(w + lgamma(a)) + d = max(2.0, a*(a - 1.0)) + if y >= ln10*d # go to 61 + s = 1.0 - a + z = log(y) + c1 = -s*z + c2 = -s*(1.0 + c1) + c3 = s*((0.5*c1 + (2.0 - a))*c1 + (2.5 - 1.5*a)) + c4 = -s*(((c1/3.0 + (2.5 - 1.5*a))*c1 + ((a - 6.0)*a + 7.0))*c1 + ((11.0*a - 46.0)*a + 47.0)/6.0) + c5 = -s*((((-c1/4.0 + (11.0*a - 17.0)/6.0)*c1 + ((-3.0*a + 13.0)*a - 13.0))*c1 + 0.5*(((2.0*a - 25.0)*a + 72.0)*a - 61.0))*c1 + (((25.0*a - 195.0)*a + 477.0)*a - 379.0)/12.0) + xn = ((((c5/y + c4)/y + c3)/y + c2)/y + c1) + y + useP = false + break + end + t = a - 1.0 + xn = y + t*log(xn) - dlnrel(-t/(xn + 1.0)) + xn = y + t*log(xn) - dlnrel(-t/(xn + 1.0)) + useP = false + break + end + + ap1 = a + 1.0 + if xn > 0.7*ap1 break end + w = log(p) + lgamma(ap1) + if xn <= 0.15*ap1 # go to 80 + ap2 = a + 2.0 + ap3 = a + 3.0 + x = exp((w + x)/a) + x = exp((w + x - log(1.0 + (x/ap1)*(1.0 + x/ap2)))/a) + x = exp((w + x - log(1.0 + (x/ap1)*(1.0 + x/ap2)))/a) + x = exp((w + x - log(1.0 + (x/ap1)*(1.0 + (x/ap2)*(1.0 + x/ap3))))/a) + xn = x + if xn <= 1.e-2*ap1 break end + end + + apn = ap1 + t = xn/apn + sum = 1.0 + t + while true + apn += 1.0 + t *= xn/apn + sum += t + if t <= 1.e-4 break end # go to 81 + end + t = w - log(sum) + xn = exp((xn + t)/a) + xn *= 1.0 - (a*log(xn) - xn - t)/(a - xn) + break + end + +# SCHRODER ITERATION USING P + if p > 0.5 useP = false end + if useP + if p <= xmin return xn end # go to 550 + am1 = (a - 0.5) - 0.5 + + while true + if ierr >= 10 return x end # go to 530 + ierr += 1 + pn, qn = dgrat(a, xn) + if pn == 0.0 || qn == 0.0 return xn end# go to 550 + r = drcomp(a,xn) + if r < xmin return xn end # go to 550 + t = (pn - p)/r + w = 0.5*(am1 - xn) + if abs(t) > 0.1 || abs(w*t) > 0.1 # go to 120 + x = xn*(1.0 - t) + if x <= 0.0 error("Iteration failed") end # go to 540 + d = abs(t) + else # go to 121 + h = t*(1.0 + w*t) + x = xn*(1.0 - h) + if x <= 0.0 error("Iteration failed") end # go to 540 + if abs(w) >= 1.0 && abs(w)*t*t <= deps return x end + d = abs(h) + end + xn = x + if d <= tol # go to 110 + if d <= deps return x end + if abs(p - pn) <= tol*p return x end + end + end + else + +# SCHRODER ITERATION USING Q + + if q <= xmin return xn end # go to 550 + am1 = (a - 0.50) - 0.50 + + while true + if ierr >= 10 return x end # go to 530 + ierr += 1 + pn, qn = dgrat(a, xn) + if pn == 0.0 || qn == 0.0 return xn end # go to 550 + r = drcomp(a,xn) + if r < xmin return xn end # go to 550 + t = (q - qn)/r + w = 0.5*(am1 - xn) + if abs(t) > 0.1 || abs(w*t) > 0.1 # go to 220 + x = xn*(1.0 - t) + if x <= 0.0 error("Iteration failed") end # go to 540 + d = abs(t) + else + h = t*(1.0 + w*t) + x = xn*(1.0 - h) + if x <= 0.0 error("Iteration failed") end # go to 540 + if abs(w) >= 1.0 && abs(w)*t*t <= deps return x end + d = abs(h) + end + xn = x + if d <= tol # go to 210 + if d <= deps return x end + if abs(q - qn) <= tol*q return x end + end + end + end +end + +function gaminv(a::Float32, x0::Float32, p::Float32, q::Float32) +#----------------------------------------------------------------------- +# +# INVERSE INCOMPLETE GAMMA RATIO FUNCTION +# +# GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. +# THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER +# ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X +# TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE +# PARTICULAR COMPUTER ARITHMETIC BEING USED. +# +# ------------ +# +# X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, +# AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT +# NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN +# A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE +# IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. +# +# X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER +# DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET +# X0 .LE. 0. +# +# IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +# WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING +# VALUES ... +# +# IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS +# NOT USED. +# IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS +# WERE PERFORMED. +# IERR = -2 (INPUT ERROR) A .LE. 0 +# IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A +# IS TOO LARGE. +# IERR = -4 (INPUT ERROR) P OR Q IS NEGATIVE, OR +# P + Q .NE. 1. +# IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST +# RECENT VALUE OBTAINED FOR X IS GIVEN. +# THIS CANNOT OCCUR IF X0 .LE. 0. +# IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. +# THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. +# IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE +# ROUTINE IS NOT CERTAIN OF ITS ACCURACY. +# ITERATION CANNOT BE PERFORMED IN THIS +# CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY +# WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS +# POSITIVE THEN THIS CAN OCCUR WHEN A IS +# EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY +# LARGE (SAY A .GE. 1.E20). +# +#----------------------------------------------------------------------- +# WRITTEN BY ALFRED H. MORRIS, JR. +# NAVAL SURFACE WARFARE CENTER +# DAHLGREN, VIRGINIA +# REVISED ... JANUARY 1992 +#------------------------ + # REAL LN10, BMIN(2), EMIN(2) +#------------------------ +# LN10 = LN(10) +# C = EULER CONSTANT +#------------------------ + ln10 = 2.302585f0 + c = .577215664901533f0 +#------------------------ + bmin = [1.f-28, 1.f-13] + emin = [2.f-03, 6.f-03] +#------------------------ + tol = 1.f-5 +#------------------------ +# +# ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE +# SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN +# IS THE SMALLEST POSITIVE NUMBER. +# + e = eps(Float32) + xmin = realmin(Float32) + +#------------------------ + x = 0.0f0 + if a <= 0.0 throw(DomainError()) end # go to 500 + if p < 0.0 || q < 0.0f0 throw(DomainError()) end # go to 520 + t = ((p + q) - 0.5f0) - 0.5f0 + if abs(t) > 5.0f0*max(e,1.f-15) throw(DomainError()) end # go to 520 + + ierr = 0 + xmin /= e + if p/e <= xmin return x, ierr end # go to 400 + if q/e <= xmin return realmax(Float32), -8 end # go to 560 + if a == 1.0f0 # go to 410 + if q >= 0.9f0 # go to 411 + return -alnrel(-p), ierr + end + return -log(q), ierr + end + + e2 = e + e + amax = 0.4f-10/(e*e) + deps = max(100.0f0*e,1.f-10) + iop = 1 + if e > 1.f-10 iop = 2 end + xn = x0 + useP = true + while true + if x0 > 0.0 break end # go to 100 + +# SELECTION OF THE INITIAL APPROXIMATION XN OF X +# WHEN A .LT. 1 + + if a <= 1.0 # go to 50 + g = gamma(a + 1.0f0) + qg = q*g + if qg == 0.0 return realmax(Float32), -8 end # go to 560 + b = qg/a + if qg <= 0.6f0*a # go to 20 + if a < 0.30 && b >= 0.35 # go to 10 + t = exp(-(b + c)) + u = t*exp(t) + xn = t*exp(u) + break + end + if b < 0.45 # go to 20 + if b == 0.0 return realmax(Float32), -8 end # go to 560 + y = -log(b) + s = 0.5f0 + (0.5f0 - a) + z = log(y) + t = y - s*z + if b >= 0.15 # go to 11 + xn = y - s*log(t) - log(1.0f0 + s/(t + 1.0f0)) + useP = false + break + end + if b > 1.f-2 # go to 12 + u = ((t + 2.0f0*(3.0f0 - a))*t + (2.0f0 - a)*(3.0f0 - a))/((t + (5.0f0 - a))*t + 2.0f0) + xn = y - s*log(t) - log(u) + useP = false + break + end + c1 = -s*z + c2 = -s*(1.0f0 + c1) + c3 = s*((0.5f0*c1 + (2.0f0 - a))*c1 + (2.5f0 - 1.5f0*a)) + c4 = -s*(((c1/3.0f0 + (2.5f0 - 1.5f0*a))*c1 + ((a - 6.0f0)*a + 7.0f0))*c1 + ((11.0f0*a - 46.0f0)*a + 47.0f0)/6.0f0) + c5 = -s*((((-c1/4.0f0 + (11.0f0*a - 17.0f0)/6.0f0)*c1 + ((-3.0f0*a + 13.0f0)*a - 13.0f0))*c1 + 0.5f0*(((2.0f0*a - 25.0f0)*a + 72.0f0)*a - 61.0f0))*c1 + (((25.0f0*a - 195.0f0)*a + 477.0f0)*a - 379.0f0)/12.0f0) + xn = ((((c5/y + c4)/y + c3)/y + c2)/y + c1) + y + if a > 1.0 || b > bmin[iop] + useP = false + break + end + return xn, ierr + end + end + + if b*q <= 1.f-8 # go to 21 + xn = exp(-(q/a + c)) + elseif p > 0.9 # go to 22 + xn = exp((alnrel(-q) + gamln1(a))/a) + else + xn = exp(log(p*g)/a) + end + if xn == 0.0 return 0.0f0, -3 end + t = 0.5f0 + (0.5f0 - xn/(a + 1.0f0)) + xn /= t + break + end + +# SELECTION OF THE INITIAL APPROXIMATION XN OF X +# WHEN A .GT. 1 + + t = p - 0.5f0 + if q < 0.5 t = 0.5f0 - q end + s = p <= 0.5 ? Φinv(p) : -Φinv(q) + + rta = sqrt(a) + s2 = s*s + xn = (((12.0f0*s2 - 243.0f0)*s2 - 923.0f0)*s2 + 1472.0f0)/204120.0f0 + xn = (xn/a + s*((9.0f0*s2 + 256.0f0)*s2 - 433.0f0)/(38880.0f0*rta)) - ((3.0f0*s2 + 7.0f0)*s2 - 16.0f0)/810.0f0 + xn = a + s*rta + (s2 - 1.0f0)/3.0f0 + s*(s2 - 7.0f0)/(36.0f0*rta) + xn/a + xn = max(xn, 0.0f0) + + amin = 20.0f0 + if e < 1.f-8 amin = 250.0f0 end + if a >= amin # go to 60 + x = xn + d = 0.5f0 + (0.5f0 - x/a) + if abs(d) <= 1.f-1 return x, ierr end + end + + if p > 0.5 # go to 70 + if xn < 3.0f0*a + useP = false + break + end + w = log(q) + y = -(w + lgamma(a)) + d = max(2.0f0, a*(a - 1.0f0)) + if y >= ln10*d # go to 61 + s = 1.0f0 - a + z = log(y) + c1 = -s*z + c2 = -s*(1.0f0 + c1) + c3 = s*((0.5f0*c1 + (2.0f0 - a))*c1 + (2.5f0 - 1.5f0*a)) + c4 = -s*(((c1/3.0f0 + (2.5f0 - 1.5f0*a))*c1 + ((a - 6.0f0)*a + 7.0f0))*c1 + ((11.0f0*a - 46.0f0)*a + 47.0f0)/6.0f0) + c5 = -s*((((-c1/4.0f0 + (11.0f0*a - 17.0f0)/6.0f0)*c1 + ((-3.0f0*a + 13.0f0)*a - 13.0f0))*0.5f0*(((2.0f0*a - 25.0f0)*a + 72.0f0)*a - 61.0f0))*c1 + (((25.0f0*a - 195.0f0)*a +.0f0)*a - 379.0f0)/12.0f0) + xn = ((((c5/y + c4)/y + c3)/y + c2)/y + c1) + y + if a > 1.0 || b > bmin[iop] + useP = false + break + end + return xn, ierr + end + t = a - 1.0f0 + xn = y + t*log(xn) - alnrel(-t/(xn + 1.0f0)) + xn = y + t*log(xn) - alnrel(-t/(xn + 1.0f0)) + useP = false + break + end + + ap1 = a + 1.0f0 + if xn > 0.70f0*ap1 break end # go to 101 + w = log(p) + lgamma(ap1) + if xn <= 0.15f0*ap1 # go to 80 + ap2 = a + 2.0f0 + ap3 = a + 3.0f0 + x = exp((w + x)/a) + x = exp((w + x - log(1.0f0 + (x/ap1)*(1.0f0 + x/ap2)))/a) + x = exp((w + x - log(1.0f0 + (x/ap1)*(1.0f0 + x/ap2)))/a) + x = exp((w + x - log(1.0f0 + (x/ap1)*(1.0f0 + (x/ap2)*(1.0f0 + x/ap3))))/a) + xn = x + if xn <= 1.f-2*ap1 # go to 80 + if xn <= emin[iop]*ap1 return x, ierr end + break + end + end + + apn = ap1 + t = xn/apn + sum = 1.0f0 + t + while true + apn += 1.0f0 + t *= xn/apn + sum += t + if t <= 1.f-4 break end + end + t = w - log(sum) + xn = exp((xn + t)/a) + xn *= 1.0f0 - (a*log(xn) - xn - t)/(a - xn) + break + end + +# SCHRODER ITERATION USING P + + if p > 0.5 useP = false end # go to 200 + if useP + while true + if p <= xmin return xn, -8 end # go to 550 + am1 = (a - 0.5f0) - 0.5f0 + if a > amax # go to 110 + d = 0.5f0 + (0.5f0 - xn/a) + if abs(d) <= e2 return xn, -8 end # go to 550 + end + if ierr >= 20 return xn, -6 end # go to 530 + ierr += 1 + pn, qn = gratio(a, xn, 0) + if pn == 0.0 || qn == 0.0 return xn, -8 end # go to 550 + r = rcomp(a, xn) + if r < xmin return xn, -8 end # go to 550 + t = (pn - p)/r + w = 0.5f0*(am1 - xn) + if abs(t) > 0.1 || abs(w*t) > 0.1 # go to 120 + x = xn*(1.0f0 - t) + if x <= 0.0 error("Iteration failed") end # go to 540 + d = abs(t) + else + h = t*(1.0f0 + w*t) + x = xn*(1.0f0 - h) + if x <= 0.0 error("Iteration failed") end # go to 540 + if abs(w) >= 1.0 && abs(w)*t*t <= deps return x, ierr end + d = abs(h) + end + xn = x + if d <= tol # go to 102 + if d <= deps || abs(p - pn) < tol*p return x, ierr end + end + end + end + +# SCHRODER ITERATION USING Q + + while true + if q <= xmin return xn, -8 end # go to 550 + am1 = (a - 0.5f0) - 0.5f0 + if a > amax # go to 210 + d = 0.5f0 + (0.5f0 - xn/a) + if abs(d) <= e2 return xn, -8 end # go to 550 + end + + if ierr >= 20 return x, -6 end # go to 530 + ierr += 1 + pn, qn = gratio(a, xn, 0) + if pn == 0.0 || qn == 0.0 return xn, -8 end # go to 550 + r = rcomp(a, xn) + if r < xmin return xn, -8 end # go to 550 + t = (q - qn)/r + w = 0.5f0*(am1 - xn) + if abs(t) > 0.1 || abs(w*t) > 0.1 # go to 220 + x = xn*(1.0f0 - t) + if x <= 0.0 error("Iteration failed") end # go to 540 + d = abs(t) + else + h = t*(1.0f0 + w*t) + x = xn*(1.0f0 - h) + if x <= 0.0 error("Iteration failed") end # go to 540 + if abs(w) >= 1.0 && abs(w)*t*t <= deps return x, ierr end + d = abs(h) + end + xn = x + if d <= tol # go to 201 + if d <= deps || abs(q - qn) <= tol*q return x, ierr end + end + end +end + + +# The regularized incomplete beta function +# Translated from the NSWC Library +function bratio(a::Real, b::Real, x::Real) +# SUBROUTINE BRATIO (A, B, X, Y, W, W1, IERR) +#----------------------------------------------------------------------- +# +# EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) +# -------------------- +# +# IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X <= 1 +# AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES +# +# W = IX(A,B) +# W1 = 1 - IX(A,B) +# +# IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +# IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND +# W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, +# THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO +# ONE OF THE FOLLOWING VALUES ... +# +# IERR = 1 IF A OR B IS NEGATIVE +# IERR = 2 IF A = B = 0 +# IERR = 3 IF X < 0 OR X > 1 +# IERR = 4 IF Y < 0 OR Y > 1 +# IERR = 5 IF X + Y != 1 +# IERR = 6 IF X = A = 0 +# IERR = 7 IF Y = B = 0 +# +#-------------------- +# WRITTEN BY ALFRED H. MORRIS, JR. +# NAVAL SURFACE WARFARE CENTER +# DAHLGREN, VIRGINIA +# REVISED ... NOV 1991 +#----------------------------------------------------------------------- +# REAL LAMBDA +#----------------------------------------------------------------------- +# +# ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST +# FLOATING POINT NUMBER FOR WHICH 1.0 + EPS > 1.0 +# +# EPS = SPMPAR(1) +# +#----------------------------------------------------------------------- + precision = eps(float(x)) + w = 0.0 + w1 = 0.0 + y = 1.0 - x + if a < 0.0 || b < 0.0 error("a and b must be non-negative") end + if a == 0.0 && b == 0.0 error("Either a or b must positive") end + if x < 0.0 || x > 1.0 error("x must be between zero and one") end + + if x == 0.0 + if a == 0.0 error("Either x or a must be positive") end + return 0.0 + end + if y == 0.0 + if a == 0.0 error("Either x must be less than one or b must be positive") end + return 1.0 + end + if a == 0.0 return 1.0 end + if b == 0.0 return 0.0 end + + if max(a,b) < 1.e-3*precision return b/(a + b) end + + ind = false + a0 = a + b0 = b + x0 = x + y0 = y + if min(a0, b0) <= 1.0 + +# PROCEDURE FOR A0 <= 1 OR B0 <= 1 + + if x > 0.5 + ind = true + a0 = b + b0 = a + x0 = y + y0 = x + end + + if b0 < min(precision,precision*a0) # go to 80 + w = fpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if a0 < min(precision,precision*b0) && b0*x0 <= 1.0 # go to 90 + w1 = apser(a0, b0, x0, precision) + return ind ? w1 : 1.0 - w1 + end + if max(a0, b0) <= 1.0 # go to 20 + if a0 >= min(0.2, b0) # go to 100 + w = bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if x0^a0 <= 0.9 # go to 100 + w = bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if x0 >= 0.3 # go to 110 + w1 = bpser(b0, a0, y0, precision) + return ind ? w1 : 1.0 - w1 + end + n = 20 + w1 = bup(b0, a0, y0, x0, n, precision) # go to 130 + b0 += n + w1 = bgrat(b0, a0, y0, x0, w1, 15.0*precision) + return ind ? w1 : 1.0 - w1 + end + + if b0 <= 1.0 # go to 100 + w = bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if x0 >= 0.3 # go to 110 + w1 = bpser(b0, a0, y0, precision) + return ind ? w1 : 1.0 - w1 + end + if x0 < 0.1 # go to 21 + if (x0*b0)^a0 <= 0.7 # go to 100 + w = bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + end + if b0 > 15.0 # go to 131 + w1 = bgrat(b0, a0, y0, x0, w1, 15.0*precision) + return ind ? w1 : 1.0 - w1 + end + n = 20 + w1 = bup(b0, a0, y0, x0, n, precision) # go to 130 + b0 += n + w1 = bgrat(b0, a0, y0, x0, w1, 15.0*precision) + return ind ? w1 : 1.0 - w1 + end + +# PROCEDURE FOR A0 > 1 AND B0 > 1 + + if a <= b # go to 31 + lambda = a - (a + b)*x + else + lambda = (a + b)*y - b + end + if lambda < 0.0 # go to 40 + ind = true + a0 = b + b0 = a + x0 = y + y0 = x + lambda = abs(lambda) + end + + if b0 < 40.0 && b0*x0 <= 0.7 # go to 100 + w = bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if b0 < 40.0 # go to 140 + n = itrunc(b0) + b0 -= n + if b0 == 0.0 # go to 141 + n -= 1 + b0 = 1.0 + end + w = bup(b0, a0, y0, x0, n, precision) + if x0 <= 0.7 # go to 150 + w += bpser(a0, b0, x0, precision) + return ind ? 1.0 - w : w + end + if a0 <= 15.0 # go to 151 + n = 20 + w += bup(a0, b0, x0, y0, n, precision) + a0 += n + end + w = bgrat(a0, b0, x0, y0, w, 15.0*precision) + return ind ? 1.0 - w : w + end + if a0 <= b0 # go to 50 + if a0 <= 100.0 || lambda > 0.03*a0 # go to 120 + w = bfrac(a0, b0, x0, y0, lambda, 15.0*precision) + return ind ? 1.0 - w : w + end + w = basym(a0, b0, lambda, 100.0*precision) + return ind ? 1.0 - w : w + end + if b0 <= 100.0 # go to 120 + w = bfrac(a0, b0, x0, y0, lambda, 15.0*precision) + return ind ? 1.0 - w : w + end + if lambda > 0.03*b0 # go to 120 + w = bfrac(a0, b0, x0, y0, lambda, 15.0*precision) + return ind ? 1.0 - w : w + end + w = basym(a0, b0, lambda, 100.0*precision) + return ind ? 1.0 - w : w +end + +## Auxilliary functions + +function fpser(a::Real, b::Real, x::Real, precision::Real) +# REAL FUNCTION FPSER (A, B, X, EPS) +#----------------------------------------------------------------------- +# +# EVALUATION OF I (A,B) +# X +# +# FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. +# +#----------------------------------------------------------------------- +# +# SET FPSER = X**A +# + fpserval = x^a + if fpserval < precision return 0.0 end +# note that 1/b(a,b) = b + + fpserval *= b/a + tol = precision/a + an = a + 1.0 + t = x + s = t/an + while abs(c) > tol + an += 1.0 + t *= x + c = t/an + s += c + end + fpserval *= 1.0 + a*s + return fpserval +end + +function apser(a::Real, b::Real, x::Real, precision::Real) +# REAL FUNCTION APSER (A, B, X, EPS) +#----------------------------------------------------------------------- +# APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR +# A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN +# A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. +#----------------------------------------------------------------------- +# REAL J +#-------------------- + g = 0.57721566490153286 +#-------------------- + bx = b*x + t = x - bx + if (b*precision <= 2.e-2) # go to 10 + c = log(x) + digamma(b) + g + t + else + c = log(bx) + g + t + end + + tol = 5.0*precision*abs(c) + j = 1.0 + s = 0.0 + aj = t + while (abs(aj) > tol) + j += 1.0 + t *= x - bx/j + aj = t/j + s += aj + end + return -a*(c + s) +end + +function bpser(a::Real, b::Real, x::Real, precision::Real) +# REAL FUNCTION BPSER(A, B, X, EPS) +#----------------------------------------------------------------------- +# POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 +# OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. +#----------------------------------------------------------------------- +# REAL N +# +# BPSER = 0.0 + if (x == 0.0) return 0.0 end +#----------------------------------------------------------------------- +# COMPUTE THE FACTOR X**A/(A*BETA(A,B)) +#----------------------------------------------------------------------- + a0 = min(a,b) + if (a0 >= 1.0) # go to 10 + z = a*log(x) - dbetln(a,b) + bpserval = exp(z)/a + # go to 70 + else + b0 = max(a,b) + if (b0 <= 1.0) + +# PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 + + bpserval = x^a + if (bpserval == 0.0) return 0.0 end + + apb = a + b + if (apb <= 1.0) # go to 20 + z = 1.0 + dgam1(apb) + else + u = a + b - 1.0 + z = (1.0 + dgam1(u))/apb + end + c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + bpserval *= c*(b/apb) + + elseif (b0 < 8.0) +# PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 + + u = dgmln1(a0) + m = itrunc(b0 - 1.0) + if (m >= 1) # go to 50 + c = 1.0 + for i = 1:m + b0 -= 1.0 + c *= b0/(a0 + b0) + end + u += log(c) + end + z = a*log(x) - u + b0 -= 1.0 + apb = a0 + b0 + if (apb <= 1.0) # go to 51 + t = 1.0 + dgam1(apb) + else + u = a0 + b0 - 1.0 + t = (1.0 + dgam1(u))/apb + end + bpserval = exp(z)*(a0/a)*(1.0 + dgam1(b0))/t + else + +# PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 + + u = dgmln1(a0) + dlgdiv(a0,b0) + z = a*log(x) - u + bpserval = (a0/a)*exp(z) + end + end + if (bpserval == 0.0 || a <= 0.1*precision) return bpserval end +#----------------------------------------------------------------------- +# COMPUTE THE SERIES +#----------------------------------------------------------------------- + sumval = 0.0 + n = 0.0 + c = 1.0 + tol = precision/a + w = c + while abs(w) > tol + n += 1.0 + c *= (0.5 + (0.5 - b/n))*x + w = c/(a + n) + sumval += w + end + return bpserval*(1.0 + a*sumval) +end + +function bup(a::Real, b::Real, x::Real, y::Real, n::Integer, precision::Real) +# REAL FUNCTION BUP(A, B, X, Y, N, EPS) +#----------------------------------------------------------------------- +# EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. +# EPS IS THE TOLERANCE USED. +#----------------------------------------------------------------------- +# REAL L +# +# OBTAIN THE SCALING FACTOR EXP(-MU) AND +# EXP(MU)*(X**A*Y**B/BETA(A,B))/A +# + apb = a + b + ap1 = a + 1.0 + mu = 0 + d = 1.0 + if (n != 1 && a >= 1.0 && apb >= 1.1*ap1) # go to 10 + mu = itrunc(abs(dxparg(true))) + k = itrunc(dxparg(false)) + if (k < mu) mu = k end + t = mu + d = exp(-t) + end + bupval = brcmp1(mu,a,b,x,y)/a + if (n == 1 || bupval == 0.0) return bupval end + nm1 = n - 1 + w = d + +# LET K BE THE INDEX OF THE MAXIMUM TERM + + k = 0 + while true + if (b <= 1.0) break end# go to 40 + if (y <= 1.e-4) # go to 20 + k = nm1 + else + r = (b - 1.0)*x/y - a + if (r < 1.0) break end + k = nm1 + t = nm1 + if (r < t) k = itrunc(r) end + end + +# ADD THE INCREASING TERMS OF THE SERIES + + for i = 1:k + l = i - 1 + d *= ((apb + l)/(ap1 + l))*x + w += d + end + if (k == nm1) return bupval*w end + break + end + +# ADD THE REMAINING TERMS OF THE SERIES + kp1 = k + 1 + for i = kp1:nm1 + l = i - 1 + d *= ((apb + l)/(ap1 + l))*x + w += d + if (d <= precision*w) break end + end + +# terminate the procedure + return bupval*w +end + +function bfrac(a::Real, b::Real, x::Real, y::Real, lambda::Real, precision::Real) +# REAL FUNCTION BFRAC(A, B, X, Y, LAMBDA, EPS) +#----------------------------------------------------------------------- +# CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. +# IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. +#----------------------------------------------------------------------- +# REAL LAMBDA, N +#-------------------- + bfracval = brcomp(a,b,x,y) + if (bfracval == 0.0) return 0.0 end + + c = 1.0 + lambda + c0 = b/a + c1 = 1.0 + 1.0/a + yp1 = y + 1.0 + + n = 0.0 + p = 1.0 + s = a + 1.0 + an = 0.0 + bn = 1.0 + anp1 = 1.0 + bnp1 = c/c1 + r = c1/c + +# CONTINUED FRACTION CALCULATION + + while true + n += 1.0 + t = n/a + w = n*(b - n)*x + e = a/s + alpha = (p*(p + c0)*e*e)*(w*x) + e = (1.0 + t)/(c1 + t + t) + beta = n + w/s + e*(c + n*yp1) + p = 1.0 + t + s += 2.0 + +# update an, bn, anp1, and bnp1 + + t = alpha*an + beta*anp1 + an = anp1 + anp1 = t + t = alpha*bn + beta*bnp1 + bn = bnp1 + bnp1 = t + + r0 = r + r = anp1/bnp1 + if (abs(r - r0) < precision*r) break end + +# rescale an, bn, anp1, and bnp1 + + an /= bnp1 + bn /= bnp1 + anp1 = r + bnp1 = 1.0 + end + +# TERMINATION + + return bfracval*r +end + +function brcomp(a::Real, b::Real, x::Real, y::Real) +# REAL FUNCTION BRCOMP (A, B, X, Y) +#----------------------------------------------------------------------- +# EVALUATION OF X**A*Y**B/BETA(A,B) +#----------------------------------------------------------------------- +# REAL LAMBDA, LNX, LNY +#----------------- +# CONST = 1/SQRT(2*PI) +#----------------- + cnst = .398942280401433 + + brcompval = 0.0 + if (x == 0.0 || y == 0.0) return brcompval end + a0 = min(a,b) + if (a0 < 8.0) # go to 100 + + if (x <= 0.375)# go to 10 + lnx = log(x) + lny = dlnrel(-x) + elseif (y <= 0.375)# go to 20 + lnx = dlnrel(-y) + lny = log(y) + else + lnx = log(x) + lny = log(y) + end + + z = a*lnx + b*lny + if (a0 >= 1.0) # go to 30 + z -= dbetln(a,b) + return exp(z) + end + +#----------------------------------------------------------------------- +# PROCEDURE FOR A .LT. 1 OR B .LT. 1 +#----------------------------------------------------------------------- + b0 = max(a,b) + #if (b0 .ge. 8.0) go to 80 + if (b0 <= 1.0) # go to 60 + +# algorithm for b0 .le. 1 + + brcompval = exp(z) + if (brcompval == 0.0) return 0.0 end + + apb = a + b + if (apb <= 1.0) # go to 40 + z = 1.0 + dgam1(apb) + else + u = a + b - 1.0 + z = (1.0 + dgam1(u))/apb + end + + c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + return brcompval*(a0*c)/(1.0 + a0/b0) + elseif (b0 < 8.0) + +# ALGORITHM FOR 1 .LT. B0 .LT. 8 + + u = dgmln1(a0) + n = itrunc(b0 - 1.0) + if (n > 1) # go to 70 + c = 1.0 + for i = 1:n + b0 -= 1.0 + c *= b0/(a0 + b0) + end + u += log(c) + end + + z -= u + b0 -= 1.0 + apb = a0 + b0 + if (apb <= 1.0) + t = 1.0 + dgam1(apb) + else + u = a0 + b0 - 1.0 + t = (1.0 + dgam1(u))/apb + end + return a0*exp(z)*(1.0 + dgam1(b0))/t + else + +# ALGORITHM FOR B0 .GE. 8 + u = dgmln1(a0) + dlgdiv(a0,b0) + return a0*exp(z - u) + end + end +#----------------------------------------------------------------------- +# PROCEDURE FOR A .GE. 8 AND B .GE. 8 +#----------------------------------------------------------------------- + if (a <= b) # go to 101 + h = a/b + x0 = h/(1.0 + h) + y0 = 1.0/(1.0 + h) + lambda = a - (a + b)*x + else + h = b/a + x0 = 1.0/(1.0 + h) + y0 = h/(1.0 + h) + lambda = (a + b)*y - b + end + e = -lambda/a + if (abs(e) <= 0.6) # go to 111 + u = drlog1(e) + else + u = e - log(x/x0) + end + + e = lambda/b + if (abs(e) <= 0.6) # go to 121 + v = drlog1(e) + else + v = e - log(y/y0) + end + z = exp(-(a*u + b*v)) + return cnst*sqrt(b*x0)*z*exp(-dbcorr(a,b)) +end + +function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) +# REAL FUNCTION BRCMP1 (MU, A, B, X, Y) +#----------------------------------------------------------------------- +# EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) +#----------------------------------------------------------------------- +# REAL LAMBDA, LNX, LNY +#----------------- +# CONST = 1/SQRT(2*PI) +#----------------- + cnst = 0.3989422804014327 + + brcompval = 0.0 + if (x == 0.0 || y == 0.0) return 0.0 end + a0 = min(a,b) + if (a0 < 8.0) # go to 100 + + if (x <= 0.375)# go to 10 + lnx = log(x) + lny = dlnrel(-x) + elseif (y <= 0.375)# go to 20 + lnx = dlnrel(-y) + lny = log(y) + else + lnx = log(x) + lny = log(y) + end + + z = a*lnx + b*lny + if (a0 >= 1.0) # go to 30 + z -= dbetln(a,b) + return desum(mu, z) + end + +#----------------------------------------------------------------------- +# PROCEDURE FOR A .LT. 1 OR B .LT. 1 +#----------------------------------------------------------------------- + b0 = max(a,b) + #if (b0 .ge. 8.0) go to 80 + if (b0 <= 1.0) # go to 60 + +# algorithm for b0 .le. 1 + + brcompval = exp(mu + z) + if (brcompval == 0.0) return 0.0 end + + apb = a + b + if (apb <= 1.0) # go to 40 + z = 1.0 + dgam1(apb) + else + u = a + b - 1.0 + z = (1.0 + dgam1(u))/apb + end + + c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + return brcompval*(a0*c)/(1.0 + a0/b0) + elseif (b0 < 8.0) + +# ALGORITHM FOR 1 .LT. B0 .LT. 8 + + u = dgmln1(a0) + n = itrunc(b0 - 1.0) + if (n > 1) # go to 70 + c = 1.0 + for i = 1:n + b0 -= 1.0 + c *= b0/(a0 + b0) + end + u += log(c) + end + + z -= u + b0 -= 1.0 + apb = a0 + b0 + if (apb <= 1.0) + t = 1.0 + dgam1(apb) + else + u = a0 + b0 - 1.0 + t = (1.0 + dgam1(u))/apb + end + return a0*exp(mu + z)*(1.0 + dgam1(b0))/t + else + +# ALGORITHM FOR B0 .GE. 8 + + u = dgmln1(a0) + dlgdiv(a0,b0) + return a0*exp(mu + z - u) + end + end +#----------------------------------------------------------------------- +# PROCEDURE FOR A .GE. 8 AND B .GE. 8 +#----------------------------------------------------------------------- + if (a <= b) # go to 101 + h = a/b + x0 = h/(1.0 + h) + y0 = 1.0/(1.0 + h) + lambda = a - (a + b)*x + else + h = b/a + x0 = 1.0/(1.0 + h) + y0 = h/(1.0 + h) + lambda = (a + b)*y - b + end + e = -lambda/a + if (abs(e) <= 0.6) # go to 111 + u = drlog1(e) + else + u = e - log(x/x0) + end + + e = lambda/b + if (abs(e) <= 0.6) # go to 121 + v = drlog1(e) + else + v = e - log(y/y0) + end + z = exp(mu - (a*u + b*v)) + return cnst*sqrt(b*x0)*z*exp(-dbcorr(a,b)) +end + +function bgrat(a::Real, b::Real, x::Real, y::Real, w::Real, precision::Real) +# SUBROUTINE BGRAT(A, B, X, Y, W, EPS, IERR) +#----------------------------------------------------------------------- +# ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. +# THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED +# THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. +# IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +#----------------------------------------------------------------------- +# REAL J, L, LNX, NU, N2 +# REAL C(30), D(30) + + c = Array(Float64, 30) + d = Array(Float64, 30) + + bm1 = (b - 0.5) - 0.5 + nu = a + 0.5*bm1 + if y <= 0.375 + lnx = dlnrel(-y) + else + lnx = log(x) + end + z = -nu*lnx + if (b*z == 0.0) return w end # How should errors be handled? They are ognored in the original progam. ("Cannot calculate expansion") + +# COMPUTATION OF THE EXPANSION +# SET R = EXP(-Z)*Z**B/GAMMA(B) + + r = b*(1.0 + dgam1(b))*z^b + r *= exp(a*lnx)*exp(0.5*bm1*lnx) + u = dlgdiv(b,a) + b*log(nu) + u = r*exp(-u) + if (u == 0.0) return w end # How should errors be handled? They are ognored in the original progam. ("Cannot calculate expansion") + p,q = grat1(b,z,r,precision) + + v = 0.25*(1.0/nu)^2 + t2 = 0.25*lnx*lnx + l = w/u + j = q/r + sumval = j + t = 1.0 + cn = 1.0 + n2 = 0.0 + for n = 1:30 + bp2n = b + n2 + j = (bp2n*(bp2n + 1.0)*j + (z + bp2n + 1.0)*t)*v + n2 += 2.0 + t *= t2 + cn /= n2*(n2 + 1.0) + c[n] = cn + s = 0.0 + if (n > 1) + nm1 = n - 1 + coef = b - n + for i = 1:nm1 + s += coef*c[i]*d[n-i] + coef += b + end + end + d[n] = bm1*cn + s/n + dj = d[n]*j + sumval += dj + if (sumval <= 0.0) return w end # How should errors be handled? They are ognored in the original progam. ("Cannot calculate expansion") + if (abs(dj) <= precision*(sumval + l)) break end + end + +# ADD THE RESULTS TO W + + return w + u*sumval +end + +function grat1(a::Real,x::Real,r::Real,precision::Real) +# SUBROUTINE GRAT1 (A,X,R,P,Q,EPS) +# REAL J, L +#----------------------------------------------------------------------- +# EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS +# P(A,X) AND Q(A,X) +# +# IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. +# THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). +#----------------------------------------------------------------------- + if (a*x == 0.0) return (x <= a ? (0.0, 1.0) : (1.0, 0.0)) end + if (a == 0.5) + if (x < 0.25) # go to 121 + p = erf(sqrt(x)) + return p, 1.0 - p + return + else + q = erfc(sqrt(x)) + return 1.0 - q, q + end + end + if (x < 1.1) # go to 10 + +# TAYLOR SERIES FOR P(A,X)/X**A + + an = 3.0 + c = x + sumval = x/(a + 3.0) + tol = 0.1*precision/(a + 1.0) + t = c + while (abs(t) > tol) + an += 1.0 + c *= -(x/an) + t = c/(a + an) + sumval += t + end + j = a*x*((sumval/6.0 - 0.5/(a + 2.0))*x + 1.0/(a + 1.0)) + + z = a*log(x) + h = dgam1(a) + g = 1.0 + h + while true + if (x >= 0.25) + if (a < x/2.59) break end + else + if (z > -.13394) break end + end + + w = exp(z) + p = w*g*(1.0 - j) + return p, 1.0 - p + break + end + + l = expm1(z) + w = 0.5 + (0.5 + l) + q = (w*j - l)*g - h + if (q < 0.0) return 1.0, 0.0 end + return 1.0 - q, q + +# CONTINUED FRACTION EXPANSION + + else + a2nm1 = 1.0 + a2n = 1.0 + b2nm1 = x + b2n = x + (1.0 - a) + c = 1.0 + am0 = a2nm1/b2nm1 + an0 = a2n/b2n + while (abs(an0 - am0) >= precision*an0) + a2nm1 = x*a2n + c*a2nm1 + b2nm1 = x*b2n + c*b2nm1 + am0 = a2nm1/b2nm1 + c = c + 1.0 + cma = c - a + a2n = a2nm1 + cma*a2n + b2n = b2nm1 + cma*b2n + an0 = a2n/b2n + end + q = r*an0 + return 1.0 - q, q + end +end + +function basym(a::Real, b::Real, lambda::Real, precision::Real) +# REAL FUNCTION BASYM(A, B, LAMBDA, EPS) +#----------------------------------------------------------------------- +# ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. +# LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. +# IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT +# A AND B ARE GREATER THAN OR EQUAL TO 15. +#----------------------------------------------------------------------- +# REAL J0, J1, LAMBDA +#------------------------ +# ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP +# ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. +# THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. +# + num = 20 + a0 = Array(Float64, num + 1) + b0 = Array(Float64, num + 1) + c = Array(Float64, num + 1) + d = Array(Float64, num + 1) + +#------------------------ +# E0 = 2/SQRT(PI) +# E1 = 2**(-3/2) +#------------------------ + e0 = 1.1283791670955126 + e1 = 0.3535533905932737 +#------------------------ + basymval = 0.0 + if (a < b) # go to 10 + h = a/b + r0 = 1.0/(1.0 + h) + r1 = (b - a)/b + w0 = 1.0/sqrt(a*(1.0 + h)) + else + h = b/a + r0 = 1.0/(1.0 + h) + r1 = (b - a)/a + w0 = 1.0/sqrt(b*(1.0 + h)) + end + + f = a*drlog1(-lambda/a) + b*drlog1(lambda/b) + t = exp(-f) + if (t == 0.0) return basymval end + z0 = sqrt(f) + z = 0.5*(z0/e1) + z2 = f + f + + a0[1] = (2.0/3.0)*r1 + c[1] = - 0.5*a0[1] + d[1] = - c[1] + j0 = (0.5/e0)*erfcx(z0) + j1 = e1 + sumval = j0 + d[1]*w0*j1 + s = 1.0 + h2 = h*h + hn = 1.0 + w = w0 + znm1 = z + zn = z2 + for n = 2:2:num + hn = h2*hn + a0[n] = 2.0*r0*(1.0 + h*hn)/(n + 2.0) + np1 = n + 1 + s += hn + a0[np1] = 2.0*r1*s/(n + 3.0) + + for i = n:np1 + r = -0.5*(i + 1.0) + b0[1] = r*a0[1] + for m = 2:i + bsum = 0.0 + mm1 = m - 1 + for j = 1:mm1 + mmj = m - j + bsum += (j*r - mmj)*a0[j]*b0[mmj] + end + b0[m] = r*a0[m] + bsum/m + end + c[i] = b0[i]/(i + 1.0) + + dsum = 0.0 + im1 = i - 1 + for j = 1:im1 + imj = i - j + dsum += d[imj]*c[j] + end + d[i] = -(dsum + c[i]) + end + + j0 = e1*znm1 + (n - 1.0)*j0 + j1 = e1*zn + n*j1 + znm1 *= z2 + zn *= z2 + w *= w0 + t0 = d[n]*w*j0 + w *= w0 + t1 = d[np1]*w*j1 + sumval += t0 + t1 + if ((abs(t0) + abs(t1)) <= precision*sumval) break end + end + + u = exp(-dbcorr(a,b)) + return e0*t*u*sumval +end + +function drlog1(x::Real) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION X - LN(1 + X) +#----------------------------------------------------------------------- +# DOUBLE PRECISION X +# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z +# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C1, C2, C3, C4, C5 +#------------------------- +# A = DRLOG (0.7) +# B = DRLOG (4/3) +#------------------------- + a = 0.566749439387323789126387112411845e-01 + b = 0.456512608815524058941143273395059e-01 +#------------------------- + p0 = .7692307692307692307680e-01 + p1 = -.1505958055914600184836e+00 + p2 = .9302355725278521726994e-01 + p3 = -.1787900022182327735804e-01 + q1 = -.2824412139355646910683e+01 + q2 = .2892424216041495392509e+01 + q3 = -.1263560605948009364422e+01 + q4 = .1966769435894561313526e+00 +#------------------------- +# CI = 1/(2I + 1) +#------------------------- + c1 = .333333333333333333333333333333333e+00 + c2 = .200000000000000000000000000000000e+00 + c3 = .142857142857142857142857142857143e+00 + c4 = .111111111111111111111111111111111e+00 + c5 = .909090909090909090909090909090909e-01 +#------------------------- + if x >= -0.39 && x <= 0.57 # go to 100 + if x < -0.18 # go to 10 + u = (x + 0.3)/0.7 + up2 = u + 2.0 + w1 = a - u*0.3 + elseif x > 0.18 # go to 20 + t = 0.75*x + u = t - 0.25 + up2 = t + 1.75 + w1 = b + u/3.0 + else + u = x + up2 = u + 2.0 + w1 = 0.0 + end +# +# SERIES EXPANSION +# + r = u/up2 + t = r*r +# +# Z IS A MINIMAX APPROXIMATION OF THE SERIES +# +# C6 + C7*R**2 + C8*R**4 + ... +# +# FOR THE INTERVAL (0.0, 0.375). THE APPROX- +# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF +# THE 21-ST SIGNIFICANT DIGIT. +# + z = (((p3*t + p2)*t + p1)*t + p0)/((((q4*t + q3)*t + q2)*t + q1)*t + 1.0) +# + w = ((((z*t + c5)*t + c4)*t + c3)*t + c2)*t + c1 + return r*(u - 2.0*t*w) + w1 +# +# + end + w = (x + 0.5) + 0.5 + return x - log(w) +end + +function dbcorr(a0::Real, b0::Real) +#----------------------------------------------------------------------- +# +# EVALUATION OF DEL(A) + DEL(B0) - DEL(A) + B0) WHERE +# LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). +# IT IS ASSUMED THAT A0 .GE. 10 AND B0 .GE. 10. +# +# -------- +# +# THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS +# DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE +# SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). +# +#----------------------------------------------------------------------- +# DOUBLE PRECISION A0, B0 +# DOUBLE PRECISION A, B, C, E(15), H, S(15), T, W, X, X2, Z + s = Array(Float64, 15) +#-------------------------- + e=[.833333333333333333333333333333e-01, + -.277777777777777777777777752282e-04, + .793650793650793650791732130419e-07, + -.595238095238095232389839236182e-09, + .841750841750832853294451671990e-11, + -.191752691751854612334149171243e-12, + .641025640510325475730918472625e-14, + -.295506514125338232839867823991e-15, + .179643716359402238723287696452e-16, + -.139228964661627791231203060395e-17, + .133802855014020915603275339093e-18, + -.154246009867966094273710216533e-19, + .197701992980957427278370133333e-20, + -.234065664793997056856992426667e-21, + .171348014966398575409015466667e-22] +#-------------------------- + a = min(a0, b0) + b = max(a0, b0) + + h = a/b + c = h/(1.0 + h) + x = 1.0/(1.0 + h) + x2 = x*x +# +# COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,... +# STORE THESE VALUES IN S(1),S(2),... +# + s[1] = 1.0 + for j = 1:14 + s[j+1] = 1.0 + (x + x2*s[j]) + end +# +# SET W = DEL(B) - DEL(A + B) +# + t = (10.0/b)^2 + w = e[15]*s[15] + for j = 1:14 + k = 15 - j + w = t*w + e[k]*s[k] + end + w *= c/b +# +# COMPUTE DEL(A) + W +# + t = (10.0/a)^2 + z = e[15] + for j = 1:14 + k = 15 - j + z = t*z + e[k] + end + return z/a + w +end + +function dlgdiv(a::Real, b::Real) +#----------------------------------------------------------------------- +# +# COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) FOR B .GE. 10 +# +# -------- +# +# DLGDIV USES A SERIES FOR THE FUNCTION DEL(X) WHERE +# LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). +# THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS +# DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE +# SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). +# +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, B +# DOUBLE PRECISION C, D, E(15), H, S(15), T, U, V, W, X, X2 + s = Array(Float64, 15) +# DOUBLE PRECISION DLNREL +#-------------------------- + e=[.833333333333333333333333333333e-01 + -.277777777777777777777777752282e-04 + .793650793650793650791732130419e-07 + -.595238095238095232389839236182e-09 + .841750841750832853294451671990e-11 + -.191752691751854612334149171243e-12 + .641025640510325475730918472625e-14 + -.295506514125338232839867823991e-15 + .179643716359402238723287696452e-16 + -.139228964661627791231203060395e-17 + .133802855014020915603275339093e-18 + -.154246009867966094273710216533e-19 + .197701992980957427278370133333e-20 + -.234065664793997056856992426667e-21 + .171348014966398575409015466667e-22] +#-------------------------- + if (a > b) # go to 10 + h = b/a + c = 1.0/(1.0 + h) + x = h/(1.0 + h) + d = a + (b - 0.5) + else + h = a/b + c = h/(1.0 + h) + x = 1.0/(1.0 + h) + d = b + (a - 0.50) + end +# +# COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,... +# STORE THESE VALUES IN S(1),S(2),... +# + x2 = x*x + s[1] = 1.0 + for j = 1:14 + s[j + 1] = 1.0 + (x + x2*s[j]) + end +# +# SET W = DEL(B) - DEL(A + B) +# + t = (10.0/b)^2 + w = e[15]*s[15] + for j = 1:14 + k = 15 - j + w = t*w + e[k]*s[k] + end + w *= c/b +# +# COMBINE THE RESULTS +# + u = d*dlnrel(a/b) + v = a*(log(b) - 1.0) + if u > v # go to 40 + return (w - v) - u + end + return (w - u) - v +end + +function dlnrel(a::Real) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION LN(1 + A) +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, T, T2, W, Z +# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C1, C2, C3, C4, C5 +#------------------------- + p0 = .7692307692307692307680e-01 + p1 = -.1505958055914600184836e+00 + p2 = .9302355725278521726994e-01 + p3 = -.1787900022182327735804e-01 + q1 = -.2824412139355646910683e+01 + q2 = .2892424216041495392509e+01 + q3 = -.1263560605948009364422e+01 + q4 = .1966769435894561313526e+00 +#------------------------- +# CI = 1/(2I + 1) +#------------------------- + c1 = .3333333333333333333333333333333e+00 + c2 = .2000000000000000000000000000000e+00 + c3 = .1428571428571428571428571428571e+00 + c4 = .1111111111111111111111111111111e+00 + c5 = .9090909090909090909090909090909e-01 +#------------------------- + if abs(a) >= 0.375 # go to 10 + t = 1.0 + a + if a < 0.0 t = 0.50 + (0.50 + a) end + return log(t) + end +# +# W IS A MINIMAX APPROXIMATION OF THE SERIES +# +# C6 + C7*T**2 + C8*T**4 + ... +# +# THIS APPROXIMATION IS ACCURATE TO WITHIN +# 1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT. +# THE RESULTING VALUE FOR 1.D0 + T2*Z IS +# ACCURATE TO WITHIN 1 UNIT OF THE 30-TH +# SIGNIFICANT DIGIT. +# + t = a/(a + 2.0) + t2 = t*t + w = (((p3*t2 + p2)*t2 + p1)*t2 + p0)/((((q4*t2 + q3)*t2 + q2)*t2 + q1)*t2 + 1.0) + + z = ((((w*t2 + c5)*t2 + c4)*t2 + c3)*t2 + c2)*t2 + c1 + return 2.0*t*(1.0 + t2*z) +end + +function alnrel(a::Float32) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION LN(1 + A) +#----------------------------------------------------------------------- + p1 = -.129418923021993f+01 + p2 = .405303492862024f+00 + p3 = -.178874546012214f-01 + q1 = -.162752256355323f+01 + q2 = .747811014037616f+00 + q3 = -.845104217945565f-01 +#-------------------------- + if abs(a) <= 0.375 # go to 10 + t = a/(a + 2.0f0) + t2 = t*t + w = (((p3*t2 + p2)*t2 + p1)*t2 + 1.0f0)/(((q3*t2 + q2)*t2 + q1)*t2 + 1.0f0) + return 2.0f0*t*w + end + + x = 1.0f0 + a + if a < 0.0 x = (a + 0.5f0) + 0.5f0 end + return log(x) +end + +function dbetln(a0::Real, b0::Real) +#----------------------------------------------------------------------- +# EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION +#----------------------------------------------------------------------- +# DOUBLE PRECISION A0, B0 +# DOUBLE PRECISION A, B, C, E, H, SN, U, V, W, Z +# DOUBLE PRECISION DBCORR, DGAMLN, DGSMLN, DLGDIV, DLNREL +#-------------------------- +# E = 0.5*LN(2*PI) +#-------------------------- + e = .9189385332046727417803297364056 +#-------------------------- + a = min(a0,b0) + b = max(a0,b0) + if a < 10.0 # go to 60 + if a < 1.0 # go to 20 +#----------------------------------------------------------------------- +# PROCEDURE WHEN A .LT. 1 +#----------------------------------------------------------------------- + if b < 10.0 # go to 10 + return lgamma(a) + (lgamma(b) - lgamma(a + b)) + else + return lgamma(a) + dlgdiv(a,b) + end + end +#----------------------------------------------------------------------- +# PROCEDURE WHEN 1 .LE. A .LT. 10 +#----------------------------------------------------------------------- + while true + if a <= 2.0 # go to 30 + if b <= 2.0 # go to 21 + return lgamma(a) + lgamma(b) - dgsmln(a,b) + end + w = 0.0 + if b < 10.0 break end # go to 40 + return lgamma(a) + dlgdiv(a,b) + end +# +# REDUCTION OF A WHEN B .LE. 1000 +# + if b > 1.0e3 # go to 50 +# +# REDUCTION OF A WHEN B .GT. 1000 +# + n = itrunc(a - 1.0) + w = 1.0 + for i = 1:n + a -= 1.0 + w *= a/(1.0 + a/b) + end + sn = n + return (log(w) - sn*log(b)) + (lgamma(a) + dlgdiv(a,b)) + end + + n = itrunc(a - 1.0) + w = 1.0 + for i = 1:n + a -= 1.0 + h = a/b + w *= h/(1.0 + h) + end + w = log(w) + if b < 10.0 break end # go to 40 + return w + lgamma(a) + dlgdiv(a,b) + end +# +# REDUCTION OF B WHEN B .LT. 10 +# + n = b - 1.0 + z = 1.0 + for i = 1:n + b -= 1.0 + z *= b/(a + b) + end + return w + log(z) + (lgamma(a) + (lgamma(b) - dgsmln(a,b))) + end +#----------------------------------------------------------------------- +# PROCEDURE WHEN A .GE. 10 +#----------------------------------------------------------------------- + w = dbcorr(a,b) + h = a/b + c = h/(1.0 + h) + u = -(a - 0.50)*log(c) + v = b*dlnrel(h) + if u > v # go to 61 + return (((-0.5*log(b) + e) + w) - v) - u + end + return (((-0.5*log(b) + e) + w) - u) - v +end + +function dgsmln(a::Real, b::Real) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) +# FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 +#----------------------------------------------------------------------- +# DOUBLE PRECISION A, B, X +# DOUBLE PRECISION DGMLN1, DLNREL + + x = (a - 1.0) + (b - 1.0) + if x <= 0.50 # go to 10 + return dgmln1(1.0 + x) + end + if x < 1.50 # go to 20 + return dgmln1(x) + dlnrel(x) + end + return dgmln1(x - 1.0) + log(x*(1.0 + x)) +end + +function desum(mu::Integer, x::Real) +#----------------------------------------------------------------------- +# EVALUATION OF EXP(MU + X) +#----------------------------------------------------------------------- +# DOUBLE PRECISION X, W +# + if x <= 0.0 # go to 10 + + if mu < 0 return exp(mu)*exp(x) end + w = mu + x + if w > 0.0 return exp(mu)*exp(x) end + return exp(w) + end + + if mu > 0 return exp(mu)*exp(x) end + w = mu + x + if w < 0.0 return exp(mu)*exp(x) end + return exp(w) +end + +function dgam1(x::Real) +#----------------------------------------------------------------------- +# EVALUATION OF 1/GAMMA(1 + X) - 1 FOR -0.5 .LE. X .LE. 1.5 +#----------------------------------------------------------------------- +# DOUBLE PRECISION X, D, T, W, Z +# DOUBLE PRECISION A0, A1, B1, B2, B3, B4, B5, B6, B7, B8 +# DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C, C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, +# * C10, C11, C12, C13 +#---------------------------- + a0 = .611609510448141581788e-08 + a1 = .624730830116465516210e-08 + b1 = .203610414066806987300e+00 + b2 = .266205348428949217746e-01 + b3 = .493944979382446875238e-03 + b4 = -.851419432440314906588e-05 + b5 = -.643045481779353022248e-05 + b6 = .992641840672773722196e-06 + b7 = -.607761895722825260739e-07 + b8 = .195755836614639731882e-09 +#---------------------------- + p0 = .6116095104481415817861e-08 + p1 = .6871674113067198736152e-08 + p2 = .6820161668496170657918e-09 + p3 = .4686843322948848031080e-10 + p4 = .1572833027710446286995e-11 + p5 = -.1249441572276366213222e-12 + p6 = .4343529937408594255178e-14 + q1 = .3056961078365221025009e+00 + q2 = .5464213086042296536016e-01 + q3 = .4956830093825887312020e-02 + q4 = .2692369466186361192876e-03 +#---------------------------- +# c = c0 - 1 +#---------------------------- + c = -.422784335098467139393487909917598e+00 +#---------------------------- + c0 = .577215664901532860606512090082402e+00 + c1 = -.655878071520253881077019515145390e+00 + c2 = -.420026350340952355290039348754298e-01 + c3 = .166538611382291489501700795102105e+00 + c4 = -.421977345555443367482083012891874e-01 + c5 = -.962197152787697356211492167234820e-02 + c6 = .721894324666309954239501034044657e-02 + c7 = -.116516759185906511211397108401839e-02 + c8 = -.215241674114950972815729963053648e-03 + c9 = .128050282388116186153198626328164e-03 + c10 = -.201348547807882386556893914210218e-04 + c11 = -.125049348214267065734535947383309e-05 + c12 = .113302723198169588237412962033074e-05 + c13 = -.205633841697760710345015413002057e-06 +#---------------------------- + t = x + d = x - 0.5 + if d > 0.0 t = d - 0.5 end + if t == 0 # 40,10,20 + return 0.0 + elseif t > 0 +#------------ +# +# CASE WHEN 0 .LT. T .LE. 0.5 +# +# W IS A MINIMAX APPROXIMATION FOR +# THE SERIES A(15) + A(16)*T + ... +# +#------------ + w = ((((((p6*t + p5)*t + p4)*t + p3)*t + p2)*t + p1)*t + p0)/((((q4*t + q3)*t + q2)*t + q1)*t + 1.0) + z = (((((((((((((w*t + c13)*t + c12)*t + c11)*t + c10)*t + c9)*t + c8)*t + c7)*t + c6)*t + c5)*t + c4)*t + c3)*t + c2)*t + c1)*t + c0 + + if d <= 0.0 # go to 30 + return x*z + end + return (t/x)*((z - 0.5) - 0.5) + end +#------------ +# +# CASE WHEN -0.5 .LE. T .LT. 0 +# +# W IS A MINIMAX APPROXIMATION FOR +# THE SERIES A(15) + A(16)*T + ... +# +#------------ + w = (a1*t + a0)/((((((((b8*t + b7)*t + b6)*t + b5)*t + b4)*t + b3)*t + b2)*t + b1)*t + 1.0) + z = (((((((((((((w*t + c13)*t + c12)*t + c11)*t + c10)*t + c9)*t + c8)*t + c7)*t + c6)*t + c5)*t + c4)*t + c3)*t + c2)*t + c1)*t + c + + if d <= 0.0 # go to 50 + return x*((z + 0.5d0) + 0.5d0) + end + return t*z/x +end + +function gam1(a::Float32) +#----------------------------------------------------------------------- +# COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 +#----------------------------------------------------------------------- + # REAL P(7), Q(5), R(9) +#------------------------ + t = a + d = a - 0.5f0 + if d > 0.0f0 t = d - 0.5f0 end + if t == 0 # 30,10,20 + return 0.0f0 + elseif t < 0 + top = @horner(t, .577215664901533f+00, + -.409078193005776f+00, + -.230975380857675f+00, + .597275330452234f-01, + .766968181649490f-02, + -.514889771323592f-02, + .589597428611429f-03) + bot = @horner(t,.100000000000000f+01, + .427569613095214f+00, + .158451672430138f+00, + .261132021441447f-01, + .423244297896961f-02) + w = top/bot + if d <= 0.0 # go to 21 + return a*w + end + return (t/a)*((w - 0.5f0) - 0.5f0) + end + + top = @horner(t, -.422784335098468f+00, + -.771330383816272f+00, + -.244757765222226f+00, + .118378989872749f+00, + .930357293360349f-03, + -.118290993445146f-01, + .223047661158249f-02, + .266505979058923f-03, + -.132674909766242f-03) + bot = @horner(t, 1.0f0, + .273076135303957f+00, + .559398236957378f-01) + w = top/bot + if d <= 0.0 # go to 31 + return a*((w + 0.5f0) + 0.5f0) + end + return t*w/a +end + +gamln1(x::Float32) = lgamma(1.0f0 + x) +dgmln1(x::Real) = lgamma(1 + x) +dxparg(bmin::Bool) = (bmin ? log(realmin()) : log(realmax())) +exparg(bmin::Bool) = (bmin ? log(realmin(Float32)) : log(realmax(Float32))) + +### End of regularized incomplete beta function # Multidimensional gamma / partial gamma function function lpgamma(p::Int64, a::Float64) diff --git a/src/univariate/beta.jl b/src/univariate/beta.jl index cb03f264f..d14bc9810 100644 --- a/src/univariate/beta.jl +++ b/src/univariate/beta.jl @@ -10,7 +10,11 @@ end Beta(a::Real) = Beta(a, a) # symmetric in [0, 1] Beta() = Beta(1.0) # uniform -@_jl_dist_2p Beta beta +function cdf(d::Beta, x::Real) + if x >= 1 return 1.0 end + if x <= 0 return 0.0 end + return bratio(d.alpha, d.beta, x) +end function entropy(d::Beta) o = lbeta(d.alpha, d.beta) @@ -42,6 +46,8 @@ end modes(d::Beta) = [mode(d)] +pdf(d::Beta, x::Real) = insupport(d, x) ? brcomp(d.alpha, d.beta, x, 1.0 - x)/(x*(1.0 - x)) : 0.0 + function rand(d::Beta) u = rand(Gamma(d.alpha)) u / (u + rand(Gamma(d.beta))) diff --git a/src/univariate/binomial.jl b/src/univariate/binomial.jl index 836d28865..ef213d788 100644 --- a/src/univariate/binomial.jl +++ b/src/univariate/binomial.jl @@ -16,6 +16,12 @@ max(d::Binomial) = d.size @_jl_dist_2p Binomial binom +function cdf(d::Binomial, x::Real) + if x >= d.size return 1.0 end + if x < 0 return 0.0 end + return cdf(Beta(d.size - x, x + 1.0), 1.0 - d.prob) +end + function entropy(d::Binomial; approx::Bool=false) n = d.size p1 = d.prob @@ -35,14 +41,9 @@ function entropy(d::Binomial; approx::Bool=false) end insupport(d::Binomial, x::Real) = isinteger(x) && 0 <= x <= d.size - kurtosis(d::Binomial) = (1.0 - 6.0 * d.prob * (1.0 - d.prob)) / var(d) mean(d::Binomial) = d.size * d.prob - -median(d::Binomial) = iround(d.size * d.prob) - -# TODO: May need to subtract 1 sometimes mode(d::Binomial) = iround((d.size + 1.0) * d.prob) modes(d::Binomial) = [mode(d)] @@ -56,7 +57,7 @@ function cf(d::Binomial, t::Real) (1.0 - p + p * exp(im * t))^d.size end -modes(d::Binomial) = iround([d.size * d.prob]) +pdf(d::Binomial, x::Real) = insupport(d,x) ? pdf(Beta(d.size - x + 1.0, x + 1.0), 1 - d.prob)::Float64/(d.size + 1) : 0.0 # TODO: rand() is totally screwed up @@ -107,4 +108,3 @@ fit_mle{T<:Integer}(::Type{Binomial}, n::Integer, x::Array{T}) = fit_mle(Binomia fit_mle{T<:Integer}(::Type{Binomial}, n::Integer, x::Array{T}, w::Array{Float64}) = fit_mle(Binomial, suffstats(Binomial, n, x, w)) fit_mle{T<:Integer}(::Type{Binomial}, data::(Int, Array{T})) = fit_mle(Binomial, suffstats(Binomial, data)) fit_mle{T<:Integer}(::Type{Binomial}, data::(Int, Array{T}), w::Array{Float64}) = fit_mle(Binomial, suffstats(Binomial, data, w)) - diff --git a/src/univariate/gamma.jl b/src/univariate/gamma.jl index dc6219ec1..4c28962bd 100644 --- a/src/univariate/gamma.jl +++ b/src/univariate/gamma.jl @@ -16,6 +16,13 @@ rate(d::Gamma) = 1.0 / d.scale @_jl_dist_2p Gamma gamma +function cdf(d::Gamma, x::Real) + if x < 0 return 0.0 end + return dgrat(d.shape, x/d.scale)[1] +end + +quantile(d::Gamma, α::Real) = dginv(d.shape, α, 1-α)*d.scale + function entropy(d::Gamma) x = (1.0 - d.shape) * digamma(d.shape) x + lgamma(d.shape) + log(d.scale) + d.shape @@ -40,6 +47,8 @@ end modes(d::Gamma) = [mode(d)] +pdf(d::Gamma, x::Real) = insupport(d, x) ? drcomp(d.shape, x/d.scale)/x : 0.0 + # rand() # # A simple method for generating gamma variables - Marsaglia and Tsang (2000) diff --git a/src/univariate/poisson.jl b/src/univariate/poisson.jl index f6708be00..50dfdb60c 100644 --- a/src/univariate/poisson.jl +++ b/src/univariate/poisson.jl @@ -7,7 +7,10 @@ immutable Poisson <: DiscreteUnivariateDistribution Poisson() = new(1.0) end -@_jl_dist_1p Poisson pois +function cdf(d::Poisson, x::Real) + if x < 0 return 0.0 end + dgrat(floor(x), d.lambda)[2] + pdf(d, x) +end function entropy(d::Poisson) λ = d.lambda @@ -47,6 +50,8 @@ end mode(d::Poisson) = ifloor(d.lambda) modes(d::Poisson) = [mode(d)] +pdf(d::Poisson, x::Real) = insupport(d, x) ? drcomp(x, d.lambda)/x : 0.0 + skewness(d::Poisson) = 1.0 / sqrt(d.lambda) var(d::Poisson) = d.lambda diff --git a/test/discrete.jl b/test/discrete.jl index 9c853c082..f48a541bc 100644 --- a/test/discrete.jl +++ b/test/discrete.jl @@ -146,7 +146,7 @@ for d in [ @test_approx_eq mean(d) xmean @test_approx_eq var(d) xvar @test_approx_eq std(d) xstd - @test_approx_eq skewness(d) xskew + @test_approx_eq_eps skewness(d) xskew 1000eps() @test_approx_eq kurtosis(d) xkurt @test_approx_eq entropy(d) xentropy diff --git a/test/univariate.jl b/test/univariate.jl index a02fee81f..618226863 100644 --- a/test/univariate.jl +++ b/test/univariate.jl @@ -37,8 +37,8 @@ for d in [Arcsine(), Chisq(20.0), # Cosine(), # Empirical(), - Erlang(1), - Erlang(17.0), + # Erlang(1), + # Erlang(17.0), Exponential(1.0), Exponential(5.1), FDist(9, 9), @@ -125,7 +125,6 @@ for d in [Arcsine(), # avoid checking high order moments for LogNormal and Logistic avoid_highord = isa(d, LogNormal) || isa(d, Logistic) || isa(d, Truncated) - ##### # # Part 1: Capability of random number generation From b0c3e48218766771b8ef685d21963449e6f0dc0c Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Wed, 18 Sep 2013 16:16:00 +0100 Subject: [PATCH 05/19] rename nswc methods for multiple dispatch --- src/specialfuns.jl | 534 +++++++++++++++++---------------------------- 1 file changed, 198 insertions(+), 336 deletions(-) diff --git a/src/specialfuns.jl b/src/specialfuns.jl index 8bd4d6855..d72fda492 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns.jl @@ -1,5 +1,13 @@ # Special functions +realmaxexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmax(T)),RoundDown) +realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(prevfloat(inf(BigFloat))),RoundDown) + +realminexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmin(T)),RoundUp) +realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(nextfloat(zero(BigFloat))),RoundUp) + + + # See: # Martin Maechler (2012) "Accurately Computing log(1 − exp(− |a|))" # http://cran.r-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf @@ -8,12 +16,12 @@ # NOTE: different than Maechler (2012), no negation inside parantheses log1mexp(x::Real) = x >= -0.6931471805599453 ? log(-expm1(x)) : log1p(-exp(x)) # log(1+exp(x)) -log1pexp(x::Real) = log1p(exp(x)) +log1pexp(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log1p(exp(x)) : x log1pexp(x::Float64) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x log1pexp(x::Float32) = x <= 9f0 ? log1p(exp(x)) : x <= 16f0 ? x + exp(-x) : x log1pexp(x::Integer) = log1pexp(float(x)) # log(exp(x)-1) -logexpm1(x::Real) = log(expm1(x)) +logexpm1(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log(expm1(x)) : x logexpm1(x::Float64) = x <= 18.0 ? log(expm1(x)) : x <= 33.3 ? x - exp(-x) : x logexpm1(x::Float32) = x <= 9f0 ? log(expm1(x)) : x <= 16f0 ? x - exp(-x) : x logexpm1(x::Integer) = logexpm1(float(x)) @@ -265,6 +273,80 @@ function logmxp1(x::Float32) end +# negative of NSWC DRLOG1 +function log1pmx(x::Float64) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION X - LN(1 + X) +#----------------------------------------------------------------------- +# DOUBLE PRECISION X +# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z +# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C1, C2, C3, C4, C5 +#------------------------- +# A = DRLOG (0.7) +# B = DRLOG (4/3) +#------------------------- + a = 0.566749439387323789126387112411845e-01 + b = 0.456512608815524058941143273395059e-01 +#------------------------- +#------------------------- +# CI = 1/(2I + 1) +#------------------------- +#------------------------- + if x >= -0.39 && x <= 0.57 # go to 100 + if x < -0.18 # go to 10 + u = (x + 0.3)/0.7 + up2 = u + 2.0 + w1 = a - u*0.3 + elseif x > 0.18 # go to 20 + t = 0.75*x + u = t - 0.25 + up2 = t + 1.75 + w1 = b + u/3.0 + else + u = x + up2 = u + 2.0 + w1 = 0.0 + end +# +# SERIES EXPANSION +# + r = u/up2 + t = r*r +# +# Z IS A MINIMAX APPROXIMATION OF THE SERIES +# +# C6 + C7*R**2 + C8*R**4 + ... +# +# FOR THE INTERVAL (0.0, 0.375). THE APPROX- +# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF +# THE 21-ST SIGNIFICANT DIGIT. +# + z = @horner(t, + .7692307692307692307680e-01, + -.1505958055914600184836e+00, + .9302355725278521726994e-01, + -.1787900022182327735804e-01) / + @horner(t,1.0, + -.2824412139355646910683e+01, + .2892424216041495392509e+01, + -.1263560605948009364422e+01, + .1966769435894561313526e+00) + w = @horner(t, + .333333333333333333333333333333333e+00, + .200000000000000000000000000000000e+00, + .142857142857142857142857142857143e+00, + .111111111111111111111111111111111e+00, + .909090909090909090909090909090909e-01, + z) + + return r*(2.0*t*w - u) - w1 + end + return log1p(x) - x +end + + + # Stirling series for the gamma function # @@ -282,6 +364,7 @@ stirling(x) = exp(lstirling(x)) # fallback lstirling(x) = lgamma(x)- (x-0.5)*log(x) + x - 0.5*oftype(x,log2π) lstirling(x::Integer) = lstirling(float(x)) + # based on NSWC DPDEL: only valid for values >= 10 # Float32 version? function lstirling(x::Float64) @@ -415,7 +498,7 @@ function gratio(a::Float32, x::Float32, ind::Integer) j = a*x*((sum/6.0f0 - 0.5f0/(a + 2.0f0))*x + 1.0f0/(a + 1.0f0)) z = a*log(x) - h = gam1(a) + h = rgamma1pm1(a) g = 1.0f0 + h if x >= 0.25 # go to 120 if a < x/2.59f0 # go to 135 @@ -474,7 +557,7 @@ function gratio(a::Float32, x::Float32, ind::Integer) l = x/a if l == 0.0 return 0.0f0, 1.0f0 end # go to 300 s = 0.5f0 + (0.5f0 - l) - z = rlog(l) + z = -logmxp1(l) if z >= 700.0f0/a # go to 330 if abs(s) <= 2.0f0*e error() end # go to 400 if x <= a return 0.0f0, 1.0f0 end # go to 300 @@ -867,7 +950,7 @@ function dgrat(a::Real, x::Real) z = a*log(x) u = exp(z) - h = dgam1(a) + h = rgamma1pm1(a) g = 1.0 + h ans = u*g*(0.5 + (0.5 - j)) qans = 0.5 + (0.5 - ans) @@ -916,7 +999,7 @@ function dgrat(a::Real, x::Real) l = x/a if l == 0.0 return 0.0, 1.0 end s = 0.5 + (0.5 - l) - z = drlog(l) + z = -logmxp1(l) if z >= 700.0/a # go to 330 if abs(s) <= 2.0*e error("ierr=3") end if x < a return 0.0, 1.0 end @@ -1036,9 +1119,9 @@ function rcomp(a::Float32, x::Float32) if a < 20.0 # go to 20 t = a*log(x) - x - if t < exparg(true) return 0.0f0 end + if t < realminexp(Float32) return 0.0f0 end if a < 1.0 # go to 10 - return (a*exp(t))*(1.0f0 + gam1(a)) + return (a*exp(t))*(1.0f0 + rgamma1pm1(a)) end return exp(t)/gamma(a) end @@ -1047,8 +1130,8 @@ function rcomp(a::Float32, x::Float32) if u == 0.0 return 0.0f0 end t = (1.0f0/a)^2 t1 = (((0.75f0*t - 1.0f0)*t + 3.5f0)*t - 105.0f0)/(a*1260.0f0) - t1 -= a*rlog(u) - if t1 >= exparg(true) return rt2pin*sqrt(a)*exp(t1) end + t1 += a*logmxp1(u) + if t1 >= realminexp(Float32) return rt2pin*sqrt(a)*exp(t1) end end function drcomp(a::Real, x::Real) @@ -1065,179 +1148,24 @@ function drcomp(a::Real, x::Real) if x == 0.0 return 0.0 end if a <= 20.0 # go to 20 t = a*log(x) - x - if t < dxparg(true) return 0.0 end + if t < realminexp(Float64) return 0.0 end if a < 1.0 # go to 10 - return (a*exp(t))*(1.0 + dgam1(a)) + return (a*exp(t))*(1.0 + rgamma1pm1(a)) end return exp(t)/gamma(a) end t = x/a if t == 0.0 return 0.0 end - w = -(dpdel(a) + a*drlog(t)) - if w >= dxparg(true) + w = -(lstirling(a) - a*logmxp1(t)) + if w >= realminexp(Float64) return c*sqrt(a)*exp(w) else return 0.0 end end -function dpdel(x::Real) -#----------------------------------------------------------------------- -# -# COMPUTATION OF THE FUNCTION DEL(X) FOR X .GE. 10 WHERE -# LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X) -# -# -------- -# -# THE SERIES FOR DPDEL ON THE INTERVAL 0.0 TO 1.0 DERIVED BY -# A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY -# OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). -# -#----------------------------------------------------------------------- -# DOUBLE PRECISION X, A(15), T, W -#----------------------------------------------------------------------- - -#----------------------------------------------------------------------- - t = (10.0/x)^2 - w = Base.Math.@horner(t, .833333333333333333333333333333e-01, - -.277777777777777777777777752282e-04, - .793650793650793650791732130419e-07, - -.595238095238095232389839236182e-09, - .841750841750832853294451671990e-11, - -.191752691751854612334149171243e-12, - .641025640510325475730918472625e-14, - -.295506514125338232839867823991e-15, - .179643716359402238723287696452e-16, - -.139228964661627791231203060395e-17, - .133802855014020915603275339093e-18, - -.154246009867966094273710216533e-19, - .197701992980957427278370133333e-20, - -.234065664793997056856992426667e-21, - .171348014966398575409015466667e-22) - return w/x -end - -function rlog(x::Float32) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION X - 1 - LN(X) -#----------------------------------------------------------------------- -# A = RLOG (0.7) -# B = RLOG (4/3) -#------------------------ - a = .566749439387324f-01 - b = .456512608815524f-01 -#------------------------ - p0 = .333333333333333f+00 - p1 = -.224696413112536f+00 - p2 = .620886815375787f-02 - q1 = -.127408923933623f+01 - q2 = .354508718369557f+00 -#------------------------ - if x < 0.61 || x > 1.57 # go to 100 - r = (x - 0.5f0) - 0.5f0 - return r - log(x) - end - if x < 0.82 # go to 10 - u = (x - 0.7f0)/0.7f0 - up2 = u + 2.0f0 - w1 = a - u*0.3f0 - elseif x > 1.18 # go to 20 - t = 0.75f0*(x - 1.0f0) - u = t - 0.25f0 - up2 = t + 1.75f0 - w1 = b + u/3.0f0 - else -# ARGUMENT REDUCTION - - u = (x - 0.5f0) - 0.5f0 - up2 = u + 2.0f0 - w1 = 0.0f0 - end - -# SERIES EXPANSION - - r = u/up2 - t = r*r - w = ((p2*t + p1)*t + p0)/((q2*t + q1)*t + 1.0f0) - return r*(u - 2.0f0*t*w) + w1 -end - -function drlog(x::Real) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION X - 1 - LN(X) -#----------------------------------------------------------------------- -# DOUBLE PRECISION X -# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z -# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 -# DOUBLE PRECISION C1, C2, C3, C4, C5 -#------------------------- -# A = DRLOG (0.7) -# B = DRLOG (4/3) -#------------------------- - a = .566749439387323789126387112411845e-01 - b = .456512608815524058941143273395059e-01 -#------------------------- - p0 = .7692307692307692307680e-01 - p1 = -.1505958055914600184836e+00 - p2 = .9302355725278521726994e-01 - p3 = -.1787900022182327735804e-01 - q1 = -.2824412139355646910683e+01 - q2 = .2892424216041495392509e+01 - q3 = -.1263560605948009364422e+01 - q4 = .1966769435894561313526e+00 -#------------------------- -# CI = 1/(2I + 1) -#------------------------- - c1 = .333333333333333333333333333333333e+00 - c2 = .200000000000000000000000000000000e+00 - c3 = .142857142857142857142857142857143e+00 - c4 = .111111111111111111111111111111111e+00 - c5 = .909090909090909090909090909090909e-01 -#------------------------- - if x < 0.61 || x > 1.57 # go to 100 - r = (x - 0.5) - 0.5 - return r - log(x) - end - if x <= 1.18 # go to 20 - if x >= 0.82 # go to 10 - -# ARGUMENT REDUCTION - u = (x - 0.5) - 0.5 - up2 = u + 2.0 - w1 = 0.0 - else - - u = (x - 0.7)/0.7 - up2 = u + 2.0 - w1 = a - u*0.3 - end - else - t = 0.75*(x - 1.0) - u = t - 0.25 - up2 = t + 1.75 - w1 = b + u/3.0 - end - -# SERIES EXPANSION - - r = u/up2 - t = r*r -# -# Z IS A MINIMAX APPROXIMATION OF THE SERIES -# -# C6 + C7*R**2 + C8*R**4 + ... -# -# FOR THE INTERVAL (0.0, 0.375). THE APPROX- -# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF -# THE 21-ST SIGNIFICANT DIGIT. -# - z = (((p3*t + p2)*t + p1)*t + p0)/((((q4*t + q3)*t + q2)*t + q1)*t + 1.0) - - w = ((((z*t + c5)*t + c4)*t + c3)*t + c2)*t + c1 - return r*(u - 2.0*t*w) + w1 -end function dgr17(a::Real, y::Real, l::Real, z::Real, rta::Real) #----------------------------------------------------------------------- @@ -1265,85 +1193,85 @@ function dgr17(a::Real, y::Real, l::Real, z::Real, rta::Real) z = sqrt(z + z) if l < 1.0 z = -z end - c0 = Base.Math.@horner(z, -.33333333333333333e+00, + c0 = @horner(z, -.33333333333333333e+00, -.24232172943558393e+00, -.76816029947195974e-01, -.11758531313175796e-01, -.73324404807556026e-03) - c0 /= Base.Math.@horner(z, 1.0, + c0 /= @horner(z, 1.0, .97696518830675185e+00, .43024494247383254e+00, .10288837674434487e+00, .13250270182342259e-01, .73121701584237188e-03, .10555647473018528e-06) - c1 = Base.Math.@horner(z, -.18518518518518417e-02, + c1 = @horner(z, -.18518518518518417e-02, -.52949366601406939e-02, -.16090334014223031e-02, -.16746784557475121e-03) - c1 /= Base.Math.@horner(z, 1.0, + c1 /= @horner(z, 1.0, .98426579647613593e+00, .45195109694529839e+00, .11439610256504704e+00, .15954049115266936e-01, .98671953445602142e-03, .12328086517283227e-05) - c2 = Base.Math.@horner(z, .41335978835983393e-02, + c2 = @horner(z, .41335978835983393e-02, .15067356806896441e-02, .13743853858711134e-03, .12049855113125238e-04) - c2 /= Base.Math.@horner(z, 1.0, + c2 /= @horner(z, 1.0, .10131761625405203e+01, .50379606871703058e+00, .14009848931638062e+00, .22316881460606523e-01, .15927093345670077e-02) - c3 = Base.Math.@horner(z, .64943415637082551e-03, + c3 = @horner(z, .64943415637082551e-03, .81804333975935872e-03, .13012396979747783e-04, .46318872971699924e-05) - c3 /= Base.Math.@horner(z, 1.0, + c3 /= @horner(z, 1.0, .90628317147366376e+00, .42226789458984594e+00, .10044290377295469e+00, .12414068921653593e-01) - c4 = Base.Math.@horner(z, -.86188829773520181e-03, + c4 = @horner(z, -.86188829773520181e-03, -.82794205648271314e-04, -.37567394580525597e-05) - c4 /= Base.Math.@horner(z, 1.0, + c4 /= @horner(z, 1.0, .10057375981227881e+01, .57225859400072754e+00, .16988291247058802e+00, .31290397554562032e-01) - c5 = Base.Math.@horner(z, -.33679854644784478e-03, + c5 = @horner(z, -.33679854644784478e-03, -.43263341886764011e-03) - c5 /= Base.Math.@horner(z, 1.0, + c5 /= @horner(z, 1.0, .10775200414676195e+01, .60019022026983067e+00, .17081504060220639e+00, .22714615451529335e-01) - c6 = Base.Math.@horner(z, .53130115408837152e-03, + c6 = @horner(z, .53130115408837152e-03, -.12962670089753501e-03) - c6 /= Base.Math.@horner(z, 1.0, + c6 /= @horner(z, 1.0, .87058903334443855e+00, .45957439582639129e+00, .65929776650152292e-01) - c7 = Base.Math.@horner(z, .34438428473168988e-03, + c7 = @horner(z, .34438428473168988e-03, .47861364421780889e-03) - c7 /= Base.Math.@horner(z, 1.0, + c7 /= @horner(z, 1.0, .12396875725833093e+01, .78991370162247144e+00, .27176241899664174e+00) - c8 = Base.Math.@horner(z, -.65256615574219131e-03, + c8 = @horner(z, -.65256615574219131e-03, .27086391808339115e-03) - c8 /= Base.Math.@horner(z, 1.0, + c8 /= @horner(z, 1.0, .87002402612484571e+00, .44207055629598579e+00) - c9 = Base.Math.@horner(z, -.60335050249571475e-03, + c9 = @horner(z, -.60335050249571475e-03, -.14838721516118744e-03, .84725086921921823e-03) - c10 = Base.Math.@horner(z, .13324454494800656e-02, + c10 = @horner(z, .13324454494800656e-02, -.19144384985654775e-02) @@ -1386,14 +1314,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) z = sqrt(z + z) if l < 1.0 z = -z end - t = Base.Math.@horner(z,-.218544851067999216147364227e-05, + t = @horner(z,-.218544851067999216147364227e-05, -.490033281596113358850307112e-05, -.372722892959910688597417881e-05, -.145717031728609218851588740e-05, -.327874000161065050049103731e-06, -.408902435641223939887180303e-07, -.234443848930188413698825870e-08) - t /= Base.Math.@horner(z,1.0, + t /= @horner(z,1.0, .139388806936391316154237713e+01, .902581259032419042347458484e+00, .349373447613102956696810725e+00, @@ -1410,14 +1338,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) -.148148148148148148148148148148e-01)*z + .833333333333333333333333333333e-01)*z + -.333333333333333333333333333333e+00 - c1 = Base.Math.@horner(z,-.185185185185185185185185200e-02, + c1 = @horner(z,-.185185185185185185185185200e-02, -.627269388216833251971110268e-02, -.462960105006279850867332060e-02, -.167787748352827199882047653e-02, -.334816794629374699945489443e-03, -.359791514993122440319624428e-04, -.162671127226300802902860047e-05) - c1 /= Base.Math.@horner(z,1.0, + c1 /= @horner(z,1.0, .151225469637089956064399494e+01, .109307843990990308990473663e+01, .482173396010404307346794795e+00, @@ -1427,14 +1355,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .275463718595762102271929980e-03, .974094440943696092434381137e-05, .361538770500640888027927000e-09) - c2 = Base.Math.@horner(z, .413359788359788359788359644e-02, + c2 = @horner(z, .413359788359788359788359644e-02, .365985331203490698463644329e-02, .138385867950361368914038461e-02, .287368655528567495658887760e-03, .351658023234640143803014403e-04, .261809837060522545971782889e-05, .100841467329617467204527243e-06) - c2 /= Base.Math.@horner(z,1.0, + c2 /= @horner(z,1.0, .153405837991415136438992306e+01, .114320896084982707537755002e+01, .524238095721639512312120765e+00, @@ -1443,14 +1371,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .457258679387716305283282667e-02, .378705615967233119938297206e-03, .144996224602847932479320241e-04) - c3 = Base.Math.@horner(z, .649434156378600823045102236e-03, + c3 = @horner(z, .649434156378600823045102236e-03, .141844584435355290321010006e-02, .987931909328964685388525477e-03, .331552280167649130371474456e-03, .620467118988901865955998784e-04, .695396758348887902366951353e-05, .352304123782956092061364635e-06) - c3 /= Base.Math.@horner(z,1.0, + c3 /= @horner(z,1.0, .183078413578083710405050462e+01, .159678625605457556492814589e+01, .856743428738899911100227393e+00, @@ -1459,14 +1387,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .126418031281256648240652355e-01, .130398975231883219976260776e-02, .656342109234806261144233394e-04) - c4 = Base.Math.@horner(z, -.861888290916711698604710684e-03, + c4 = @horner(z, -.861888290916711698604710684e-03, -.619343030286408407629007048e-03, -.173138093150706317400323103e-03, -.337525643163070607393381432e-04, -.487392507564453824976295590e-05, -.470448694272734954500324169e-06, -.260879135093022176005540138e-07) - c4 /= Base.Math.@horner(z,1.0, + c4 /= @horner(z,1.0, .162826466816694512158165085e+01, .133507902144433100426436242e+01, .686949677014349678482109368e+00, @@ -1475,14 +1403,14 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .990129468337836044520381371e-02, .104553622856827932853059322e-02, .561738585657138771286755470e-04) - c5 = Base.Math.@horner(z, -.336798553366358151161633777e-03, + c5 = @horner(z, -.336798553366358151161633777e-03, -.548868487607991087508092013e-03, -.171902547619915856635305717e-03, -.332229941748769925615918550e-04, -.556701576804390213081214801e-05, .506465072067030007394288471e-08, -.116166342948098688243985652e-07) - c5 /= Base.Math.@horner(z,1.0, + c5 /= @horner(z,1.0, .142263185288429590449288300e+01, .103913867517817784825064299e+01, .462890328922621047510807887e+00, @@ -1490,11 +1418,11 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .254669201041872409738119341e-01, .280714123386276098548285440e-02, .106576106868815233442641444e-03) - c6 = Base.Math.@horner(z, .531307936463992224884286210e-03, + c6 = @horner(z, .531307936463992224884286210e-03, .209213745619758030399432459e-03, .694345283181981060040314140e-05, .118384620224413424936260301e-04) - c6 /= Base.Math.@horner(z,1.0, + c6 /= @horner(z,1.0, .150831585220968267709550582e+01, .118432122801495778365352945e+01, .571784440733980642101712125e+00, @@ -1504,12 +1432,12 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .151734058829700925162000373e-03, -.248639208901374031411609873e-04, -.633002360430352916354621750e-05) - c7 = Base.Math.@horner(z, .344367606892381545765962366e-03, + c7 = @horner(z, .344367606892381545765962366e-03, .605983804794748515383615779e-03, .208913588225005764102252127e-03, .462793722775687016808279009e-04, .972342656522493967167788395e-05) - c7 /= Base.Math.@horner(z,1.0, + c7 /= @horner(z,1.0, .160951809815647533045690195e+01, .133753662990343866552766613e+01, .682159830165959997577293001e+00, @@ -1517,12 +1445,12 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .497403555098433701440032746e-01, .621296161441756044580440529e-02, .215964480325937088444595990e-03) - c8 = Base.Math.@horner(z, -.652623918595320914510590273e-03, + c8 = @horner(z, -.652623918595320914510590273e-03, -.353272052089782073130912603e-03, -.282551884312564905942488077e-04, -.192877995065652524742879002e-04, -.231069438570167401077137510e-05) - c8 /= Base.Math.@horner(z,1.0, + c8 /= @horner(z,1.0, .182765408802230546887514255e+01, .172269407630659768618234623e+01, .101702505946784412105505734e+01, @@ -1530,65 +1458,65 @@ function dgr29(a::Real, y::Real, l::Real, z::Real, rta::Real) .110127834209242088316741250e+00, .189231675289329563916597032e-01, .156052480203446255774109882e-02) - c9 = Base.Math.@horner(z, -.596761290192642722092337263e-03, + c9 = @horner(z, -.596761290192642722092337263e-03, -.109151697941931403194363814e-02, -.377126645910917006921076652e-03, -.120148495117517992204095691e-03, -.203007139532451428594124139e-04) - c9 /= Base.Math.@horner(z,1.0, + c9 /= @horner(z,1.0, .170833470935668756293234818e+01, .156222230858412078350692234e+01, .881575022436158946373557744e+00, .335555306170768573903990019e+00, .803149717787956717154553908e-01, .108808775028021530146610124e-01) - c10 =Base.Math.@horner(z, .133244544950730832649306319e-02, + c10 =@horner(z, .133244544950730832649306319e-02, .580375987713106460207815603e-03, -.352503880413640910997936559e-04, .475862254251166503473724173e-04) - c10/=Base.Math.@horner(z, 1.0, + c10/=@horner(z, 1.0, .187235769169449339141968881e+01, .183146436130501918547134176e+01, .110810715319704031415255670e+01, .448280675300097555552484502e+00, .114651544043625219459951640e+00, .161103572271541189817119144e-01) - c11 =Base.Math.@horner(z, .157972766214718575927904484e-02, + c11 =@horner(z, .157972766214718575927904484e-02, .246371734409638623215800502e-02, .717725173388339108430635016e-05, .121185049262809526794966703e-03) - c11/=Base.Math.@horner(z, 1.0, + c11/=@horner(z, 1.0, .145670749780693850410866175e+01, .116082103318559904744144217e+01, .505939635317477779328000706e+00, .131627017265860324219513170e+00, .794610889405176143379963912e-02) - c12 =Base.Math.@horner(z, -.407251199495291398243480255e-02, + c12 =@horner(z, -.407251199495291398243480255e-02, -.214376520139497301154749750e-03, .650624975008642297405944869e-03, -.246294151509758620837749269e-03) - c12/=Base.Math.@horner(z, 1.0, + c12/=@horner(z, 1.0, .162497775209192630951344224e+01, .140298208333879535577602171e+01, .653453590771198550320727688e+00, .168390445944818504703640731e+00) - c13 =Base.Math.@horner(z, -.594758070915055362667114240e-02, + c13 =@horner(z, -.594758070915055362667114240e-02, -.109727312966041723997078734e-01, -.159520095187034545391135461e-02) - c13/=Base.Math.@horner(z, 1.0, + c13/=@horner(z, 1.0, .175409273929961597148916309e+01, .158706682625067673596619095e+01, .790935125477975506817064616e+00, .207815761771742289849225339e+00) - c14 =Base.Math.@horner(z, .175722793448246103440764372e-01, + c14 =@horner(z, .175722793448246103440764372e-01, -.119636668153843644820445054e-01, .245543970647383469794050102e-02) - c14/=Base.Math.@horner(z, 1.0, + c14/=@horner(z, 1.0, .100158659226079685399214158e+01, .676925518749829493412063599e+00) - c15 =Base.Math.@horner(z, .400765463491067514929787780e-01, + c15 =@horner(z, .400765463491067514929787780e-01, .588261033368548917447688791e-01) - c15/=Base.Math.@horner(z, 1.0, + c15/=@horner(z, 1.0, .149189509890654955611528542e+01, .124266359850901469771032599e+01) c16 = (.119522261141925960204472459e+00*z + @@ -1769,7 +1697,7 @@ function dginv(a::Real, p::Real, q::Real) if b*q <= 1.0e-8 # go to 31 xn = exp(-(q/a + c)) elseif p > 0.9 # go to 32 - xn = exp((dlnrel(-q) + dgmln1(a))/a) + xn = exp((dlnrel(-q) + lgamma1p(a))/a) else xn = exp(log(p*g)/a) end @@ -2536,18 +2464,18 @@ function bpser(a::Real, b::Real, x::Real, precision::Real) apb = a + b if (apb <= 1.0) # go to 20 - z = 1.0 + dgam1(apb) + z = 1.0 + rgamma1pm1(apb) else u = a + b - 1.0 - z = (1.0 + dgam1(u))/apb + z = (1.0 + rgamma1pm1(u))/apb end - c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + c = (1.0 + rgamma1pm1(a))*(1.0 + rgamma1pm1(b))/z bpserval *= c*(b/apb) elseif (b0 < 8.0) # PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 - u = dgmln1(a0) + u = lgamma1p(a0) m = itrunc(b0 - 1.0) if (m >= 1) # go to 50 c = 1.0 @@ -2561,17 +2489,17 @@ function bpser(a::Real, b::Real, x::Real, precision::Real) b0 -= 1.0 apb = a0 + b0 if (apb <= 1.0) # go to 51 - t = 1.0 + dgam1(apb) + t = 1.0 + rgamma1pm1(apb) else u = a0 + b0 - 1.0 - t = (1.0 + dgam1(u))/apb + t = (1.0 + rgamma1pm1(u))/apb end - bpserval = exp(z)*(a0/a)*(1.0 + dgam1(b0))/t + bpserval = exp(z)*(a0/a)*(1.0 + rgamma1pm1(b0))/t else # PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 - u = dgmln1(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + dlgdiv(a0,b0) z = a*log(x) - u bpserval = (a0/a)*exp(z) end @@ -2610,8 +2538,8 @@ function bup(a::Real, b::Real, x::Real, y::Real, n::Integer, precision::Real) mu = 0 d = 1.0 if (n != 1 && a >= 1.0 && apb >= 1.1*ap1) # go to 10 - mu = itrunc(abs(dxparg(true))) - k = itrunc(dxparg(false)) + mu = itrunc(abs(realminexp(Float64))) + k = itrunc(realmaxexp(Float64)) if (k < mu) mu = k end t = mu d = exp(-t) @@ -2771,19 +2699,19 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) apb = a + b if (apb <= 1.0) # go to 40 - z = 1.0 + dgam1(apb) + z = 1.0 + rgamma1pm1(apb) else u = a + b - 1.0 - z = (1.0 + dgam1(u))/apb + z = (1.0 + rgamma1pm1(u))/apb end - c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + c = (1.0 + rgamma1pm1(a))*(1.0 + rgamma1pm1(b))/z return brcompval*(a0*c)/(1.0 + a0/b0) elseif (b0 < 8.0) # ALGORITHM FOR 1 .LT. B0 .LT. 8 - u = dgmln1(a0) + u = lgamma1p(a0) n = itrunc(b0 - 1.0) if (n > 1) # go to 70 c = 1.0 @@ -2798,16 +2726,16 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) b0 -= 1.0 apb = a0 + b0 if (apb <= 1.0) - t = 1.0 + dgam1(apb) + t = 1.0 + rgamma1pm1(apb) else u = a0 + b0 - 1.0 - t = (1.0 + dgam1(u))/apb + t = (1.0 + rgamma1pm1(u))/apb end - return a0*exp(z)*(1.0 + dgam1(b0))/t + return a0*exp(z)*(1.0 + rgamma1pm1(b0))/t else # ALGORITHM FOR B0 .GE. 8 - u = dgmln1(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + dlgdiv(a0,b0) return a0*exp(z - u) end end @@ -2827,14 +2755,14 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) end e = -lambda/a if (abs(e) <= 0.6) # go to 111 - u = drlog1(e) + u = -log1pmx(e) else u = e - log(x/x0) end e = lambda/b if (abs(e) <= 0.6) # go to 121 - v = drlog1(e) + v = -log1pmx(e) else v = e - log(y/y0) end @@ -2889,19 +2817,19 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) apb = a + b if (apb <= 1.0) # go to 40 - z = 1.0 + dgam1(apb) + z = 1.0 + rgamma1pm1(apb) else u = a + b - 1.0 - z = (1.0 + dgam1(u))/apb + z = (1.0 + rgamma1pm1(u))/apb end - c = (1.0 + dgam1(a))*(1.0 + dgam1(b))/z + c = (1.0 + rgamma1pm1(a))*(1.0 + rgamma1pm1(b))/z return brcompval*(a0*c)/(1.0 + a0/b0) elseif (b0 < 8.0) # ALGORITHM FOR 1 .LT. B0 .LT. 8 - u = dgmln1(a0) + u = lgamma1p(a0) n = itrunc(b0 - 1.0) if (n > 1) # go to 70 c = 1.0 @@ -2916,17 +2844,17 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) b0 -= 1.0 apb = a0 + b0 if (apb <= 1.0) - t = 1.0 + dgam1(apb) + t = 1.0 + rgamma1pm1(apb) else u = a0 + b0 - 1.0 - t = (1.0 + dgam1(u))/apb + t = (1.0 + rgamma1pm1(u))/apb end - return a0*exp(mu + z)*(1.0 + dgam1(b0))/t + return a0*exp(mu + z)*(1.0 + rgamma1pm1(b0))/t else # ALGORITHM FOR B0 .GE. 8 - u = dgmln1(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + dlgdiv(a0,b0) return a0*exp(mu + z - u) end end @@ -2946,14 +2874,14 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) end e = -lambda/a if (abs(e) <= 0.6) # go to 111 - u = drlog1(e) + u = -log1pmx(e) else u = e - log(x/x0) end e = lambda/b if (abs(e) <= 0.6) # go to 121 - v = drlog1(e) + v = -log1pmx(e) else v = e - log(y/y0) end @@ -2988,7 +2916,7 @@ function bgrat(a::Real, b::Real, x::Real, y::Real, w::Real, precision::Real) # COMPUTATION OF THE EXPANSION # SET R = EXP(-Z)*Z**B/GAMMA(B) - r = b*(1.0 + dgam1(b))*z^b + r = b*(1.0 + rgamma1pm1(b))*z^b r *= exp(a*lnx)*exp(0.5*bm1*lnx) u = dlgdiv(b,a) + b*log(nu) u = r*exp(-u) @@ -3070,7 +2998,7 @@ function grat1(a::Real,x::Real,r::Real,precision::Real) j = a*x*((sumval/6.0 - 0.5/(a + 2.0))*x + 1.0/(a + 1.0)) z = a*log(x) - h = dgam1(a) + h = rgamma1pm1(a) g = 1.0 + h while true if (x >= 0.25) @@ -3156,7 +3084,7 @@ function basym(a::Real, b::Real, lambda::Real, precision::Real) w0 = 1.0/sqrt(b*(1.0 + h)) end - f = a*drlog1(-lambda/a) + b*drlog1(lambda/b) + f = -a*log1pmx(-lambda/a) - b*log1pmx(lambda/b) t = exp(-f) if (t == 0.0) return basymval end z0 = sqrt(f) @@ -3221,77 +3149,6 @@ function basym(a::Real, b::Real, lambda::Real, precision::Real) return e0*t*u*sumval end -function drlog1(x::Real) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION X - LN(1 + X) -#----------------------------------------------------------------------- -# DOUBLE PRECISION X -# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z -# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 -# DOUBLE PRECISION C1, C2, C3, C4, C5 -#------------------------- -# A = DRLOG (0.7) -# B = DRLOG (4/3) -#------------------------- - a = 0.566749439387323789126387112411845e-01 - b = 0.456512608815524058941143273395059e-01 -#------------------------- - p0 = .7692307692307692307680e-01 - p1 = -.1505958055914600184836e+00 - p2 = .9302355725278521726994e-01 - p3 = -.1787900022182327735804e-01 - q1 = -.2824412139355646910683e+01 - q2 = .2892424216041495392509e+01 - q3 = -.1263560605948009364422e+01 - q4 = .1966769435894561313526e+00 -#------------------------- -# CI = 1/(2I + 1) -#------------------------- - c1 = .333333333333333333333333333333333e+00 - c2 = .200000000000000000000000000000000e+00 - c3 = .142857142857142857142857142857143e+00 - c4 = .111111111111111111111111111111111e+00 - c5 = .909090909090909090909090909090909e-01 -#------------------------- - if x >= -0.39 && x <= 0.57 # go to 100 - if x < -0.18 # go to 10 - u = (x + 0.3)/0.7 - up2 = u + 2.0 - w1 = a - u*0.3 - elseif x > 0.18 # go to 20 - t = 0.75*x - u = t - 0.25 - up2 = t + 1.75 - w1 = b + u/3.0 - else - u = x - up2 = u + 2.0 - w1 = 0.0 - end -# -# SERIES EXPANSION -# - r = u/up2 - t = r*r -# -# Z IS A MINIMAX APPROXIMATION OF THE SERIES -# -# C6 + C7*R**2 + C8*R**4 + ... -# -# FOR THE INTERVAL (0.0, 0.375). THE APPROX- -# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF -# THE 21-ST SIGNIFICANT DIGIT. -# - z = (((p3*t + p2)*t + p1)*t + p0)/((((q4*t + q3)*t + q2)*t + q1)*t + 1.0) -# - w = ((((z*t + c5)*t + c4)*t + c3)*t + c2)*t + c1 - return r*(u - 2.0*t*w) + w1 -# -# - end - w = (x + 0.5) + 0.5 - return x - log(w) -end function dbcorr(a0::Real, b0::Real) #----------------------------------------------------------------------- @@ -3612,12 +3469,12 @@ function dgsmln(a::Real, b::Real) x = (a - 1.0) + (b - 1.0) if x <= 0.50 # go to 10 - return dgmln1(1.0 + x) + return lgamma1p(1.0 + x) end if x < 1.50 # go to 20 - return dgmln1(x) + dlnrel(x) + return lgamma1p(x) + dlnrel(x) end - return dgmln1(x - 1.0) + log(x*(1.0 + x)) + return lgamma1p(x - 1.0) + log(x*(1.0 + x)) end function desum(mu::Integer, x::Real) @@ -3640,7 +3497,8 @@ function desum(mu::Integer, x::Real) return exp(w) end -function dgam1(x::Real) +# NSWC DGAM1 +function rgamma1pm1(x::Float64) #----------------------------------------------------------------------- # EVALUATION OF 1/GAMMA(1 + X) - 1 FOR -0.5 .LE. X .LE. 1.5 #----------------------------------------------------------------------- @@ -3726,12 +3584,13 @@ function dgam1(x::Real) z = (((((((((((((w*t + c13)*t + c12)*t + c11)*t + c10)*t + c9)*t + c8)*t + c7)*t + c6)*t + c5)*t + c4)*t + c3)*t + c2)*t + c1)*t + c if d <= 0.0 # go to 50 - return x*((z + 0.5d0) + 0.5d0) + return x*((z + 0.5) + 0.5) end return t*z/x end -function gam1(a::Float32) +# NSWC GAM1 +function rgamma1pm1(a::Float32) #----------------------------------------------------------------------- # COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 #----------------------------------------------------------------------- @@ -3781,10 +3640,13 @@ function gam1(a::Float32) return t*w/a end -gamln1(x::Float32) = lgamma(1.0f0 + x) -dgmln1(x::Real) = lgamma(1 + x) -dxparg(bmin::Bool) = (bmin ? log(realmin()) : log(realmax())) -exparg(bmin::Bool) = (bmin ? log(realmin(Float32)) : log(realmax(Float32))) +function lgamma1p(x) + if -0.5 <= x <= 1.5 + return -log1p(rgamma1pm1(x)) + else + lgamma(one(x)+x) + end +end ### End of regularized incomplete beta function From 8bc20ca7ba11a4ea9003a9e1fdf98ce1d846a31b Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Wed, 18 Sep 2013 19:43:05 +0100 Subject: [PATCH 06/19] add some special function tests, fix errors --- src/specialfuns.jl | 65 ++++++++++++++++++++++++++++++++-- test/specialfuns.jl | 86 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 149 insertions(+), 2 deletions(-) create mode 100644 test/specialfuns.jl diff --git a/src/specialfuns.jl b/src/specialfuns.jl index d72fda492..175761d69 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns.jl @@ -1,11 +1,12 @@ # Special functions +# the largest x such that exp(x) < Inf realmaxexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmax(T)),RoundDown) realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(prevfloat(inf(BigFloat))),RoundDown) +# the smallest x such that exp(x) > 0 (or at least not a subnormal number) realminexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmin(T)),RoundUp) -realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(nextfloat(zero(BigFloat))),RoundUp) - +realminexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(nextfloat(zero(BigFloat))),RoundUp) # See: @@ -21,6 +22,7 @@ log1pexp(x::Float64) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x log1pexp(x::Float32) = x <= 9f0 ? log1p(exp(x)) : x <= 16f0 ? x + exp(-x) : x log1pexp(x::Integer) = log1pexp(float(x)) # log(exp(x)-1) +# still inaccurate for values close to log(2) logexpm1(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log(expm1(x)) : x logexpm1(x::Float64) = x <= 18.0 ? log(expm1(x)) : x <= 33.3 ? x - exp(-x) : x logexpm1(x::Float32) = x <= 9f0 ? log(expm1(x)) : x <= 16f0 ? x - exp(-x) : x @@ -273,6 +275,7 @@ function logmxp1(x::Float32) end +log1pmx(x) = log1p(x) - x # negative of NSWC DRLOG1 function log1pmx(x::Float64) #----------------------------------------------------------------------- @@ -345,6 +348,44 @@ function log1pmx(x::Float64) return log1p(x) - x end +# NSWC RLOG1 +function log1pmx(x::Float32) + a = 0.566749439387324f-01 + b = 0.456512608815524f-01 + + if x >= -0.39f0 && x <= 0.57f0 # go to 100 + if x < -0.18f0 # go to 10 + u = (x + 0.3f0)/0.7f0 + up2 = u + 2f0 + w1 = a - u*0.3f0 + elseif x > 0.18 # go to 20 + t = 0.75f0*x + u = t - 0.25f0 + up2 = t + 1.75f0 + w1 = b + u/3f0 + else + u = x + up2 = u + 2f0 + w1 = 0f0 + end +# +# SERIES EXPANSION +# + r = u/up2 + t = r*r + + w = @horner(t, + 0.333333333333333f+00, + -.224696413112536f+00, + 0.620886815375787f-02) / + @horner(t, 1f0, + -.127408923933623f+01, + 0.354508718369557f+00) + + return r*(2f0*t*w - u) - w1 + end + return log1p(x) - x +end @@ -392,6 +433,26 @@ function lstirling(x::Float64) end end + +function lstirling(x::Float32) + if x <= 10.0 + return lgamma(x) - (x-0.5f0)*log(x) + x - 0.5f0*log2π + else + u = 10f0/x + t = u*u + return @horner(t, + .833333333333333333333333333333f-01, + -.277777777777777777777777752282f-04, + .793650793650793650791732130419f-07, + -.595238095238095232389839236182f-09, + .841750841750832853294451671990f-11, + -.191752691751854612334149171243f-12, + .641025640510325475730918472625f-14, + -.295506514125338232839867823991f-15) / x + end +end + + # The regularized incomplete gamma function # Translated from the NSWC Library function gratio(a::Float32, x::Float32, ind::Integer) diff --git a/test/specialfuns.jl b/test/specialfuns.jl new file mode 100644 index 000000000..a2c88c164 --- /dev/null +++ b/test/specialfuns.jl @@ -0,0 +1,86 @@ +using Distributions +using Base.Test + + +import Distributions.realmaxexp +import Distributions.realminexp + +for t = [Float32, Float64, BigFloat] + @test !isinf(exp(realmaxexp(t))) + @test exp(realminexp(t)) != zero(t) +end + + +import Distributions.log1mexp +import Distributions.log1pexp +import Distributions.logexpm1 + +import Distributions.logmxp1 +import Distributions.log1pmx + +import Distributions.lstirling + + + + +macro test_floatvsbig(a,fac) + fargs = a.args[2:] + b = :(oftype($(fargs[1]),$(Expr(:call,a.args[1],[:(big($u)) for u = fargs]...)))) + stra = string(a) + strb = string(b) + argstr = :(string($([:(string($(string(u))," = ",$u,", ")) for u in fargs]...))) + quote + va = $(esc(a)) + vb = $(esc(b)) + diff = abs(va - vb) + maxeps = eps(max(abs(va),abs(vb))) + if diff > $(esc(fac))*maxeps + error("assertion failed: ",string("|",$stra," - ",$strb,"| <= ",$(string(fac))),"*eps", + "\n ",$argstr, + "\n ",$stra," = ",va, + "\n ",$strb," = ",vb, + "\n ","Relative error = ",diff/maxeps,"*eps") + end + end +end + + + +# 10 random mantissas +X = rand(10)+1.0 + +# todo: +# - lower relative error threshold +# - Float32 checks + +for x = X + for t = [Float32, Float64] + # check across different orders of magnitude + for i = exponent(realmin(t)):exponent(realmax(t)) + y = oftype(t,x*2.0^i) + ny = -y + @test_floatvsbig log1mexp(ny) 8 + @test_floatvsbig log1pexp(y) 8 + if !(0.5= 1e-60 # BigFloat underflow + @test_floatvsbig log1pmx(y) 8 + if ny > -1 + @test_floatvsbig log1pmx(ny) 8 + end + end + + if y >= 10 # currently only valid for this range + if y < 1e28 # BigFloat underflow + @test_floatvsbig lstirling(y) 8 + end + end + end + end +end + From 7ec55967c13449519369b34e597017dbfe6eb2c0 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Thu, 19 Sep 2013 10:17:55 +0100 Subject: [PATCH 07/19] split out special functions --- src/Distributions.jl | 5 +- .../gammabeta.jl} | 494 +----------------- src/specialfuns/log.jl | 211 ++++++++ src/specialfuns/misc.jl | 8 + src/specialfuns/normal.jl | 170 ++++++ test/discrete.jl | 2 +- 6 files changed, 411 insertions(+), 479 deletions(-) rename src/{specialfuns.jl => specialfuns/gammabeta.jl} (86%) create mode 100644 src/specialfuns/log.jl create mode 100644 src/specialfuns/misc.jl create mode 100644 src/specialfuns/normal.jl diff --git a/src/Distributions.jl b/src/Distributions.jl index 70fa722b5..dbae385d7 100644 --- a/src/Distributions.jl +++ b/src/Distributions.jl @@ -195,7 +195,10 @@ include("constants.jl") include("fallbacks.jl") include("rmath.jl") -include("specialfuns.jl") +include("specialfuns/misc.jl") +include("specialfuns/normal.jl") +include("specialfuns/log.jl") +include("specialfuns/gammabeta.jl") include("tvpack.jl") include("utils.jl") diff --git a/src/specialfuns.jl b/src/specialfuns/gammabeta.jl similarity index 86% rename from src/specialfuns.jl rename to src/specialfuns/gammabeta.jl index 175761d69..49635318a 100644 --- a/src/specialfuns.jl +++ b/src/specialfuns/gammabeta.jl @@ -1,392 +1,4 @@ -# Special functions - -# the largest x such that exp(x) < Inf -realmaxexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmax(T)),RoundDown) -realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(prevfloat(inf(BigFloat))),RoundDown) - -# the smallest x such that exp(x) > 0 (or at least not a subnormal number) -realminexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmin(T)),RoundUp) -realminexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(nextfloat(zero(BigFloat))),RoundUp) - - -# See: -# Martin Maechler (2012) "Accurately Computing log(1 − exp(− |a|))" -# http://cran.r-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf - -# log(1-exp(x)) -# NOTE: different than Maechler (2012), no negation inside parantheses -log1mexp(x::Real) = x >= -0.6931471805599453 ? log(-expm1(x)) : log1p(-exp(x)) -# log(1+exp(x)) -log1pexp(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log1p(exp(x)) : x -log1pexp(x::Float64) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x -log1pexp(x::Float32) = x <= 9f0 ? log1p(exp(x)) : x <= 16f0 ? x + exp(-x) : x -log1pexp(x::Integer) = log1pexp(float(x)) -# log(exp(x)-1) -# still inaccurate for values close to log(2) -logexpm1(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log(expm1(x)) : x -logexpm1(x::Float64) = x <= 18.0 ? log(expm1(x)) : x <= 33.3 ? x - exp(-x) : x -logexpm1(x::Float32) = x <= 9f0 ? log(expm1(x)) : x <= 16f0 ? x - exp(-x) : x -logexpm1(x::Integer) = logexpm1(float(x)) - -φ(z::Real) = exp(-0.5*z*z)/√2π -logφ(z::Real) = -0.5*(z*z + log2π) - -Φ(z::Real) = 0.5*erfc(-z/√2) -Φc(z::Real) = 0.5*erfc(z/√2) -logΦ(z::Real) = z < -1.0 ? log(0.5*erfcx(-z/√2)) - 0.5*z*z : log1p(-0.5*erfc(z/√2)) -logΦc(z::Real) = z > 1.0 ? log(0.5*erfcx(z/√2)) - 0.5*z*z : log1p(-0.5*erfc(-z/√2)) - -import Base.Math.@horner - -# Rational approximations for the inverse cdf, from: -# Wichura, M.J. (1988) Algorithm AS 241: The Percentage Points of the Normal Distribution -# Journal of the Royal Statistical Society. Series C (Applied Statistics), Vol. 37, No. 3, pp. 477-484 -Φinv(p::Integer) = Φinv(float(p)) -logΦinv(p::Integer) = logΦinv(float(p)) - -for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) - @eval begin - function $fn($arg::Float32) - if $(fn == :Φinv) - q = p - 0.5f0 - else - q = exp(logp) - 0.5f0 - end - if abs(q) <= 0.425f0 - r = 0.180625f0 - q*q - return q * @horner(r, - 3.38713_27179f0, - 5.04342_71938f1, - 1.59291_13202f2, - 5.91093_74720f1, - ) / - @horner(r, - 1.0f0, - 1.78951_69469f1, - 7.87577_57664f1, - 6.71875_63600f1) - else - if $(fn == :Φinv) - if p <= 0f0 - return p == 0f0 ? -inf(Float32) : nan(Float32) - elseif p >= 1f0 - return p == 1f0 ? inf(Float32) : nan(Float32) - end - r = sqrt(q < 0f0 ? -log(p) : -log1p(-p)) - else - if logp == -Inf - return -inf(Float32) - elseif logp >= 0f0 - return logp == 0f0 ? inf(Float32) : nan(Float32) - end - r = sqrt(qf0 < 0 ? -logp : -log1mexp(logp)) - end - if r < 5.0f0 - r -= 1.6f0 - z = @horner(r, - 1.42343_72777f0, - 2.75681_53900f0, - 1.30672_84816f0, - 1.70238_21103f-1) / - @horner(r, - 1.0f0, - 7.37001_64250f-1, - 1.20211_32975f-1) - else - r -= 5.0f0 - z = @horner(r, - 6.65790_51150f0, - 3.08122_63860f0, - 4.28682_94337f-1, - 1.73372_03997f-2) / - @horner(r, - 1.0f0, - 2.41978_94225f-1, - 1.22582_02635f-2) - end - return copysign(z,q) - end - end - - function $fn($arg::Float64) - if $(fn == :Φinv) - q = p - 0.5 - else - q = exp(logp) - 0.5 - end - if abs(q) <= 0.425 - r = 0.180625 - q*q - return q * @horner(r, - 3.38713_28727_96366_6080e0, - 1.33141_66789_17843_7745e2, - 1.97159_09503_06551_4427e3, - 1.37316_93765_50946_1125e4, - 4.59219_53931_54987_1457e4, - 6.72657_70927_00870_0853e4, - 3.34305_75583_58812_8105e4, - 2.50908_09287_30122_6727e3) / - @horner(r, - 1.0, - 4.23133_30701_60091_1252e1, - 6.87187_00749_20579_0830e2, - 5.39419_60214_24751_1077e3, - 2.12137_94301_58659_5867e4, - 3.93078_95800_09271_0610e4, - 2.87290_85735_72194_2674e4, - 5.22649_52788_52854_5610e3) - else - if $(fn == :Φinv) - if p <= 0.0 - return p == 0.0 ? -inf(Float64) : nan(Float64) - elseif p >= 1.0 - return p == 1.0 ? inf(Float64) : nan(Float64) - end - r = sqrt(q < 0 ? -log(p) : -log1p(-p)) - else - if logp == -Inf - return -inf(Float64) - elseif logp >= 0.0 - return logp == 0.0 ? inf(Float64) : nan(Float64) - end - r = sqrt(q < 0 ? -logp : -log1mexp(logp)) - end - if r < 5.0 - r -= 1.6 - z = @horner(r, - 1.42343_71107_49683_57734e0, - 4.63033_78461_56545_29590e0, - 5.76949_72214_60691_40550e0, - 3.64784_83247_63204_60504e0, - 1.27045_82524_52368_38258e0, - 2.41780_72517_74506_11770e-1, - 2.27238_44989_26918_45833e-2, - 7.74545_01427_83414_07640e-4) / - @horner(r, - 1.0, - 2.05319_16266_37758_82187e0, - 1.67638_48301_83803_84940e0, - 6.89767_33498_51000_04550e-1, - 1.48103_97642_74800_74590e-1, - 1.51986_66563_61645_71966e-2, - 5.47593_80849_95344_94600e-4, - 1.05075_00716_44416_84324e-9) - else - r -= 5.0 - z = @horner(r, - 6.65790_46435_01103_77720e0, - 5.46378_49111_64114_36990e0, - 1.78482_65399_17291_33580e0, - 2.96560_57182_85048_91230e-1, - 2.65321_89526_57612_30930e-2, - 1.24266_09473_88078_43860e-3, - 2.71155_55687_43487_57815e-5, - 2.01033_43992_92288_13265e-7) / - @horner(r, - 1.0, - 5.99832_20655_58879_37690e-1, - 1.36929_88092_27358_05310e-1, - 1.48753_61290_85061_48525e-2, - 7.86869_13114_56132_59100e-4, - 1.84631_83175_10054_68180e-5, - 1.42151_17583_16445_88870e-7, - 2.04426_31033_89939_78564e-15) - end - return copysign(z,q) - end - end - end -end - -# log(x) - x + 1 -# fallback -logmxp1(x) = log(x) - x + one(x) -logmxp1(x::Integer) = logmxp1(float(x)) - -# negative of NSWC DRLOG -function logmxp1(x::Float64) - if (x < 0.61) || (x > 1.57) - return log(x) - (x-1.0) - end - if x < 0.82 - u = (x-0.7)/0.7 - up2 = u+2.0 - w1 = 0.566749439387323789126387112411845e-01 - u*0.3 - elseif x > 1.18 - t = 0.75*(x-1.0) - u = t-0.25 - up2 = t+1.75 - w1 = 0.456512608815524058941143273395059e-01 + u/3.0 - else - u = x-1.0 - up2 = x+1.0 - w1 = 0.0 - end - r = u/up2 - t = r*r - z = @horner(t, - 0.7692307692307692307680e-01, - -0.1505958055914600184836e+00, - 0.9302355725278521726994e-01, - -0.1787900022182327735804e-01) / - @horner(t,1.0, - -0.2824412139355646910683e+01, - 0.2892424216041495392509e+01, - -0.1263560605948009364422e+01, - 0.1966769435894561313526e+00) - w = @horner(t, - 0.333333333333333333333333333333333e+00, - 0.200000000000000000000000000000000e+00, - 0.142857142857142857142857142857143e+00, - 0.111111111111111111111111111111111e+00, - 0.909090909090909090909090909090909e-01, - z) - return r*(2.0*t*w-u) - w1 -end - -# negative of NSWC RLOG -function logmxp1(x::Float32) - if (x < 0.61f0) || (x > 1.57f0) - return log(x) - (x-1f0) - end - if x < 0.82f0 - u = (x-0.7f0)/0.7f0 - up2 = u+2f0 - w1 = 0.566749439387324f-01 - u*0.3f0 - elseif x > 1.18f0 - t = 0.75f0*(x-1f0) - u = t-0.25f0 - up2 = t+1.75f0 - w1 = 0.456512608815524f-01 + u/3f0 - else - u = x-1f0 - up2 = x+1f0 - w1 = 0f0 - end - r = u/up2 - t = r*r - w = @horner(t, - 0.333333333333333f+00, - -.224696413112536f+00, - 0.620886815375787f-02) / - @horner(t, 1f0, - -.127408923933623f+01, - 0.354508718369557f+00) - return r*(2f0*t*w-u) - w1 -end - - -log1pmx(x) = log1p(x) - x -# negative of NSWC DRLOG1 -function log1pmx(x::Float64) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION X - LN(1 + X) -#----------------------------------------------------------------------- -# DOUBLE PRECISION X -# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z -# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 -# DOUBLE PRECISION C1, C2, C3, C4, C5 -#------------------------- -# A = DRLOG (0.7) -# B = DRLOG (4/3) -#------------------------- - a = 0.566749439387323789126387112411845e-01 - b = 0.456512608815524058941143273395059e-01 -#------------------------- -#------------------------- -# CI = 1/(2I + 1) -#------------------------- -#------------------------- - if x >= -0.39 && x <= 0.57 # go to 100 - if x < -0.18 # go to 10 - u = (x + 0.3)/0.7 - up2 = u + 2.0 - w1 = a - u*0.3 - elseif x > 0.18 # go to 20 - t = 0.75*x - u = t - 0.25 - up2 = t + 1.75 - w1 = b + u/3.0 - else - u = x - up2 = u + 2.0 - w1 = 0.0 - end -# -# SERIES EXPANSION -# - r = u/up2 - t = r*r -# -# Z IS A MINIMAX APPROXIMATION OF THE SERIES -# -# C6 + C7*R**2 + C8*R**4 + ... -# -# FOR THE INTERVAL (0.0, 0.375). THE APPROX- -# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF -# THE 21-ST SIGNIFICANT DIGIT. -# - z = @horner(t, - .7692307692307692307680e-01, - -.1505958055914600184836e+00, - .9302355725278521726994e-01, - -.1787900022182327735804e-01) / - @horner(t,1.0, - -.2824412139355646910683e+01, - .2892424216041495392509e+01, - -.1263560605948009364422e+01, - .1966769435894561313526e+00) - w = @horner(t, - .333333333333333333333333333333333e+00, - .200000000000000000000000000000000e+00, - .142857142857142857142857142857143e+00, - .111111111111111111111111111111111e+00, - .909090909090909090909090909090909e-01, - z) - - return r*(2.0*t*w - u) - w1 - end - return log1p(x) - x -end - -# NSWC RLOG1 -function log1pmx(x::Float32) - a = 0.566749439387324f-01 - b = 0.456512608815524f-01 - - if x >= -0.39f0 && x <= 0.57f0 # go to 100 - if x < -0.18f0 # go to 10 - u = (x + 0.3f0)/0.7f0 - up2 = u + 2f0 - w1 = a - u*0.3f0 - elseif x > 0.18 # go to 20 - t = 0.75f0*x - u = t - 0.25f0 - up2 = t + 1.75f0 - w1 = b + u/3f0 - else - u = x - up2 = u + 2f0 - w1 = 0f0 - end -# -# SERIES EXPANSION -# - r = u/up2 - t = r*r - - w = @horner(t, - 0.333333333333333f+00, - -.224696413112536f+00, - 0.620886815375787f-02) / - @horner(t, 1f0, - -.127408923933623f+01, - 0.354508718369557f+00) - - return r*(2f0*t*w - u) - w1 - end - return log1p(x) - x -end - +# gamma and beta functions # Stirling series for the gamma function @@ -407,7 +19,6 @@ lstirling(x) = lgamma(x)- (x-0.5)*log(x) + x - 0.5*oftype(x,log2π) lstirling(x::Integer) = lstirling(float(x)) # based on NSWC DPDEL: only valid for values >= 10 -# Float32 version? function lstirling(x::Float64) if x <= 10.0 return lgamma(x) - (x-0.5)*log(x) + x - 0.5*log2π @@ -1682,7 +1293,7 @@ function dginv(a::Real, p::Real, q::Real) if q/e <= xmin return realmax() end if a == 1.0 if q >= 0.9 # go to 411 - return -dlnrel(-p) + return -log1p(-p) end return -log(q) end @@ -1758,7 +1369,7 @@ function dginv(a::Real, p::Real, q::Real) if b*q <= 1.0e-8 # go to 31 xn = exp(-(q/a + c)) elseif p > 0.9 # go to 32 - xn = exp((dlnrel(-q) + lgamma1p(a))/a) + xn = exp((log1p(-q) + lgamma1p(a))/a) else xn = exp(log(p*g)/a) end @@ -1810,8 +1421,8 @@ function dginv(a::Real, p::Real, q::Real) break end t = a - 1.0 - xn = y + t*log(xn) - dlnrel(-t/(xn + 1.0)) - xn = y + t*log(xn) - dlnrel(-t/(xn + 1.0)) + xn = y + t*log(xn) - log1p(-t/(xn + 1.0)) + xn = y + t*log(xn) - log1p(-t/(xn + 1.0)) useP = false break end @@ -2003,7 +1614,7 @@ function gaminv(a::Float32, x0::Float32, p::Float32, q::Float32) if q/e <= xmin return realmax(Float32), -8 end # go to 560 if a == 1.0f0 # go to 410 if q >= 0.9f0 # go to 411 - return -alnrel(-p), ierr + return -log1p(-p), ierr end return -log(q), ierr end @@ -2067,7 +1678,7 @@ function gaminv(a::Float32, x0::Float32, p::Float32, q::Float32) if b*q <= 1.f-8 # go to 21 xn = exp(-(q/a + c)) elseif p > 0.9 # go to 22 - xn = exp((alnrel(-q) + gamln1(a))/a) + xn = exp((log1p(-q) + gamln1(a))/a) else xn = exp(log(p*g)/a) end @@ -2123,8 +1734,8 @@ function gaminv(a::Float32, x0::Float32, p::Float32, q::Float32) return xn, ierr end t = a - 1.0f0 - xn = y + t*log(xn) - alnrel(-t/(xn + 1.0f0)) - xn = y + t*log(xn) - alnrel(-t/(xn + 1.0f0)) + xn = y + t*log(xn) - log1p(-t/(xn + 1.0f0)) + xn = y + t*log(xn) - log1p(-t/(xn + 1.0f0)) useP = false break end @@ -2731,9 +2342,9 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) if (x <= 0.375)# go to 10 lnx = log(x) - lny = dlnrel(-x) + lny = log1p(-x) elseif (y <= 0.375)# go to 20 - lnx = dlnrel(-y) + lnx = log1p(-y) lny = log(y) else lnx = log(x) @@ -2849,9 +2460,9 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) if (x <= 0.375)# go to 10 lnx = log(x) - lny = dlnrel(-x) + lny = log1p(-x) elseif (y <= 0.375)# go to 20 - lnx = dlnrel(-y) + lnx = log1p(-y) lny = log(y) else lnx = log(x) @@ -2967,7 +2578,7 @@ function bgrat(a::Real, b::Real, x::Real, y::Real, w::Real, precision::Real) bm1 = (b - 0.5) - 0.5 nu = a + 0.5*bm1 if y <= 0.375 - lnx = dlnrel(-y) + lnx = log1p(-y) else lnx = log(x) end @@ -3350,7 +2961,7 @@ function dlgdiv(a::Real, b::Real) # # COMBINE THE RESULTS # - u = d*dlnrel(a/b) + u = d*log1p(a/b) v = a*(log(b) - 1.0) if u > v # go to 40 return (w - v) - u @@ -3358,77 +2969,6 @@ function dlgdiv(a::Real, b::Real) return (w - u) - v end -function dlnrel(a::Real) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION LN(1 + A) -#----------------------------------------------------------------------- -# DOUBLE PRECISION A, T, T2, W, Z -# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 -# DOUBLE PRECISION C1, C2, C3, C4, C5 -#------------------------- - p0 = .7692307692307692307680e-01 - p1 = -.1505958055914600184836e+00 - p2 = .9302355725278521726994e-01 - p3 = -.1787900022182327735804e-01 - q1 = -.2824412139355646910683e+01 - q2 = .2892424216041495392509e+01 - q3 = -.1263560605948009364422e+01 - q4 = .1966769435894561313526e+00 -#------------------------- -# CI = 1/(2I + 1) -#------------------------- - c1 = .3333333333333333333333333333333e+00 - c2 = .2000000000000000000000000000000e+00 - c3 = .1428571428571428571428571428571e+00 - c4 = .1111111111111111111111111111111e+00 - c5 = .9090909090909090909090909090909e-01 -#------------------------- - if abs(a) >= 0.375 # go to 10 - t = 1.0 + a - if a < 0.0 t = 0.50 + (0.50 + a) end - return log(t) - end -# -# W IS A MINIMAX APPROXIMATION OF THE SERIES -# -# C6 + C7*T**2 + C8*T**4 + ... -# -# THIS APPROXIMATION IS ACCURATE TO WITHIN -# 1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT. -# THE RESULTING VALUE FOR 1.D0 + T2*Z IS -# ACCURATE TO WITHIN 1 UNIT OF THE 30-TH -# SIGNIFICANT DIGIT. -# - t = a/(a + 2.0) - t2 = t*t - w = (((p3*t2 + p2)*t2 + p1)*t2 + p0)/((((q4*t2 + q3)*t2 + q2)*t2 + q1)*t2 + 1.0) - - z = ((((w*t2 + c5)*t2 + c4)*t2 + c3)*t2 + c2)*t2 + c1 - return 2.0*t*(1.0 + t2*z) -end - -function alnrel(a::Float32) -#----------------------------------------------------------------------- -# EVALUATION OF THE FUNCTION LN(1 + A) -#----------------------------------------------------------------------- - p1 = -.129418923021993f+01 - p2 = .405303492862024f+00 - p3 = -.178874546012214f-01 - q1 = -.162752256355323f+01 - q2 = .747811014037616f+00 - q3 = -.845104217945565f-01 -#-------------------------- - if abs(a) <= 0.375 # go to 10 - t = a/(a + 2.0f0) - t2 = t*t - w = (((p3*t2 + p2)*t2 + p1)*t2 + 1.0f0)/(((q3*t2 + q2)*t2 + q1)*t2 + 1.0f0) - return 2.0f0*t*w - end - - x = 1.0f0 + a - if a < 0.0 x = (a + 0.5f0) + 0.5f0 end - return log(x) -end function dbetln(a0::Real, b0::Real) #----------------------------------------------------------------------- @@ -3513,7 +3053,7 @@ function dbetln(a0::Real, b0::Real) h = a/b c = h/(1.0 + h) u = -(a - 0.50)*log(c) - v = b*dlnrel(h) + v = b*log1p(h) if u > v # go to 61 return (((-0.5*log(b) + e) + w) - v) - u end @@ -3533,7 +3073,7 @@ function dgsmln(a::Real, b::Real) return lgamma1p(1.0 + x) end if x < 1.50 # go to 20 - return lgamma1p(x) + dlnrel(x) + return lgamma1p(x) + log1p(x) end return lgamma1p(x - 1.0) + log(x*(1.0 + x)) end diff --git a/src/specialfuns/log.jl b/src/specialfuns/log.jl new file mode 100644 index 000000000..795ea3548 --- /dev/null +++ b/src/specialfuns/log.jl @@ -0,0 +1,211 @@ +# special log functions + +# log1mexp and log1pexp are based on: +# Martin Maechler (2012) "Accurately Computing log(1 − exp(− |a|))" +# http://cran.r-project.org/web/packages/Rmpfr/vignettes/log1mexp-note.pdf + +# log(1-exp(x)) +# NOTE: different than Maechler (2012), no negation inside parantheses +log1mexp(x::Real) = x >= -0.6931471805599453 ? log(-expm1(x)) : log1p(-exp(x)) +# log(1+exp(x)) +log1pexp(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log1p(exp(x)) : x +log1pexp(x::Float64) = x <= 18.0 ? log1p(exp(x)) : x <= 33.3 ? x + exp(-x) : x +log1pexp(x::Float32) = x <= 9f0 ? log1p(exp(x)) : x <= 16f0 ? x + exp(-x) : x +log1pexp(x::Integer) = log1pexp(float(x)) + +# log(exp(x)-1) +# still inaccurate for values close to log(2) +logexpm1(x::BigFloat) = x <= realmaxexp(typeof(x)) ? log(expm1(x)) : x +logexpm1(x::Float64) = x <= 18.0 ? log(expm1(x)) : x <= 33.3 ? x - exp(-x) : x +logexpm1(x::Float32) = x <= 9f0 ? log(expm1(x)) : x <= 16f0 ? x - exp(-x) : x +logexpm1(x::Integer) = logexpm1(float(x)) + + + +logmxp1(x) = log(x) - x + one(x) +logmxp1(x::Integer) = logmxp1(float(x)) + +# negative of NSWC DRLOG +function logmxp1(x::Float64) + if (x < 0.61) || (x > 1.57) + return log(x) - (x-1.0) + end + if x < 0.82 + u = (x-0.7)/0.7 + up2 = u+2.0 + w1 = 0.566749439387323789126387112411845e-01 - u*0.3 + elseif x > 1.18 + t = 0.75*(x-1.0) + u = t-0.25 + up2 = t+1.75 + w1 = 0.456512608815524058941143273395059e-01 + u/3.0 + else + u = x-1.0 + up2 = x+1.0 + w1 = 0.0 + end + r = u/up2 + t = r*r + z = @horner(t, + 0.7692307692307692307680e-01, + -0.1505958055914600184836e+00, + 0.9302355725278521726994e-01, + -0.1787900022182327735804e-01) / + @horner(t,1.0, + -0.2824412139355646910683e+01, + 0.2892424216041495392509e+01, + -0.1263560605948009364422e+01, + 0.1966769435894561313526e+00) + w = @horner(t, + 0.333333333333333333333333333333333e+00, + 0.200000000000000000000000000000000e+00, + 0.142857142857142857142857142857143e+00, + 0.111111111111111111111111111111111e+00, + 0.909090909090909090909090909090909e-01, + z) + return r*(2.0*t*w-u) - w1 +end + +# negative of NSWC RLOG +function logmxp1(x::Float32) + if (x < 0.61f0) || (x > 1.57f0) + return log(x) - (x-1f0) + end + if x < 0.82f0 + u = (x-0.7f0)/0.7f0 + up2 = u+2f0 + w1 = 0.566749439387324f-01 - u*0.3f0 + elseif x > 1.18f0 + t = 0.75f0*(x-1f0) + u = t-0.25f0 + up2 = t+1.75f0 + w1 = 0.456512608815524f-01 + u/3f0 + else + u = x-1f0 + up2 = x+1f0 + w1 = 0f0 + end + r = u/up2 + t = r*r + w = @horner(t, + 0.333333333333333f+00, + -.224696413112536f+00, + 0.620886815375787f-02) / + @horner(t, 1f0, + -.127408923933623f+01, + 0.354508718369557f+00) + return r*(2f0*t*w-u) - w1 +end + + +log1pmx(x) = log1p(x) - x +# negative of NSWC DRLOG1 +function log1pmx(x::Float64) +#----------------------------------------------------------------------- +# EVALUATION OF THE FUNCTION X - LN(1 + X) +#----------------------------------------------------------------------- +# DOUBLE PRECISION X +# DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z +# DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 +# DOUBLE PRECISION C1, C2, C3, C4, C5 +#------------------------- +# A = DRLOG (0.7) +# B = DRLOG (4/3) +#------------------------- + a = 0.566749439387323789126387112411845e-01 + b = 0.456512608815524058941143273395059e-01 +#------------------------- +#------------------------- +# CI = 1/(2I + 1) +#------------------------- +#------------------------- + if x >= -0.39 && x <= 0.57 # go to 100 + if x < -0.18 # go to 10 + u = (x + 0.3)/0.7 + up2 = u + 2.0 + w1 = a - u*0.3 + elseif x > 0.18 # go to 20 + t = 0.75*x + u = t - 0.25 + up2 = t + 1.75 + w1 = b + u/3.0 + else + u = x + up2 = u + 2.0 + w1 = 0.0 + end +# +# SERIES EXPANSION +# + r = u/up2 + t = r*r +# +# Z IS A MINIMAX APPROXIMATION OF THE SERIES +# +# C6 + C7*R**2 + C8*R**4 + ... +# +# FOR THE INTERVAL (0.0, 0.375). THE APPROX- +# IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF +# THE 21-ST SIGNIFICANT DIGIT. +# + z = @horner(t, + .7692307692307692307680e-01, + -.1505958055914600184836e+00, + .9302355725278521726994e-01, + -.1787900022182327735804e-01) / + @horner(t,1.0, + -.2824412139355646910683e+01, + .2892424216041495392509e+01, + -.1263560605948009364422e+01, + .1966769435894561313526e+00) + w = @horner(t, + .333333333333333333333333333333333e+00, + .200000000000000000000000000000000e+00, + .142857142857142857142857142857143e+00, + .111111111111111111111111111111111e+00, + .909090909090909090909090909090909e-01, + z) + + return r*(2.0*t*w - u) - w1 + end + return log1p(x) - x +end + +# NSWC RLOG1 +function log1pmx(x::Float32) + a = 0.566749439387324f-01 + b = 0.456512608815524f-01 + + if x >= -0.39f0 && x <= 0.57f0 # go to 100 + if x < -0.18f0 # go to 10 + u = (x + 0.3f0)/0.7f0 + up2 = u + 2f0 + w1 = a - u*0.3f0 + elseif x > 0.18 # go to 20 + t = 0.75f0*x + u = t - 0.25f0 + up2 = t + 1.75f0 + w1 = b + u/3f0 + else + u = x + up2 = u + 2f0 + w1 = 0f0 + end +# +# SERIES EXPANSION +# + r = u/up2 + t = r*r + + w = @horner(t, + 0.333333333333333f+00, + -.224696413112536f+00, + 0.620886815375787f-02) / + @horner(t, 1f0, + -.127408923933623f+01, + 0.354508718369557f+00) + + return r*(2f0*t*w - u) - w1 + end + return log1p(x) - x +end diff --git a/src/specialfuns/misc.jl b/src/specialfuns/misc.jl new file mode 100644 index 000000000..bc673d1ef --- /dev/null +++ b/src/specialfuns/misc.jl @@ -0,0 +1,8 @@ + +# the largest x such that exp(x) < Inf +realmaxexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmax(T)),RoundDown) +realmaxexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(prevfloat(inf(BigFloat))),RoundDown) + +# the smallest x such that exp(x) > 0 (or at least not a subnormal number) +realminexp{T<:FloatingPoint}(::Type{T}) = with_rounding(()->log(realmin(T)),RoundUp) +realminexp(::Type{BigFloat}) = with_bigfloat_rounding(()->log(nextfloat(zero(BigFloat))),RoundUp) diff --git a/src/specialfuns/normal.jl b/src/specialfuns/normal.jl new file mode 100644 index 000000000..8c811c68f --- /dev/null +++ b/src/specialfuns/normal.jl @@ -0,0 +1,170 @@ +# normal density and cumulative distribution functions + +φ(z::Real) = exp(-0.5*z*z)/√2π +logφ(z::Real) = -0.5*(z*z + log2π) + +Φ(z::Real) = 0.5*erfc(-z/√2) +Φc(z::Real) = 0.5*erfc(z/√2) +logΦ(z::Real) = z < -1.0 ? log(0.5*erfcx(-z/√2)) - 0.5*z*z : log1p(-0.5*erfc(z/√2)) +logΦc(z::Real) = z > 1.0 ? log(0.5*erfcx(z/√2)) - 0.5*z*z : log1p(-0.5*erfc(-z/√2)) + +import Base.Math.@horner + +# Rational approximations for the inverse cdf, from: +# Wichura, M.J. (1988) Algorithm AS 241: The Percentage Points of the Normal Distribution +# Journal of the Royal Statistical Society. Series C (Applied Statistics), Vol. 37, No. 3, pp. 477-484 +Φinv(p::Integer) = Φinv(float(p)) +logΦinv(p::Integer) = logΦinv(float(p)) + +for (fn,arg) in ((:Φinv,:p),(:logΦinv,:logp)) + @eval begin + function $fn($arg::Float32) + if $(fn == :Φinv) + q = p - 0.5f0 + else + q = exp(logp) - 0.5f0 + end + if abs(q) <= 0.425f0 + r = 0.180625f0 - q*q + return q * @horner(r, + 3.38713_27179f0, + 5.04342_71938f1, + 1.59291_13202f2, + 5.91093_74720f1, + ) / + @horner(r, + 1.0f0, + 1.78951_69469f1, + 7.87577_57664f1, + 6.71875_63600f1) + else + if $(fn == :Φinv) + if p <= 0f0 + return p == 0f0 ? -inf(Float32) : nan(Float32) + elseif p >= 1f0 + return p == 1f0 ? inf(Float32) : nan(Float32) + end + r = sqrt(q < 0f0 ? -log(p) : -log1p(-p)) + else + if logp == -Inf + return -inf(Float32) + elseif logp >= 0f0 + return logp == 0f0 ? inf(Float32) : nan(Float32) + end + r = sqrt(qf0 < 0 ? -logp : -log1mexp(logp)) + end + if r < 5.0f0 + r -= 1.6f0 + z = @horner(r, + 1.42343_72777f0, + 2.75681_53900f0, + 1.30672_84816f0, + 1.70238_21103f-1) / + @horner(r, + 1.0f0, + 7.37001_64250f-1, + 1.20211_32975f-1) + else + r -= 5.0f0 + z = @horner(r, + 6.65790_51150f0, + 3.08122_63860f0, + 4.28682_94337f-1, + 1.73372_03997f-2) / + @horner(r, + 1.0f0, + 2.41978_94225f-1, + 1.22582_02635f-2) + end + return copysign(z,q) + end + end + + function $fn($arg::Float64) + if $(fn == :Φinv) + q = p - 0.5 + else + q = exp(logp) - 0.5 + end + if abs(q) <= 0.425 + r = 0.180625 - q*q + return q * @horner(r, + 3.38713_28727_96366_6080e0, + 1.33141_66789_17843_7745e2, + 1.97159_09503_06551_4427e3, + 1.37316_93765_50946_1125e4, + 4.59219_53931_54987_1457e4, + 6.72657_70927_00870_0853e4, + 3.34305_75583_58812_8105e4, + 2.50908_09287_30122_6727e3) / + @horner(r, + 1.0, + 4.23133_30701_60091_1252e1, + 6.87187_00749_20579_0830e2, + 5.39419_60214_24751_1077e3, + 2.12137_94301_58659_5867e4, + 3.93078_95800_09271_0610e4, + 2.87290_85735_72194_2674e4, + 5.22649_52788_52854_5610e3) + else + if $(fn == :Φinv) + if p <= 0.0 + return p == 0.0 ? -inf(Float64) : nan(Float64) + elseif p >= 1.0 + return p == 1.0 ? inf(Float64) : nan(Float64) + end + r = sqrt(q < 0 ? -log(p) : -log1p(-p)) + else + if logp == -Inf + return -inf(Float64) + elseif logp >= 0.0 + return logp == 0.0 ? inf(Float64) : nan(Float64) + end + r = sqrt(q < 0 ? -logp : -log1mexp(logp)) + end + if r < 5.0 + r -= 1.6 + z = @horner(r, + 1.42343_71107_49683_57734e0, + 4.63033_78461_56545_29590e0, + 5.76949_72214_60691_40550e0, + 3.64784_83247_63204_60504e0, + 1.27045_82524_52368_38258e0, + 2.41780_72517_74506_11770e-1, + 2.27238_44989_26918_45833e-2, + 7.74545_01427_83414_07640e-4) / + @horner(r, + 1.0, + 2.05319_16266_37758_82187e0, + 1.67638_48301_83803_84940e0, + 6.89767_33498_51000_04550e-1, + 1.48103_97642_74800_74590e-1, + 1.51986_66563_61645_71966e-2, + 5.47593_80849_95344_94600e-4, + 1.05075_00716_44416_84324e-9) + else + r -= 5.0 + z = @horner(r, + 6.65790_46435_01103_77720e0, + 5.46378_49111_64114_36990e0, + 1.78482_65399_17291_33580e0, + 2.96560_57182_85048_91230e-1, + 2.65321_89526_57612_30930e-2, + 1.24266_09473_88078_43860e-3, + 2.71155_55687_43487_57815e-5, + 2.01033_43992_92288_13265e-7) / + @horner(r, + 1.0, + 5.99832_20655_58879_37690e-1, + 1.36929_88092_27358_05310e-1, + 1.48753_61290_85061_48525e-2, + 7.86869_13114_56132_59100e-4, + 1.84631_83175_10054_68180e-5, + 1.42151_17583_16445_88870e-7, + 2.04426_31033_89939_78564e-15) + end + return copysign(z,q) + end + end + end +end diff --git a/test/discrete.jl b/test/discrete.jl index 80f04dd65..b162637f8 100644 --- a/test/discrete.jl +++ b/test/discrete.jl @@ -147,7 +147,7 @@ for d in [ @test_approx_eq mean(d) xmean @test_approx_eq var(d) xvar @test_approx_eq std(d) xstd - @test_approx_eq_eps skewness(d) xskew 1000eps() + @test_approx_eq skewness(d) xskew @test_approx_eq kurtosis(d) xkurt @test_approx_eq entropy(d) xentropy From 43de03476b9f4cd586318eca65b4b052f1835b31 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Thu, 19 Sep 2013 18:27:23 +0100 Subject: [PATCH 08/19] Binomial rand, tweak special functions --- src/Distributions.jl | 1 + src/specialfuns/log.jl | 2 +- src/univariate/binomial_rand.jl | 165 ++++++++++++++++++++++++++++++++ test/specialfuns.jl | 26 ++--- 4 files changed, 180 insertions(+), 14 deletions(-) create mode 100644 src/univariate/binomial_rand.jl diff --git a/src/Distributions.jl b/src/Distributions.jl index dbae385d7..0d68a12a7 100644 --- a/src/Distributions.jl +++ b/src/Distributions.jl @@ -210,6 +210,7 @@ include(joinpath("univariate", "bernoulli.jl")) include(joinpath("univariate", "beta.jl")) include(joinpath("univariate", "betaprime.jl")) include(joinpath("univariate", "binomial.jl")) +include(joinpath("univariate", "binomial_rand.jl")) include(joinpath("univariate", "categorical.jl")) include(joinpath("univariate", "cauchy.jl")) include(joinpath("univariate", "chi.jl")) diff --git a/src/specialfuns/log.jl b/src/specialfuns/log.jl index 795ea3548..d70fa7e11 100644 --- a/src/specialfuns/log.jl +++ b/src/specialfuns/log.jl @@ -181,7 +181,7 @@ function log1pmx(x::Float32) u = (x + 0.3f0)/0.7f0 up2 = u + 2f0 w1 = a - u*0.3f0 - elseif x > 0.18 # go to 20 + elseif x > 0.18f0 # go to 20 t = 0.75f0*x u = t - 0.25f0 up2 = t + 1.75f0 diff --git a/src/univariate/binomial_rand.jl b/src/univariate/binomial_rand.jl new file mode 100644 index 000000000..70005289d --- /dev/null +++ b/src/univariate/binomial_rand.jl @@ -0,0 +1,165 @@ +# rand meta-algorithm +# most other methods assume prob <= 0.5 +function rand(d::Binomial) + p, n = d.prob, d.size + if p <= 0.5 + r = p + else + r = 1.0-p + end + if r*n <= 10.0 + y = rand_bg(Binomial(n,r)) + else + y = rand_btpe(Binomial(n,r)) + end + p <= 0.5 ? y : n-y +end + + +# simplest algorithm +function rand_bu(d::Binomial) + p, n = d.prob, d.size + y = 0 + for i = 1:n + if rand() <= p + y += 1 + end + end +end + +# Geometric method: +# Devroye. L. +# "Generating the maximum of independent identically distributed random variables" +# Computers and Marhemafics with Applicalions 6, 1960, 305-315. +function rand_bg(d::Binomial) + p, n = d.prob, d.size + y = 0 + x = -1 + while true + y += rand(Geometric(p)) +1 + x += 1 + if y > n + return x + end + end +end + + +# BTPE algorithm from: +# Kachitvichyanukul, V.; Schmeiser, B. W. +# "Binomial random variate generation." +# Comm. ACM 31 (1988), no. 2, 216–222. +function rand_btpe(d::Binomial) + # Step 0 + r, n = d.prob, d.size + q = 1.0 - r + nrq = n*r*q + fM = (n+1)*r + M = floor(fM) + Mi = integer(M) + p1 = floor(2.195*sqrt(nrq)-4.6*q) + 0.5 + xM = M+0.5 + xL = xM-p1 + xR = xM+p1 + c = 0.134 + 20.5/(15.3+M) + a = (fM-xL)/(fM-xL*r) + λL = a*(1.0 + 0.5*a) + a = (xR-fM)/(xR*q) + λR = a*(1.0 + 0.5*a) + p2 = p1*(1.0 + 2.0*c) + p3 = p2 + c/λL + p4 = p3 + c/λR + + y = 0 + + while true + # Step 1 + u = p4*rand() + v = rand() + if u <= p1 + y = ifloor(xM-p1*v+u) + # Goto 6 + return y + + elseif u <= p2 # Step 2 + x = xL + (u-p1)/c + v = v*c+1.0-abs(M-x+0.5)/p1 + if v > 1 + # Goto 1 + continue + end + y = ifloor(x) + # Goto 5 + + elseif u <= p3 # Step 3 + y = ifloor(xL + log(v)/λL) + if y < 0 + # Goto 1 + continue + end + v *= (u-p2)*λL + # Goto 5 + + else # Step 4 + y = ifloor(xR-log(v)/λR) + if y > n + # Goto 1 + continue + end + v *= (u-p3)*λR + # Goto 5 + end + + # Step 5 + # 5.0 + k = abs(y-Mi) + if (k <= 20) || (k >= nrq/2-1) + # 5.1 + s = r/q + a = s*(n+1) + F = 1.0 + if Mi < y + for i = (Mi+1):y + F *= a/i-s + end + elseif Mi > y + for i = (y+1):Mi + F /= a/i-s + end + end + if v > F + # Goto 1 + continue + end + # Goto 6 + return y + else + # 5.2 + ρ = (k/nrq)*((k*(k/3.0+0.625)+0.16666666666666666)/nrq+0.5) + t = -k^2/(2.0*nrq) + A = log(v) + if A < t - ρ + # Goto 6 + return y + elseif A > t + ρ + # Goto 1 + continue + end + + # 5.3 + x1 = y+1 + f1 = Mi+1 + z = n+1-Mi + w = n-y+1 + + if A > (xM*log(f1/x1) + (n-M+0.5)*log(z/w) + (y-Mi)log(w*r/(x1*q)) + + lstirling(f1) + lstirling(z) + lstirling(x1) + lstirling(w)) + # Goto 1 + continue + end + + # Goto 6 + return y + end + end +end diff --git a/test/specialfuns.jl b/test/specialfuns.jl index a2c88c164..16b48de3c 100644 --- a/test/specialfuns.jl +++ b/test/specialfuns.jl @@ -25,13 +25,13 @@ import Distributions.lstirling macro test_floatvsbig(a,fac) fargs = a.args[2:] - b = :(oftype($(fargs[1]),$(Expr(:call,a.args[1],[:(big($u)) for u = fargs]...)))) + b = Expr(:call,a.args[1],[:(big($u)) for u = fargs]...) stra = string(a) strb = string(b) - argstr = :(string($([:(string($(string(u))," = ",$u,", ")) for u in fargs]...))) + argstr = :(string($([:(string($(string(u))," = ",$u,"::",typeof($u),", ")) for u in fargs]...))) quote va = $(esc(a)) - vb = $(esc(b)) + vb = oftype(va,$(esc(b))) diff = abs(va - vb) maxeps = eps(max(abs(va),abs(vb))) if diff > $(esc(fac))*maxeps @@ -46,12 +46,9 @@ end -# 10 random mantissas +# random mantissas X = rand(10)+1.0 -# todo: -# - lower relative error threshold -# - Float32 checks for x = X for t = [Float32, Float64] @@ -59,15 +56,18 @@ for x = X for i = exponent(realmin(t)):exponent(realmax(t)) y = oftype(t,x*2.0^i) ny = -y - @test_floatvsbig log1mexp(ny) 8 - @test_floatvsbig log1pexp(y) 8 + @test_floatvsbig log1mexp(ny) 2 + @test_floatvsbig log1pexp(y) 2 if !(0.5= 1e-60 # BigFloat underflow @test_floatvsbig log1pmx(y) 8 if ny > -1 @@ -76,8 +76,8 @@ for x = X end if y >= 10 # currently only valid for this range - if y < 1e28 # BigFloat underflow - @test_floatvsbig lstirling(y) 8 + if y < 1e28 # else BigFloat underflow + @test_floatvsbig lstirling(y) 2 end end end From 64a528b8dae6c2408e2fc50b72259a01cbbce414 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Fri, 20 Sep 2013 13:41:29 +0100 Subject: [PATCH 09/19] Poisson rand --- src/Distributions.jl | 1 + src/univariate/poisson.jl | 75 ++++++++++++++++++--------- src/univariate/poisson_rand.jl | 93 ++++++++++++++++++++++++++++++++++ 3 files changed, 144 insertions(+), 25 deletions(-) create mode 100644 src/univariate/poisson_rand.jl diff --git a/src/Distributions.jl b/src/Distributions.jl index 0d68a12a7..beac7fa29 100644 --- a/src/Distributions.jl +++ b/src/Distributions.jl @@ -243,6 +243,7 @@ include(joinpath("univariate", "noncentralt.jl")) include(joinpath("univariate", "normal.jl")) include(joinpath("univariate", "pareto.jl")) include(joinpath("univariate", "poisson.jl")) +include(joinpath("univariate", "poisson_rand.jl")) include(joinpath("univariate", "rayleigh.jl")) include(joinpath("univariate", "skellam.jl")) include(joinpath("univariate", "tdist.jl")) diff --git a/src/univariate/poisson.jl b/src/univariate/poisson.jl index bee1f72c3..cc3987749 100644 --- a/src/univariate/poisson.jl +++ b/src/univariate/poisson.jl @@ -7,10 +7,16 @@ immutable Poisson <: DiscreteUnivariateDistribution Poisson() = new(1.0) end -function cdf(d::Poisson, x::Real) - if x < 0 return 0.0 end - dgrat(floor(x), d.lambda)[2] + pdf(d, x) -end +insupport(::Poisson, x::Real) = isinteger(x) && zero(x) <= x +insupport(::Type{Poisson}, x::Real) = isinteger(x) && zero(x) <= x + +mean(d::Poisson) = d.lambda +mode(d::Poisson) = ifloor(d.lambda) +modes(d::Poisson) = [mode(d)] + +var(d::Poisson) = d.lambda +skewness(d::Poisson) = 1.0 / sqrt(d.lambda) +kurtosis(d::Poisson) = 1.0 / d.lambda function entropy(d::Poisson) λ = d.lambda @@ -28,14 +34,49 @@ function entropy(d::Poisson) end end -insupport(::Poisson, x::Real) = isinteger(x) && zero(x) <= x -insupport(::Type{Poisson}, x::Real) = isinteger(x) && zero(x) <= x -kurtosis(d::Poisson) = 1.0 / d.lambda +# Based on: +# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" +# available from: +# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf +# Uses slightly different forms instead of D0 function +function pdf(d::Poisson, x::Real) + if !insupport(d,x) + return 0.0 + end + if x == 0 + return exp(-d.lambda) + end + # NSWC version: + drcomp(x, d.lambda)/x + # Loader's version: + # exp(x*logmxp1(d.lambda/x)-lstirling(x))/(√2π*sqrt(x)) +end +function logpdf(d::Poisson, x::Real) + if !insupport(d,x) + return -Inf + end + if x == 0 + return -d.lambda + end + x*logmxp1(d.lambda/x)-lstirling(x)-0.5*(log2π+log(x)) +end + + +function cdf(d::Poisson, x::Real) + if x < 0 + return 0.0 + end + dgrat(floor(x)+1.0, d.lambda)[2] +end +function ccdf(d::Poisson, x::Real) + if x < 0 + return 1.0 + end + dgrat(floor(x)+1.0, d.lambda)[1] +end -mean(d::Poisson) = d.lambda -median(d::Poisson) = quantile(d, 0.5) function mgf(d::Poisson, t::Real) l = d.lambda @@ -47,22 +88,6 @@ function cf(d::Poisson, t::Real) return exp(l * (exp(im * t) - 1.0)) end -mode(d::Poisson) = ifloor(d.lambda) -modes(d::Poisson) = [mode(d)] - -pdf(d::Poisson, x::Real) = insupport(d, x) ? drcomp(x, d.lambda)/x : 0.0 - -skewness(d::Poisson) = 1.0 / sqrt(d.lambda) - -var(d::Poisson) = d.lambda - -# Based on: -# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" -# available from: -# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf -# Uses slightly different forms instead of D0 function -pdf(d::Poisson, x::Real) = exp(x*logmxp1(d.lambda/x)-lstirling(x))/(√2π*sqrt(x)) -logpdf(d::Poisson, x::Real) = x*logmxp1(d.lambda/x)-lstirling(x)-0.5*(log2π+log(x)) function fit_mle(::Type{Poisson}, x::Array) diff --git a/src/univariate/poisson_rand.jl b/src/univariate/poisson_rand.jl new file mode 100644 index 000000000..1aed40e3c --- /dev/null +++ b/src/univariate/poisson_rand.jl @@ -0,0 +1,93 @@ + +# algorithm from: +# J.H. Ahrens, U. Dieter (1982) +# "Computer Generation of Poisson Deviates from Modified Normal Distributions" +# ACM Transactions on Mathematical Software, 8(2):163-179 +function rand(d::Poisson) + μ = d.lambda + if μ >= 10.0 # Case A + + s = sqrt(μ) + d = 6.0*μ^2 + L = ifloor(μ-1.1484) + + # Step N + T = randn() + G = μ + s*T + + if G >= 0.0 + K = ifloor(G) + # Step I + if K >= L + return K + end + + # Step S + U = rand() + if d*U >= (μ-K)^3 + return K + end + + # Step P + px,py,fx,fy = procf(μ,K,s) + + # Step Q + if fy*(1-U) <= py*exp(px-fx) + return K + end + end + + while true + # Step E + E = Base.Random.randmtzig_exprnd() + U = rand() + U = 2.0*U-1.0 + T = 1.8+copysign(E,U) + if T <= -0.6744 + continue + end + + K = ifloor(μ + s*T) + px,py,fx,fy = procf(μ,K,s) + c = 0.1069/μ + + # Step H + if c*abs(U) <= py*exp(px+E)-fy*exp(fx+E) + return K + end + end + else # Case B + # Ahrens & Dieter use a sequential method for tabulating and looking up quantiles. + # TODO: check which is more efficient. + return quantile(d,rand()) + end +end + + +# Procedure F +function procf(μ,K,s) + ω = 0.3989422804014327/s + b1 = 0.041666666666666664/μ + b2 = 0.3*b1^2 + c3 = 0.14285714285714285*b1*b2 + c2 = b2 - 15.0*c3 + c1 = b1 - 6.0*b2 + 45.0*c3 + c0 = 1.0 - b1 + 3.0*b2 - 15.0*c3 + + if K < 10 + px = -μ + py = μ^K/factorial(K) # replace with loopup? + else + δ = 0.08333333333333333/K + δ -= 4.8*δ^3 + V = (μ-K)/K + px = K*log1pmx(V) - δ # avoids need for table + py = 0.3989422804014327/sqrt(K) + + end + X = (K-μ+0.5)/s + X2 = X^2 + fx = -0.5*X2 # missing negation in paper + fy = ω*(((c3*X2+c2)*X2+c1)*X2+c0) + return px,py,fx,fy +end From 949f313fd0d8f6cc71a6be0c07d4444615d2bf60 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Fri, 20 Sep 2013 17:41:53 +0100 Subject: [PATCH 10/19] gamma distribution work, more special function dispatch --- src/constants.jl | 1 + src/specialfuns/gammabeta.jl | 105 ++++++++++++++++++----------------- src/univariate/gamma.jl | 44 +++++++-------- src/univariate/poisson.jl | 31 +++-------- 4 files changed, 86 insertions(+), 95 deletions(-) diff --git a/src/constants.jl b/src/constants.jl index f9e65befd..85b997659 100644 --- a/src/constants.jl +++ b/src/constants.jl @@ -6,3 +6,4 @@ import Base.@math_const @math_const √2 1.4142135623730950488 sqrt(big(2.)) @math_const log2π 1.8378770664093454836 log(big(2.)*π) @math_const √2π 2.5066282746310005024 sqrt(big(2.)*π) +@math_const r√2π 0.3989422804014326779 1/sqrt(big(2.)*π) \ No newline at end of file diff --git a/src/specialfuns/gammabeta.jl b/src/specialfuns/gammabeta.jl index 49635318a..dbe4d5ab4 100644 --- a/src/specialfuns/gammabeta.jl +++ b/src/specialfuns/gammabeta.jl @@ -66,6 +66,8 @@ end # The regularized incomplete gamma function # Translated from the NSWC Library +gratio(a::Float32, x::Float32) = gratio(a,x,0) + function gratio(a::Float32, x::Float32, ind::Integer) #----------------------------------------------------------------------- # @@ -541,7 +543,7 @@ function gratio(a::Float32, x::Float32, ind::Integer) return ans, 0.5f0 + (0.5f0 - ans) end -function dgrat(a::Real, x::Real) +function gratio(a::Real, x::Real) #----------------------------------------------------------------------- # # EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS @@ -633,7 +635,7 @@ function dgrat(a::Real, x::Real) if qans <= 0.0 return 1.0, 0.0 end return 0.5 + (0.5 - qans), qans end - r = drcomp(a,x) + r = rcomp(a,x) if r == 0.0 return 1.0, 0.0 end break end # go to 170 @@ -687,7 +689,7 @@ function dgrat(a::Real, x::Real) break end - r = drcomp(a,x) + r = rcomp(a,x) if r == 0.0 # go to 331 if abs(s) <= 2.0*e error("ierr=3") end if x < a return 0.0, 1.0 end @@ -779,61 +781,60 @@ function dgrat(a::Real, x::Real) return 0.5 + (0.5 - qans), qans end -function rcomp(a::Float32, x::Float32) -#----------------------------------------------------------------------- -# EVALUATION OF EXP(-X)*X**A/GAMMA(A) -#----------------------------------------------------------------------- -# RT2PIN = 1/SQRT(2*PI) -#------------------------ - rt2pin = .398942280401433f0 -#------------------------ - if x == 0.0 return 0.0f0 end - if a < 20.0 # go to 20 +# rcomp(a,x) = exp(-x) * x^a / gamma(a) +rcomp(a,x) = rcomp(promote(a,x)...) +# NSWC RCOMP +function rcomp(a::Float32, x::Float32) + if x == 0.0 + return 0.0f0 + end + if a < 20f0 # go to 20 t = a*log(x) - x - if t < realminexp(Float32) return 0.0f0 end - if a < 1.0 # go to 10 + if t < realminexp(Float32) + return 0.0f0 + elseif a < 1f0 # go to 10 return (a*exp(t))*(1.0f0 + rgamma1pm1(a)) end return exp(t)/gamma(a) + else + u = x/a + if u == 0f0 + return 0f0 + end + t = (1f0/a)^2 + t1 = (((0.75f0*t - 1.0f0)*t + 3.5f0)*t - 105.0f0)/(a*1260.0f0) + t1 += a*logmxp1(u) + if t1 >= realminexp(Float32) + return r√2π*sqrt(a)*exp(t1) + end end - - u = x/a - if u == 0.0 return 0.0f0 end - t = (1.0f0/a)^2 - t1 = (((0.75f0*t - 1.0f0)*t + 3.5f0)*t - 105.0f0)/(a*1260.0f0) - t1 += a*logmxp1(u) - if t1 >= realminexp(Float32) return rt2pin*sqrt(a)*exp(t1) end end -function drcomp(a::Real, x::Real) -#----------------------------------------------------------------------- -# EVALUATION OF EXP(-X)*X**A/GAMMA(A) -#----------------------------------------------------------------------- -# DOUBLE PRECISION A, X, C, T, W -# DOUBLE PRECISION DGAMMA, DGAM1, DPDEL, DRLOG, DXPARG -#-------------------------- -# C = 1/SQRT(2*PI) -#-------------------------- - c = .398942280401432677939946059934 -#-------------------------- - if x == 0.0 return 0.0 end +# NSWC DRCOMP +function rcomp(a::Float64, x::Float64) + if x == 0.0 + return 0.0 + end if a <= 20.0 # go to 20 t = a*log(x) - x - if t < realminexp(Float64) return 0.0 end - if a < 1.0 # go to 10 + if t < realminexp(Float64) + return 0.0 + elseif a < 1.0 # go to 10 return (a*exp(t))*(1.0 + rgamma1pm1(a)) end return exp(t)/gamma(a) - end - - t = x/a - if t == 0.0 return 0.0 end - w = -(lstirling(a) - a*logmxp1(t)) - if w >= realminexp(Float64) - return c*sqrt(a)*exp(w) else - return 0.0 + t = x/a + if t == 0.0 + return 0.0 + end + w = a*logmxp1(t)-lstirling(a) + if w >= realminexp(Float64) + return r√2π*sqrt(a)*exp(w) + else + return 0.0 + end end end @@ -1209,8 +1210,8 @@ c5)*u + c4)*u + c3)*u + c2)*u + c1)*u + c0 end # The inverse incomplete Gamma ratio function -# Translated from NSWC -function dginv(a::Real, p::Real, q::Real) +# Translated from NSWC DGINV +function gaminv(a::Float64, p::Float64, q::Float64) #----------------------------------------------------------------------- # # DOUBLE PRECISION @@ -1312,7 +1313,7 @@ function dginv(a::Real, p::Real, q::Real) p0 = float32(p) q0 = float32(q) if p0 != 0.0 && q0 != 0.0 # go to 10 - x0, ier = gaminv(float32(a), 0.0f0, p0, q0) + x0, ier = gaminv(float32(a), p0, q0) if ier >= 0 || ier == -8 # go to 10 ierr = max(ier,0) if x0 <= 1.f34 # go to 10 @@ -1465,9 +1466,9 @@ function dginv(a::Real, p::Real, q::Real) while true if ierr >= 10 return x end # go to 530 ierr += 1 - pn, qn = dgrat(a, xn) + pn, qn = gratio(a, xn) if pn == 0.0 || qn == 0.0 return xn end# go to 550 - r = drcomp(a,xn) + r = rcomp(a,xn) if r < xmin return xn end # go to 550 t = (pn - p)/r w = 0.5*(am1 - xn) @@ -1498,9 +1499,9 @@ function dginv(a::Real, p::Real, q::Real) while true if ierr >= 10 return x end # go to 530 ierr += 1 - pn, qn = dgrat(a, xn) + pn, qn = gratio(a, xn) if pn == 0.0 || qn == 0.0 return xn end # go to 550 - r = drcomp(a,xn) + r = rcomp(a,xn) if r < xmin return xn end # go to 550 t = (q - qn)/r w = 0.5*(am1 - xn) @@ -1524,6 +1525,8 @@ function dginv(a::Real, p::Real, q::Real) end end +gaminv(a::Float32, p::Float32, q::Float32) = gaminv(a,0f0,p,q) + function gaminv(a::Float32, x0::Float32, p::Float32, q::Float32) #----------------------------------------------------------------------- # diff --git a/src/univariate/gamma.jl b/src/univariate/gamma.jl index 4c28962bd..e5be33cea 100644 --- a/src/univariate/gamma.jl +++ b/src/univariate/gamma.jl @@ -11,43 +11,46 @@ end Gamma(sh::Real) = Gamma(sh, 1.0) Gamma() = Gamma(1.0, 1.0) # Standard exponential distribution +insupport(::Gamma, x::Real) = zero(x) <= x < Inf +insupport(::Type{Gamma}, x::Real) = zero(x) <= x < Inf + scale(d::Gamma) = d.scale rate(d::Gamma) = 1.0 / d.scale -@_jl_dist_2p Gamma gamma +mean(d::Gamma) = d.shape * d.scale -function cdf(d::Gamma, x::Real) - if x < 0 return 0.0 end - return dgrat(d.shape, x/d.scale)[1] -end +mode(d::Gamma) = d.shape >= 1.0 ? d.scale * (d.shape - 1.0) : 0.0 +modes(d::Gamma) = [mode(d)] -quantile(d::Gamma, α::Real) = dginv(d.shape, α, 1-α)*d.scale +var(d::Gamma) = d.shape * d.scale * d.scale +skewness(d::Gamma) = 2.0 / sqrt(d.shape) +kurtosis(d::Gamma) = 6.0 / d.shape function entropy(d::Gamma) x = (1.0 - d.shape) * digamma(d.shape) x + lgamma(d.shape) + log(d.scale) + d.shape end -insupport(::Gamma, x::Real) = zero(x) <= x < Inf -insupport(::Type{Gamma}, x::Real) = zero(x) <= x < Inf -kurtosis(d::Gamma) = 6.0 / d.shape +function pdf(d::Gamma, x::Real) + if !insupport(d, x) + return 0.0 + elseif x == 0.0 + return d.shape > 1.0 ? 0.0 : d.shape == 1.0 ? 1/d.scale : Inf + end + rcomp(d.shape, x/d.scale)/x +end -mean(d::Gamma) = d.shape * d.scale -median(d::Gamma) = quantile(d, 0.5) +cdf(d::Gamma, x::Real) = x<0 ? 0.0 : gratio(d.shape, x/d.scale)[1] +ccdf(d::Gamma, x::Real) = x<0 ? 1.0 : gratio(d.shape, x/d.scale)[2] -mgf(d::Gamma, t::Real) = (1.0 - t * d.scale)^(-d.shape) +quantile(d::Gamma, α::Real) = gaminv(d.shape, α, 1-α)*d.scale +cquantile(d::Gamma, α::Real) = gaminv(d.shape, 1-α, α)*d.scale +mgf(d::Gamma, t::Real) = (1.0 - t * d.scale)^(-d.shape) cf(d::Gamma, t::Real) = (1.0 - im * t * d.scale)^(-d.shape) -function mode(d::Gamma) - d.shape >= 1.0 ? d.scale * (d.shape - 1.0) : error("Gamma has no mode when shape < 1.0") -end - -modes(d::Gamma) = [mode(d)] - -pdf(d::Gamma, x::Real) = insupport(d, x) ? drcomp(d.shape, x/d.scale)/x : 0.0 # rand() # @@ -99,9 +102,6 @@ function rand!(d::Gamma, A::Array{Float64}) multiply!(A, d.scale) end -skewness(d::Gamma) = 2.0 / sqrt(d.shape) - -var(d::Gamma) = d.shape * d.scale * d.scale ## Fit model diff --git a/src/univariate/poisson.jl b/src/univariate/poisson.jl index cc3987749..03859e75c 100644 --- a/src/univariate/poisson.jl +++ b/src/univariate/poisson.jl @@ -35,11 +35,6 @@ function entropy(d::Poisson) end -# Based on: -# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" -# available from: -# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf -# Uses slightly different forms instead of D0 function function pdf(d::Poisson, x::Real) if !insupport(d,x) return 0.0 @@ -47,11 +42,14 @@ function pdf(d::Poisson, x::Real) if x == 0 return exp(-d.lambda) end - # NSWC version: - drcomp(x, d.lambda)/x - # Loader's version: - # exp(x*logmxp1(d.lambda/x)-lstirling(x))/(√2π*sqrt(x)) + rcomp(x, d.lambda)/x end + +# Based on: +# Catherine Loader (2000) "Fast and accurate computation of binomial probabilities" +# available from: +# http://projects.scipy.org/scipy/raw-attachment/ticket/620/loader2000Fast.pdf +# Uses slightly different forms instead of D0 function function logpdf(d::Poisson, x::Real) if !insupport(d,x) return -Inf @@ -63,19 +61,8 @@ function logpdf(d::Poisson, x::Real) end -function cdf(d::Poisson, x::Real) - if x < 0 - return 0.0 - end - dgrat(floor(x)+1.0, d.lambda)[2] -end -function ccdf(d::Poisson, x::Real) - if x < 0 - return 1.0 - end - dgrat(floor(x)+1.0, d.lambda)[1] -end - +cdf(d::Poisson, x::Real) = x<0 ? 0.0 : gratio(floor(x)+1.0, d.lambda)[2] +ccdf(d::Poisson, x::Real) = x<0 ? 1.0 : gratio(floor(x)+1.0, d.lambda)[1] function mgf(d::Poisson, t::Real) From a46ba97adb134edf69908e27f86d6ad9bd6c244e Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Fri, 20 Sep 2013 17:57:48 +0100 Subject: [PATCH 11/19] chisq functions --- src/univariate/chisq.jl | 49 ++++++++++++++++++++++++----------------- 1 file changed, 29 insertions(+), 20 deletions(-) diff --git a/src/univariate/chisq.jl b/src/univariate/chisq.jl index 00d0bd75b..df7e79342 100644 --- a/src/univariate/chisq.jl +++ b/src/univariate/chisq.jl @@ -6,40 +6,52 @@ immutable Chisq <: ContinuousUnivariateDistribution end end -@_jl_dist_1p Chisq chisq - -function entropy(d::Chisq) - x = d.df / 2.0 + log(2.0) + lgamma(d.df / 2.0) - x + (1.0 - d.df / 2.0) * digamma(d.df / 2.0) -end - insupport(::Chisq, x::Real) = zero(x) <= x < Inf insupport(::Type{Chisq}, x::Real) = zero(x) <= x < Inf -kurtosis(d::Chisq) = 12.0 / d.df mean(d::Chisq) = d.df -# TODO: Switch to using quantile? -function median(d::Chisq) - k = d.df - k * (1.0 - 2.0 / (9.0 * k))^3 +mode(d::Chisq) = d.df > 2.0 ? d.df - 2.0 : 0.0 +modes(d::Chisq) = [mode(d)] + +var(d::Chisq) = 2.0 * d.df +skewness(d::Chisq) = sqrt(8.0 / d.df) +kurtosis(d::Chisq) = 12.0 / d.df + + +function entropy(d::Chisq) + x = d.df / 2.0 + log(2.0) + lgamma(0.5*d.df) + x + (1.0 - d.df / 2.0) * digamma(0.5*d.df) end + +pdf(d::Chisq, x::Real) = pdf(Gamma(0.5*d.df), x) +logpdf(d::Chisq, x::Real) = logpdf(Gamma(0.5*d.df), x) + +cdf(d::Chisq, x::Real) = cdf(Gamma(0.5*d.df), x) +ccdf(d::Chisq, x::Real) = ccdf(Gamma(0.5*d.df), x) +logcdf(d::Chisq, x::Real) = logcdf(Gamma(0.5*d.df), x) +logccdf(d::Chisq, x::Real) = logccdf(Gamma(0.5*d.df), x) + +quantile(d::Chisq, p::Real) = quantile(Gamma(0.5*d.df), p) +cquantile(d::Chisq, p::Real) = cquantile(Gamma(0.5*d.df), p) +invlogcdf(d::Chisq, lp::Real) = invlogcdf(Gamma(0.5*d.df), lp) +invlogccdf(d::Chisq, lp::Real) = invlogccdf(Gamma(0.5*d.df), lp) + + function mgf(d::Chisq, t::Real) k = d.df (1.0 - 2.0 * t)^(-k / 2.0) end -cf(d::Chisq, t::Real) = (1.0 - 2.0 * im * t)^(-d.df / 2.0) +cf(d::Chisq, t::Real) = (1.0 - 2.0 * im * t)^(-0.5*d.df) -mode(d::Chisq) = d.df > 2.0 ? d.df - 2.0 : 0.0 -modes(d::Chisq) = [mode(d)] # rand - the distribution chi^2(df) is 2 * gamma(df / 2) # for integer n, a chi^2(n) is the sum of n squared standard normals function rand(d::Chisq) - d.df == 1 ? randn()^2 : 2.0 * rand(Gamma(d.df / 2.0)) + d.df == 1 ? randn()^2 : 2.0 * rand(Gamma(0.5*d.df)) end function rand!(d::Chisq, A::Array{Float64}) @@ -50,7 +62,7 @@ function rand!(d::Chisq, A::Array{Float64}) return A end if d.df >= 2 - dpar = d.df / 2.0 - 1.0 / 3.0 + dpar = 0.5*d.df - 1.0 / 3.0 else error("require degrees of freedom df >= 2") end @@ -61,6 +73,3 @@ function rand!(d::Chisq, A::Array{Float64}) A end -skewness(d::Chisq) = sqrt(8.0 / d.df) - -var(d::Chisq) = 2.0 * d.df From b126c763355e397152d014f119e12c6c8539ac88 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Sat, 21 Sep 2013 10:41:06 +0100 Subject: [PATCH 12/19] fix chisq --- src/univariate/chisq.jl | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/univariate/chisq.jl b/src/univariate/chisq.jl index df7e79342..70d07509d 100644 --- a/src/univariate/chisq.jl +++ b/src/univariate/chisq.jl @@ -26,18 +26,18 @@ function entropy(d::Chisq) end -pdf(d::Chisq, x::Real) = pdf(Gamma(0.5*d.df), x) -logpdf(d::Chisq, x::Real) = logpdf(Gamma(0.5*d.df), x) +pdf(d::Chisq, x::Real) = pdf(Gamma(0.5*d.df,2.0), x) +logpdf(d::Chisq, x::Real) = logpdf(Gamma(0.5*d.df,2.0), x) -cdf(d::Chisq, x::Real) = cdf(Gamma(0.5*d.df), x) -ccdf(d::Chisq, x::Real) = ccdf(Gamma(0.5*d.df), x) -logcdf(d::Chisq, x::Real) = logcdf(Gamma(0.5*d.df), x) -logccdf(d::Chisq, x::Real) = logccdf(Gamma(0.5*d.df), x) +cdf(d::Chisq, x::Real) = cdf(Gamma(0.5*d.df,2.0), x) +ccdf(d::Chisq, x::Real) = ccdf(Gamma(0.5*d.df,2.0), x) +logcdf(d::Chisq, x::Real) = logcdf(Gamma(0.5*d.df,2.0), x) +logccdf(d::Chisq, x::Real) = logccdf(Gamma(0.5*d.df,2.0), x) -quantile(d::Chisq, p::Real) = quantile(Gamma(0.5*d.df), p) -cquantile(d::Chisq, p::Real) = cquantile(Gamma(0.5*d.df), p) -invlogcdf(d::Chisq, lp::Real) = invlogcdf(Gamma(0.5*d.df), lp) -invlogccdf(d::Chisq, lp::Real) = invlogccdf(Gamma(0.5*d.df), lp) +quantile(d::Chisq, p::Real) = quantile(Gamma(0.5*d.df,2.0), p) +cquantile(d::Chisq, p::Real) = cquantile(Gamma(0.5*d.df,2.0), p) +invlogcdf(d::Chisq, lp::Real) = invlogcdf(Gamma(0.5*d.df,2.0), lp) +invlogccdf(d::Chisq, lp::Real) = invlogccdf(Gamma(0.5*d.df,2.0), lp) function mgf(d::Chisq, t::Real) @@ -51,7 +51,7 @@ cf(d::Chisq, t::Real) = (1.0 - 2.0 * im * t)^(-0.5*d.df) # rand - the distribution chi^2(df) is 2 * gamma(df / 2) # for integer n, a chi^2(n) is the sum of n squared standard normals function rand(d::Chisq) - d.df == 1 ? randn()^2 : 2.0 * rand(Gamma(0.5*d.df)) + d.df == 1 ? randn()^2 : rand(Gamma(0.5*d.df,2.0)) end function rand!(d::Chisq, A::Array{Float64}) From 85043612b0b9297a07e3225d4ffa34990a503df4 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Mon, 23 Sep 2013 18:04:46 +0100 Subject: [PATCH 13/19] tdist, negbinom cdf and quantile --- src/constants.jl | 1 + src/univariate/beta.jl | 6 ++ src/univariate/hypergeometric.jl | 7 +- src/univariate/negativebinomial.jl | 17 ++++- src/univariate/tdist.jl | 107 +++++++++++++++++++++++++---- test/univariate.jl | 21 +++++- 6 files changed, 139 insertions(+), 20 deletions(-) diff --git a/src/constants.jl b/src/constants.jl index 85b997659..1e46abdd0 100644 --- a/src/constants.jl +++ b/src/constants.jl @@ -3,6 +3,7 @@ import Base.@math_const @math_const twoπ 6.2831853071795864769 big(2.) * π +@math_const halfπ 1.5707963267948966192 big(0.5) * π @math_const √2 1.4142135623730950488 sqrt(big(2.)) @math_const log2π 1.8378770664093454836 log(big(2.)*π) @math_const √2π 2.5066282746310005024 sqrt(big(2.)*π) diff --git a/src/univariate/beta.jl b/src/univariate/beta.jl index d14bc9810..5ec9dffba 100644 --- a/src/univariate/beta.jl +++ b/src/univariate/beta.jl @@ -16,6 +16,12 @@ function cdf(d::Beta, x::Real) return bratio(d.alpha, d.beta, x) end +function ccdf(d::Beta, x::Real) + if x >= 1 return 0.0 end + if x <= 0 return 1.0 end + return bratio(d.beta, d.alpha, 1.0-x) +end + function entropy(d::Beta) o = lbeta(d.alpha, d.beta) o -= (d.alpha - 1.0) * digamma(d.alpha) diff --git a/src/univariate/hypergeometric.jl b/src/univariate/hypergeometric.jl index 38e228cea..772eb7477 100644 --- a/src/univariate/hypergeometric.jl +++ b/src/univariate/hypergeometric.jl @@ -11,16 +11,19 @@ immutable HyperGeometric <: DiscreteUnivariateDistribution end end -@_jl_dist_3p HyperGeometric hyper - function insupport(d::HyperGeometric, x::Number) isinteger(x) && zero(x) <= x <= d.n && (d.n - d.nf) <= x <= d.ns end + mean(d::HyperGeometric) = d.n * d.ns / (d.ns + d.nf) +mode(d::HyperGeometric) = floor((d.n+1)*(d.ns+1)/(d.ns+d.nf+2)) + function var(d::HyperGeometric) N = d.ns + d.nf p = d.ns / N d.n * p * (1.0 - p) * (N - d.n) / (N - 1.0) end + +@_jl_dist_3p HyperGeometric hyper diff --git a/src/univariate/negativebinomial.jl b/src/univariate/negativebinomial.jl index 3de89541b..e941c2f45 100644 --- a/src/univariate/negativebinomial.jl +++ b/src/univariate/negativebinomial.jl @@ -52,9 +52,6 @@ function kurtosis(d::NegativeBinomial) end -@_jl_dist_2p NegativeBinomial nbinom - - function pdf(d::NegativeBinomial, x::Real) if !insupport(d,x) return 0.0 @@ -82,6 +79,15 @@ function logpdf(d::NegativeBinomial, x::Real) x*logmxp1(n*p/x) + r*logmxp1(n*q/r) + 0.5*(log(r/(x*n))-log2π) end +function cdf(d::NegativeBinomial, x::Real) + if x <= 0 return 0.0 end + return bratio(d.r, floor(x)+1.0, d.prob) +end + +function ccdf(d::NegativeBinomial, x::Real) + if x <= 0 return 1.0 end + return bratio(floor(x)+1.0, d.r, 1.0-d.prob) +end @@ -94,3 +100,8 @@ function cf(d::NegativeBinomial, t::Real) r, p = d.r, d.prob return ((1.0 - p) * exp(im * t))^r / (1.0 - p * exp(im * t))^r end + +function rand(d::NegativeBinomial) + lambda = rand(Gamma(d.r, (1-d.prob)/d.prob)) + rand(Poisson(lambda)) +end \ No newline at end of file diff --git a/src/univariate/tdist.jl b/src/univariate/tdist.jl index 58f2af1c2..1ff716ae2 100644 --- a/src/univariate/tdist.jl +++ b/src/univariate/tdist.jl @@ -6,15 +6,6 @@ immutable TDist <: ContinuousUnivariateDistribution end end -@_jl_dist_1p TDist t - -function entropy(d::TDist) - hdf = 0.5*d.df - hdfph = hdf + 0.5 - hdfph*(digamma(hdfph) - digamma(hdf)) + - 0.5*log(d.df) + lbeta(hdf,0.5) -end - insupport(::TDist, x::Real) = isfinite(x) insupport(::Type{TDist}, x::Real) = isfinite(x) @@ -25,13 +16,103 @@ median(d::TDist) = 0.0 mode(d::TDist) = 0.0 modes(d::TDist) = [0.0] +var(d::TDist) = d.df > 2.0 ? d.df / (d.df - 2.0) : d.df > 1.0 ? Inf : NaN + +skewness(d::TDist) = d.df > 3.0 ? 3.0 : NaN +kurtosis(d::TDist) = d.df > 4.0 ? 6.0/(d.df-4.0) : NaN + +function entropy(d::TDist) + hdf = 0.5*d.df + hdfph = hdf + 0.5 + hdfph*(digamma(hdfph) - digamma(hdf)) + + 0.5*log(d.df) + lbeta(hdf,0.5) +end + +@_jl_dist_1p TDist t + function pdf(d::TDist, x::Real) 1.0 / (sqrt(d.df) * beta(0.5, 0.5 * d.df)) * (1.0 + x^2 / d.df)^(-0.5 * (d.df + 1.0)) end -function var(d::TDist) - d.df > 2.0 && return d.df / (d.df - 2.0) - d.df > 1.0 && return Inf - NaN +# TODO: R claims to do a normal approximation in the tails. +function cdf(d::TDist, x::Real) + u = x*x/d.df + v = 1.0/(1.0+u) + y = 0.5*bratio(0.5*d.df,0.5,v) + x <= 0.0 ? y : 1.0-y end +function ccdf(d::TDist, x::Real) + u = x*x/d.df + v = 1.0/(1.0+u) + y = 0.5*bratio(0.5*d.df,0.5,v) + x <= 0.0 ? 1.0-y : y +end + +# Based on: +# G.W. Hill (1970) +# Algorithm 396: Student's t-quantiles +# Communications of the ACM, 13 (10): 619-620 +# and subsequent remarks. +function quantile(d::TDist, p::Real) + if p <= 0.0 + return p == 0.0 ? -Inf : NaN + elseif p >= 1.0 + return p == 1.0 ? Inf : NaN + end + n = d.df + if n==1 + return quantile(Cauchy(),p) + elseif n==2 + return sqrt(2.0/(p*(2.0-p))-2.0) + elseif n < 1 + # throw error? + return NaN + end + + a = 1.0/(n-0.5) + b = 48.0 / a^2 + c = ((20700.0*a/b - 98.0)*a - 16.0)*a - 96.36 + dd = ((94.5/(b+c) - 3.0)/b+1.0)*sqrt(halfπ*a)*n + x = 2.0*dd*p # Hill (1970) gives 2-tail quantile, so need to double p + y = x^(2.0/n) + if y > 0.05 + a + x = Φinv(p) + y = x^2 + if n < 5 + c += 0.3*(n-4.5)*(x+0.6) + end + c = (((0.05*dd*x-5.0)*x-7.0)*x-2.0)*x+b+c + y = (((((0.4*y+6.3)*y+36.0)*y+94.5)/c-y-3.0)/b+1.0)*x + y = a*y^2 + y = expm1(y) # use special function (remark by Lozy, 1979) + else + y = ((1.0/(((n+6.0)/(n*y)-0.089*dd-0.822)*(n+2.0)*3.0)+0.5/(n+4.0))*y-1.0)*(n+1.0)/(n+2.0)+1.0/y + end + q = p < 0.5 ? -sqrt(n*y) : sqrt(n*y) + # Taylor iterations (remark by Hill, 1981) + # TODO: tune convergence criteria + # e.g. quantile(TDist(28),0.445) + for i = 1:20 + z = (p - cdf(d,q)) / pdf(d,q) + delta = (n+1.0)*q*z*z*0.5/(q*q+n) + z + q += delta + abs(delta) < 100*eps(q) && break + end + q +end + +# cquantile(d::TDist, p::Real) = -quantile(d,p) + +function rand(d::TDist) + z = randn() + u = rand(Chisq(d.df)) + return z/sqrt(u/d.df) +end + +function cf(d::TDist, t::Real) + u = sqrt(d.df*abs(t)) + hdf = 0.5*d.df + 2.0*besselk(hdf,u)*(0.5*u)^hdf/gamma(hdf) +end + diff --git a/test/univariate.jl b/test/univariate.jl index 618226863..56b1dc408 100644 --- a/test/univariate.jl +++ b/test/univariate.jl @@ -20,8 +20,7 @@ const lpp = log(pp) # Use a large, odd number of samples for testing all quantities n_samples = 5_000_001 -# Try out many parameterizations of any given distribution -for d in [Arcsine(), +distlist = [Arcsine(), Beta(2.0, 2.0), Beta(3.0, 4.0), Beta(17.0, 13.0), @@ -112,6 +111,24 @@ for d in [Arcsine(), Weibull(23.0), Weibull(230.0)] +# allows calling +# julia univariate.jl Normal +# julia univariate.jl Normal(1.2,2) +if length(ARGS) > 0 + newdistlist = {} + for arg in ARGS + a = eval(parse(arg)) + if isa(a, DataType) + append!(newdistlist, filter(x -> isa(x,a),distlist)) + elseif isa(a,Distribution) + push!(newdistlist, a) + end + end + distlist = newdistlist +end + +# Try out many parameterizations of any given distribution +for d in distlist # NB: Uncomment if test fails # Mention distribution being run # println(d) From 51e268e3d6ef543eefc0bf6df70e1175318ae82a Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Mon, 23 Sep 2013 18:27:27 +0100 Subject: [PATCH 14/19] remove tdist rmath --- src/univariate/tdist.jl | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/univariate/tdist.jl b/src/univariate/tdist.jl index 1ff716ae2..8e5a02a27 100644 --- a/src/univariate/tdist.jl +++ b/src/univariate/tdist.jl @@ -28,8 +28,6 @@ function entropy(d::TDist) 0.5*log(d.df) + lbeta(hdf,0.5) end -@_jl_dist_1p TDist t - function pdf(d::TDist, x::Real) 1.0 / (sqrt(d.df) * beta(0.5, 0.5 * d.df)) * (1.0 + x^2 / d.df)^(-0.5 * (d.df + 1.0)) @@ -102,7 +100,7 @@ function quantile(d::TDist, p::Real) q end -# cquantile(d::TDist, p::Real) = -quantile(d,p) +cquantile(d::TDist, p::Real) = -quantile(d,p) function rand(d::TDist) z = randn() From 3c213741415d29362a475b0b74e4c1dff3a7c562 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Tue, 24 Sep 2013 12:34:31 +0100 Subject: [PATCH 15/19] tweaks to specialfuns, logcdf etc for cauchy --- src/constants.jl | 1 + src/specialfuns/gammabeta.jl | 149 +++++++++++++++++++---------------- src/univariate/cauchy.jl | 7 ++ 3 files changed, 87 insertions(+), 70 deletions(-) diff --git a/src/constants.jl b/src/constants.jl index 1e46abdd0..e973aa58e 100644 --- a/src/constants.jl +++ b/src/constants.jl @@ -6,5 +6,6 @@ import Base.@math_const @math_const halfπ 1.5707963267948966192 big(0.5) * π @math_const √2 1.4142135623730950488 sqrt(big(2.)) @math_const log2π 1.8378770664093454836 log(big(2.)*π) +@math_const hlog2π 0.9189385332046727418 0.5*log(big(2.)*π) @math_const √2π 2.5066282746310005024 sqrt(big(2.)*π) @math_const r√2π 0.3989422804014326779 1/sqrt(big(2.)*π) \ No newline at end of file diff --git a/src/specialfuns/gammabeta.jl b/src/specialfuns/gammabeta.jl index dbe4d5ab4..0915c3a08 100644 --- a/src/specialfuns/gammabeta.jl +++ b/src/specialfuns/gammabeta.jl @@ -2125,7 +2125,7 @@ function bpser(a::Real, b::Real, x::Real, precision::Real) #----------------------------------------------------------------------- a0 = min(a,b) if (a0 >= 1.0) # go to 10 - z = a*log(x) - dbetln(a,b) + z = a*log(x) - lbeta(a,b) bpserval = exp(z)/a # go to 70 else @@ -2174,7 +2174,7 @@ function bpser(a::Real, b::Real, x::Real, precision::Real) # PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 - u = lgamma1p(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + lgammadiv(a0,b0) z = a*log(x) - u bpserval = (a0/a)*exp(z) end @@ -2356,7 +2356,7 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) z = a*lnx + b*lny if (a0 >= 1.0) # go to 30 - z -= dbetln(a,b) + z -= lbeta(a,b) return exp(z) end @@ -2410,7 +2410,7 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) else # ALGORITHM FOR B0 .GE. 8 - u = lgamma1p(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + lgammadiv(a0,b0) return a0*exp(z - u) end end @@ -2442,7 +2442,7 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) v = e - log(y/y0) end z = exp(-(a*u + b*v)) - return cnst*sqrt(b*x0)*z*exp(-dbcorr(a,b)) + return cnst*sqrt(b*x0)*z*exp(-bcorr(a,b)) end function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) @@ -2474,7 +2474,7 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) z = a*lnx + b*lny if (a0 >= 1.0) # go to 30 - z -= dbetln(a,b) + z -= lbeta(a,b) return desum(mu, z) end @@ -2529,7 +2529,7 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) # ALGORITHM FOR B0 .GE. 8 - u = lgamma1p(a0) + dlgdiv(a0,b0) + u = lgamma1p(a0) + lgammadiv(a0,b0) return a0*exp(mu + z - u) end end @@ -2561,7 +2561,7 @@ function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) v = e - log(y/y0) end z = exp(mu - (a*u + b*v)) - return cnst*sqrt(b*x0)*z*exp(-dbcorr(a,b)) + return cnst*sqrt(b*x0)*z*exp(-bcorr(a,b)) end function bgrat(a::Real, b::Real, x::Real, y::Real, w::Real, precision::Real) @@ -2593,7 +2593,7 @@ function bgrat(a::Real, b::Real, x::Real, y::Real, w::Real, precision::Real) r = b*(1.0 + rgamma1pm1(b))*z^b r *= exp(a*lnx)*exp(0.5*bm1*lnx) - u = dlgdiv(b,a) + b*log(nu) + u = lgammadiv(b,a) + b*log(nu) u = r*exp(-u) if (u == 0.0) return w end # How should errors be handled? They are ognored in the original progam. ("Cannot calculate expansion") p,q = grat1(b,z,r,precision) @@ -2820,15 +2820,15 @@ function basym(a::Real, b::Real, lambda::Real, precision::Real) if ((abs(t0) + abs(t1)) <= precision*sumval) break end end - u = exp(-dbcorr(a,b)) + u = exp(-bcorr(a,b)) return e0*t*u*sumval end - -function dbcorr(a0::Real, b0::Real) +bcorr(a0,b0) = bcorr(promote(float(a0),float(b0))...) +function bcorr(a0::Float64, b0::Float64) #----------------------------------------------------------------------- # -# EVALUATION OF DEL(A) + DEL(B0) - DEL(A) + B0) WHERE +# EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE # LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). # IT IS ASSUMED THAT A0 .GE. 10 AND B0 .GE. 10. # @@ -2888,15 +2888,28 @@ function dbcorr(a0::Real, b0::Real) # COMPUTE DEL(A) + W # t = (10.0/a)^2 - z = e[15] - for j = 1:14 - k = 15 - j - z = t*z + e[k] - end + z = @horner(t, + .833333333333333333333333333333e-01, + -.277777777777777777777777752282e-04, + .793650793650793650791732130419e-07, + -.595238095238095232389839236182e-09, + .841750841750832853294451671990e-11, + -.191752691751854612334149171243e-12, + .641025640510325475730918472625e-14, + -.295506514125338232839867823991e-15, + .179643716359402238723287696452e-16, + -.139228964661627791231203060395e-17, + .133802855014020915603275339093e-18, + -.154246009867966094273710216533e-19, + .197701992980957427278370133333e-20, + -.234065664793997056856992426667e-21, + .171348014966398575409015466667e-22) return z/a + w end -function dlgdiv(a::Real, b::Real) +# NSWC DLGDIV +lgammadiv(a, b) = lgammadiv(promote(float(a),float(b))...) +function lgammadiv(a::Float64, b::Float64) #----------------------------------------------------------------------- # # COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) FOR B .GE. 10 @@ -2972,8 +2985,8 @@ function dlgdiv(a::Real, b::Real) return (w - u) - v end - -function dbetln(a0::Real, b0::Real) +# override lbeta in Base +function lbeta(a0::Real, b0::Real) #----------------------------------------------------------------------- # EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION #----------------------------------------------------------------------- @@ -2981,12 +2994,8 @@ function dbetln(a0::Real, b0::Real) # DOUBLE PRECISION A, B, C, E, H, SN, U, V, W, Z # DOUBLE PRECISION DBCORR, DGAMLN, DGSMLN, DLGDIV, DLNREL #-------------------------- -# E = 0.5*LN(2*PI) -#-------------------------- - e = .9189385332046727417803297364056 -#-------------------------- - a = min(a0,b0) - b = max(a0,b0) + a = float(min(a0,b0)) + b = float(max(a0,b0)) if a < 10.0 # go to 60 if a < 1.0 # go to 20 #----------------------------------------------------------------------- @@ -2995,75 +3004,75 @@ function dbetln(a0::Real, b0::Real) if b < 10.0 # go to 10 return lgamma(a) + (lgamma(b) - lgamma(a + b)) else - return lgamma(a) + dlgdiv(a,b) + return lgamma(a) + lgammadiv(a,b) end end #----------------------------------------------------------------------- # PROCEDURE WHEN 1 .LE. A .LT. 10 #----------------------------------------------------------------------- - while true - if a <= 2.0 # go to 30 - if b <= 2.0 # go to 21 - return lgamma(a) + lgamma(b) - dgsmln(a,b) - end - w = 0.0 - if b < 10.0 break end # go to 40 - return lgamma(a) + dlgdiv(a,b) + + if a <= 2.0 # go to 30 + if b <= 2.0 # go to 21 + return lgamma(a) + lgamma(b) - lgammasum(a,b) + elseif b >= 10.0 + return lgamma(a) + lgammadiv(a,b) end -# -# REDUCTION OF A WHEN B .LE. 1000 -# - if b > 1.0e3 # go to 50 + + w = zero(a) + elseif b > 1.0e3 # go to 50 # # REDUCTION OF A WHEN B .GT. 1000 # - n = itrunc(a - 1.0) - w = 1.0 - for i = 1:n - a -= 1.0 - w *= a/(1.0 + a/b) - end - sn = n - return (log(w) - sn*log(b)) + (lgamma(a) + dlgdiv(a,b)) + n = itrunc(a - one(a)) + w = one(a) + for i = 1:n + a -= one(a) + w *= a/(one(a) + a/b) end - - n = itrunc(a - 1.0) - w = 1.0 + sn = n + return (log(w) - sn*log(b)) + (lgamma(a) + lgammadiv(a,b)) + else + n = itrunc(a - one(a)) + w = one(a) for i = 1:n - a -= 1.0 + a -= one(a) h = a/b - w *= h/(1.0 + h) + w *= h/(one(h) + h) end w = log(w) - if b < 10.0 break end # go to 40 - return w + lgamma(a) + dlgdiv(a,b) + if b >= 10.0 + return w + lgamma(a) + lgammadiv(a,b) + end end # # REDUCTION OF B WHEN B .LT. 10 # - n = b - 1.0 - z = 1.0 + n = b - one(b) + z = one(b) for i = 1:n - b -= 1.0 + b -= one(b) z *= b/(a + b) end - return w + log(z) + (lgamma(a) + (lgamma(b) - dgsmln(a,b))) + return w + log(z) + (lgamma(a) + (lgamma(b) - lgammasum(a,b))) end #----------------------------------------------------------------------- # PROCEDURE WHEN A .GE. 10 #----------------------------------------------------------------------- - w = dbcorr(a,b) + w = bcorr(a,b) h = a/b - c = h/(1.0 + h) - u = -(a - 0.50)*log(c) + c = h/(one(h) + h) + u = -(a - oftype(a,0.50))*log(c) v = b*log1p(h) if u > v # go to 61 - return (((-0.5*log(b) + e) + w) - v) - u + return ((oftype(a,0.50)*(log2π-log(b)) + w) - v) - u end - return (((-0.5*log(b) + e) + w) - u) - v + return ((oftype(a,0.50)*(log2π-log(b)) + w) - u) - v end -function dgsmln(a::Real, b::Real) + + +# NSWC GSUMLN / DGSMLN +function lgammasum(a::Real, b::Real) #----------------------------------------------------------------------- # EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) # FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 @@ -3071,14 +3080,14 @@ function dgsmln(a::Real, b::Real) # DOUBLE PRECISION A, B, X # DOUBLE PRECISION DGMLN1, DLNREL - x = (a - 1.0) + (b - 1.0) + x = (a - one(a)) + (b - one(b)) if x <= 0.50 # go to 10 - return lgamma1p(1.0 + x) + return lgamma1p(one(x) + x) end if x < 1.50 # go to 20 return lgamma1p(x) + log1p(x) end - return lgamma1p(x - 1.0) + log(x*(1.0 + x)) + return lgamma1p(x - one(x)) + log(x*(one(x) + x)) end function desum(mu::Integer, x::Real) @@ -3203,9 +3212,9 @@ function rgamma1pm1(a::Float32) t = a d = a - 0.5f0 if d > 0.0f0 t = d - 0.5f0 end - if t == 0 # 30,10,20 + if t == 0f0 # 30,10,20 return 0.0f0 - elseif t < 0 + elseif t < 0f0 top = @horner(t, .577215664901533f+00, -.409078193005776f+00, -.230975380857675f+00, diff --git a/src/univariate/cauchy.jl b/src/univariate/cauchy.jl index 688f10ceb..6d699b919 100644 --- a/src/univariate/cauchy.jl +++ b/src/univariate/cauchy.jl @@ -30,9 +30,16 @@ logpdf(d::Cauchy, x::Real) = -log(pi) - log(d.scale) - log1p(((x-d.location)/d.s cdf(d::Cauchy, x::Real) = atan2(one(x),-(x-d.location)/d.scale)/pi ccdf(d::Cauchy, x::Real) = atan2(one(x),(x-d.location)/d.scale)/pi +logcdf(d::Cauchy, x::Real) = x <= d.location ? log(cdf(d,x)) : log1p(-ccdf(d,x)) +logccdf(d::Cauchy, x::Real) = x <= d.location ? log1p(-cdf(d,x)) : log(ccdf(d,x)) + quantile(d::Cauchy, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.location - d.scale*cospi(p)/sinpi(p) cquantile(d::Cauchy, p::Real) = (p < zero(p) || p > one(p)) ? NaN : d.location + d.scale*cospi(p)/sinpi(p) +invlogcdf(d::Cauchy, lp::Real) = lp < -0.6931471805599453 ? quantile(d,exp(lp)) : cquantile(d,-expm1(lp)) +invlogccdf(d::Cauchy, lp::Real) = lp < -0.6931471805599453 ? cquantile(d,exp(lp)) : quantile(d,-expm1(lp)) + + rand(d::Cauchy) = quantile(d,rand()) mgf(d::Cauchy, t::Real) = NaN From 35458b4d7730c6a276a6040ca4b7468cf57d0ebd Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Tue, 24 Sep 2013 14:35:42 +0100 Subject: [PATCH 16/19] F distribution, use brcomp for binomial --- src/specialfuns/gammabeta.jl | 5 +-- src/univariate/beta.jl | 75 +++++++++++++++++++----------------- src/univariate/binomial.jl | 5 ++- src/univariate/fdist.jl | 41 +++++++++++++++++++- test/discrete.jl | 21 ++++++++-- test/univariate.jl | 8 ++-- test/univariate_stats.jl | 22 +++++++++-- 7 files changed, 125 insertions(+), 52 deletions(-) diff --git a/src/specialfuns/gammabeta.jl b/src/specialfuns/gammabeta.jl index 0915c3a08..774f24584 100644 --- a/src/specialfuns/gammabeta.jl +++ b/src/specialfuns/gammabeta.jl @@ -2334,9 +2334,6 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) #----------------------------------------------------------------------- # REAL LAMBDA, LNX, LNY #----------------- -# CONST = 1/SQRT(2*PI) -#----------------- - cnst = .398942280401433 brcompval = 0.0 if (x == 0.0 || y == 0.0) return brcompval end @@ -2442,7 +2439,7 @@ function brcomp(a::Real, b::Real, x::Real, y::Real) v = e - log(y/y0) end z = exp(-(a*u + b*v)) - return cnst*sqrt(b*x0)*z*exp(-bcorr(a,b)) + return r√2π*sqrt(b*x0)*z*exp(-bcorr(a,b)) end function brcmp1(mu::Integer, a::Real, b::Real, x::Real, y::Real) diff --git a/src/univariate/beta.jl b/src/univariate/beta.jl index 5ec9dffba..1a2605e30 100644 --- a/src/univariate/beta.jl +++ b/src/univariate/beta.jl @@ -10,16 +10,38 @@ end Beta(a::Real) = Beta(a, a) # symmetric in [0, 1] Beta() = Beta(1.0) # uniform -function cdf(d::Beta, x::Real) - if x >= 1 return 1.0 end - if x <= 0 return 0.0 end - return bratio(d.alpha, d.beta, x) + +insupport(::Beta, x::Real) = zero(x) < x < one(x) +insupport(::Type{Beta}, x::Real) = zero(x) < x < one(x) + + +mean(d::Beta) = d.alpha / (d.alpha + d.beta) + +median(d::Beta) = quantile(d, 0.5) + +function mode(d::Beta) + α, β = d.alpha, d.beta + α > 1.0 && β > 1.0 || error("Beta with α <= 1 or β <= 1 has no modes") + (α - 1.0) / (α + β - 2.0) end -function ccdf(d::Beta, x::Real) - if x >= 1 return 0.0 end - if x <= 0 return 1.0 end - return bratio(d.beta, d.alpha, 1.0-x) +modes(d::Beta) = [mode(d)] + +function var(d::Beta) + ab = d.alpha + d.beta + d.alpha * d.beta / (ab * ab * (ab + 1.0)) +end + +function skewness(d::Beta) + num = 2.0 * (d.beta - d.alpha) * sqrt(d.alpha + d.beta + 1.0) + den = (d.alpha + d.beta + 2.0) * sqrt(d.alpha * d.beta) + num / den +end +function kurtosis(d::Beta) + α, β = d.alpha, d.beta + num = 6.0 * ((α - β)^2 * (α + β + 1.0) - α * β * (α + β + 2.0)) + den = α * β * (α + β + 2.0) * (α + β + 3.0) + num / den end function entropy(d::Beta) @@ -30,29 +52,23 @@ function entropy(d::Beta) o end -insupport(::Beta, x::Real) = zero(x) < x < one(x) -insupport(::Type{Beta}, x::Real) = zero(x) < x < one(x) -function kurtosis(d::Beta) - α, β = d.alpha, d.beta - num = 6.0 * ((α - β)^2 * (α + β + 1.0) - α * β * (α + β + 2.0)) - den = α * β * (α + β + 2.0) * (α + β + 3.0) - num / den -end +pdf(d::Beta, x::Real) = insupport(d, x) ? brcomp(d.alpha, d.beta, x, 1.0 - x)/(x*(1.0 - x)) : 0.0 -mean(d::Beta) = d.alpha / (d.alpha + d.beta) -median(d::Beta) = quantile(d, 0.5) +function cdf(d::Beta, x::Real) + if x >= 1 return 1.0 end + if x <= 0 return 0.0 end + return bratio(d.alpha, d.beta, x) +end -function mode(d::Beta) - α, β = d.alpha, d.beta - α > 1.0 && β > 1.0 || error("Beta with α <= 1 or β <= 1 has no modes") - (α - 1.0) / (α + β - 2.0) +function ccdf(d::Beta, x::Real) + if x >= 1 return 0.0 end + if x <= 0 return 1.0 end + return bratio(d.beta, d.alpha, 1.0-x) end -modes(d::Beta) = [mode(d)] -pdf(d::Beta, x::Real) = insupport(d, x) ? brcomp(d.alpha, d.beta, x, 1.0 - x)/(x*(1.0 - x)) : 0.0 function rand(d::Beta) u = rand(Gamma(d.alpha)) @@ -72,17 +88,6 @@ function rand!(d::Beta, A::Array{Float64}) A end -function skewness(d::Beta) - num = 2.0 * (d.beta - d.alpha) * sqrt(d.alpha + d.beta + 1.0) - den = (d.alpha + d.beta + 2.0) * sqrt(d.alpha * d.beta) - num / den -end - -function var(d::Beta) - ab = d.alpha + d.beta - d.alpha * d.beta / (ab * ab * (ab + 1.0)) -end - ## Fit model # TODO: add MLE method (should be similar to Dirichlet) diff --git a/src/univariate/binomial.jl b/src/univariate/binomial.jl index 1f59aaa2a..0f42ff2b9 100644 --- a/src/univariate/binomial.jl +++ b/src/univariate/binomial.jl @@ -65,8 +65,7 @@ function pdf(d::Binomial, x::Real) end q = 1.0-p y = n-x - sqrt(n/(2.0*pi*x*y))*exp((lstirling(n) - lstirling(x) - lstirling(y)) - + x*logmxp1(n*p/x) + y*logmxp1(n*q/y)) + brcomp(x,y,p,q)*n/(x*y) end function logpdf(d::Binomial, x::Real) @@ -81,6 +80,8 @@ function logpdf(d::Binomial, x::Real) elseif y ==0 return n*log(p) end + # TODO: replace lstirling with bcorr + # need to figure out what to do when x,y < 10 (lstirling(n) - lstirling(x) - lstirling(y)) + x*logmxp1(n*p/x) + y*logmxp1(n*q/y) + 0.5*(log(n/(x*y))-log2π) end diff --git a/src/univariate/fdist.jl b/src/univariate/fdist.jl index ce59dd94c..77bd7c4e3 100644 --- a/src/univariate/fdist.jl +++ b/src/univariate/fdist.jl @@ -8,8 +8,6 @@ immutable FDist <: ContinuousUnivariateDistribution end end -@_jl_dist_2p FDist f - insupport(::FDist, x::Real) = zero(x) <= x < Inf insupport(::Type{FDist}, x::Real) = zero(x) <= x < Inf @@ -40,3 +38,42 @@ entropy(d::FDist) = (log(d.ddf) -log(d.ndf) +lgamma(0.5*d.ndf) +lgamma(0.5*d.ddf) -lgamma(0.5*(d.ndf+d.ddf)) +(1.0-0.5*d.ndf)*digamma(0.5*d.ndf) +(-1.0-0.5*d.ddf)*digamma(0.5*d.ddf) +0.5*(d.ndf+d.ddf)*digamma(0.5*(d.ndf+d.ddf))) + + +function pdf(d::FDist,x::Real) + if !insupport(d,x) + return 0.0 + end + a = 0.5*d.ndf + b = 0.5*d.ddf + u = d.ndf*x + v = d.ddf + w = u+v + brcomp(a,b,u/w,v/w)/x +end + +function cdf(d::FDist, x::Real) + if !insupport(d,x) + return 0.0 + end + u = x*d.ndf/d.ddf + y = u/(one(u)+u) + cdf(Beta(0.5*d.ndf,0.5*d.ddf),y) +end +function ccdf(d::FDist, x::Real) + if !insupport(d,x) + return 0.0 + end + u = x*d.ndf/d.ddf + y = u/(one(u)+u) + ccdf(Beta(0.5*d.ndf,0.5*d.ddf),y) +end + +function quantile(d::FDist, p::Real) + y = quantile(Beta(0.5*d.ndf,0.5*d.ddf),p) + (d.ddf*y)/(d.ndf*(one(y)-y)) +end + + +rand(d::FDist) = (d.ddf*rand(Chisq(d.ndf)))/(d.ndf*rand(Chisq(d.ddf))) + diff --git a/test/discrete.jl b/test/discrete.jl index b162637f8..f3bd3a471 100644 --- a/test/discrete.jl +++ b/test/discrete.jl @@ -13,8 +13,7 @@ import NumericExtensions using Distributions using Base.Test - -for d in [ +distlist = [ Bernoulli(0.1), Bernoulli(0.5), Bernoulli(0.9), @@ -29,7 +28,23 @@ for d in [ Binomial(100, 0.9), Binomial(10000, 0.03)] - # println(d) +if length(ARGS) > 0 + newdistlist = {} + for arg in ARGS + a = eval(parse(arg)) + if isa(a, DataType) + append!(newdistlist, filter(x -> isa(x,a),distlist)) + elseif isa(a,Distribution) + push!(newdistlist, a) + end + end + distlist = newdistlist +end + +for d in distlist + if length(ARGS) > 0 + println(d) + end xmin = min(d) xmax = max(d) diff --git a/test/univariate.jl b/test/univariate.jl index 56b1dc408..af5a52359 100644 --- a/test/univariate.jl +++ b/test/univariate.jl @@ -124,15 +124,17 @@ if length(ARGS) > 0 push!(newdistlist, a) end end - distlist = newdistlist + distlist = newdistlist end # Try out many parameterizations of any given distribution for d in distlist # NB: Uncomment if test fails # Mention distribution being run - # println(d) - + if length(ARGS) > 0 + println(d) + end + n = length(pp) is_continuous = isa(d, Truncated) ? isa(d.untruncated, ContinuousDistribution) : isa(d, ContinuousDistribution) is_discrete = isa(d, Truncated) ? isa(d.untruncated, DiscreteDistribution) : isa(d, DiscreteDistribution) diff --git a/test/univariate_stats.jl b/test/univariate_stats.jl index 96a0d6671..ed53774c0 100644 --- a/test/univariate_stats.jl +++ b/test/univariate_stats.jl @@ -28,9 +28,7 @@ macro ignore_methoderror(ex) end end end - - -for d in [ +distlist = [ Arcsine(), Bernoulli(0.1), Bernoulli(0.5), @@ -135,6 +133,24 @@ for d in [ Weibull(230.0), ] +# allows calling +# julia univariate.jl Normal +# julia univariate.jl Normal(1.2,2) +if length(ARGS) > 0 + newdistlist = {} + for arg in ARGS + a = eval(parse(arg)) + if isa(a, DataType) + append!(newdistlist, filter(x -> isa(x,a),distlist)) + elseif isa(a,Distribution) + push!(newdistlist, a) + end + end + distlist = newdistlist +end + +for d in distlist + x = rand(d, n_samples) From 181bc74d1d8067f8119fce6f8dffec42e7985882 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Tue, 24 Sep 2013 15:53:00 +0100 Subject: [PATCH 17/19] support for hypergeometric --- src/univariate/hypergeometric.jl | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src/univariate/hypergeometric.jl b/src/univariate/hypergeometric.jl index 772eb7477..1812c83df 100644 --- a/src/univariate/hypergeometric.jl +++ b/src/univariate/hypergeometric.jl @@ -11,9 +11,16 @@ immutable HyperGeometric <: DiscreteUnivariateDistribution end end -function insupport(d::HyperGeometric, x::Number) - isinteger(x) && zero(x) <= x <= d.n && (d.n - d.nf) <= x <= d.ns -end +isupperbounded(d::Union(HyperGeometric, Type{HyperGeometric})) = true +islowerbounded(d::Union(HyperGeometric, Type{HyperGeometric})) = true +isbounded(d::Union(HyperGeometric, Type{HyperGeometric})) = true + +min(d::HyperGeometric) = max(0,d.n-d.nf) +max(d::HyperGeometric) = min(d.n,d.ns) +support(d::HyperGeometric) = min(d):max(d) + +insupport(d::HyperGeometric, x::Real) = isinteger(x) && zero(x) <= x <= d.n && (d.n - d.nf) <= x <= d.ns + mean(d::HyperGeometric) = d.n * d.ns / (d.ns + d.nf) @@ -22,8 +29,9 @@ mode(d::HyperGeometric) = floor((d.n+1)*(d.ns+1)/(d.ns+d.nf+2)) function var(d::HyperGeometric) N = d.ns + d.nf - p = d.ns / N - d.n * p * (1.0 - p) * (N - d.n) / (N - 1.0) + d.n * (d.ns / N) * (d.nf / N) * ((N - d.n) / (N - 1.0)) end @_jl_dist_3p HyperGeometric hyper + + From 1d4882357d3a032b80450408866cb7fd5154d635 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Tue, 24 Sep 2013 17:12:11 +0100 Subject: [PATCH 18/19] hypergeometric methods --- src/univariate/hypergeometric.jl | 66 +++++++++++++++++++++++++++++--- test/discrete.jl | 9 +++-- 2 files changed, 67 insertions(+), 8 deletions(-) diff --git a/src/univariate/hypergeometric.jl b/src/univariate/hypergeometric.jl index 1812c83df..33bdad42e 100644 --- a/src/univariate/hypergeometric.jl +++ b/src/univariate/hypergeometric.jl @@ -1,13 +1,13 @@ immutable HyperGeometric <: DiscreteUnivariateDistribution - ns::Float64 # number of successes in population - nf::Float64 # number of failures in population - n::Float64 # sample size + ns::Int # number of successes in population + nf::Int # number of failures in population + n::Int # sample size function HyperGeometric(s::Real, f::Real, n::Real) isinteger(s) && zero(s) <= s || error("ns must be a non-negative integer") isinteger(f) && zero(f) <= f || error("nf must be a non-negative integer") isinteger(n) && zero(n) < n < s + f || error("n must be a positive integer <= (ns + nf)") - new(float64(s), float64(f), float64(n)) + new(int(s), int(f), int(n)) end end @@ -32,6 +32,62 @@ function var(d::HyperGeometric) d.n * (d.ns / N) * (d.nf / N) * ((N - d.n) / (N - 1.0)) end -@_jl_dist_3p HyperGeometric hyper +function skewness(d::HyperGeometric) + N = d.ns + d.nf + (d.nf-d.ns)*((N-2d.n)/(N-2))*sqrt((N-1)/(d.n*d.ns*d.nf*(N-d.n))) +end + +function kurtosis(d::HyperGeometric) + N = d.ns + d.nf + ((N-1)*N^2*(N*(N+1)-6*d.ns*d.nf-6*d.n*(N-d.n))+6d.n*d.ns*d.nf*(N-d.n)*(5N-6))/ + (d.n*d.ns*d.nf*(N-d.n)*(N-2)*(N-3)) +end + +function entropy(d::HyperGeometric) + e = 0.0 + for x = support(d) + p = pdf(d,x) + e -= log(p)*p + end + e +end + +function pdf(d::HyperGeometric, x::Real) + N = d.ns + d.nf + p = d.ns / N + pdf(Binomial(d.ns,p),x) * pdf(Binomial(d.nf,p),d.n-x) / pdf(Binomial(N,p),d.n) +end + +function cdf(d::HyperGeometric, x::Real) + if x < min(d) + return 0.0 + elseif x >= max(d) + return 1.0 + end + p = 0.0 + for i = min(d):floor(x) + p += pdf(d,i) + end + p +end + +function quantile(d::HyperGeometric, p::Real) + if p < 0 || p > 1 return NaN end + if p == 0 return min(d) end + if p == 1 return max(d) end + cp = 0.0 + for x = support(d) + cp += pdf(d,x) + if cp >= p + return x + end + end +end +# TODO: Implement: +# V. Kachitvichyanukul & B. Schmeiser +# "Computer generation of hypergeometric random variates" +# Journal of Statistical Computation and Simulation, 22(2):127-145 +# doi:10.1080/00949658508810839 +rand(d::HyperGeometric) = quantile(d,rand()) diff --git a/test/discrete.jl b/test/discrete.jl index f3bd3a471..cff3ea047 100644 --- a/test/discrete.jl +++ b/test/discrete.jl @@ -26,7 +26,10 @@ distlist = [ Binomial(1, 0.5), Binomial(100, 0.1), Binomial(100, 0.9), - Binomial(10000, 0.03)] + Binomial(10000, 0.03), + HyperGeometric(10, 10, 3), + HyperGeometric(50, 80, 3), + HyperGeometric(50, 80, 60)] if length(ARGS) > 0 newdistlist = {} @@ -124,7 +127,7 @@ for d in distlist @test_approx_eq_eps exp(lc[i]) c[i] 1.0e-12 @test_approx_eq_eps exp(lcc[i]) cc[i] 1.0e-12 - if !isa(d, Binomial) + if !isa(d, Binomial) && p[i] > 1.1e-8 @test quantile(d, c[i] - 1.0e-8) == x[i] @test cquantile(d, cc[i] + 1.0e-8) == x[i] @test invlogcdf(d, lc[i] - 1.0e-8) == x[i] @@ -162,7 +165,7 @@ for d in distlist @test_approx_eq mean(d) xmean @test_approx_eq var(d) xvar @test_approx_eq std(d) xstd - @test_approx_eq skewness(d) xskew + @test_approx_eq_eps skewness(d) xskew max(1000eps(xskew),100eps()) @test_approx_eq kurtosis(d) xkurt @test_approx_eq entropy(d) xentropy From 91366c9aab6f6497b0d100eb41321eb4cb0668c5 Mon Sep 17 00:00:00 2001 From: Simon Byrne Date: Sun, 19 Jan 2014 17:30:29 +0000 Subject: [PATCH 19/19] missed rename --- test/univariate_stats.jl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/univariate_stats.jl b/test/univariate_stats.jl index 0fb7ca5bd..30f6dad7f 100644 --- a/test/univariate_stats.jl +++ b/test/univariate_stats.jl @@ -123,9 +123,9 @@ distlist = [ Skellam(10.0, 2.0), TDist(1), TDist(28), - Triangular(3.0, 1.0), - Triangular(3.0, 2.0), - Triangular(10.0, 10.0), + TriangularDist(3.0, 1.0), + TriangularDist(3.0, 2.0), + TriangularDist(10.0, 10.0), Truncated(Normal(0, 1), -3, 3), # Truncated(Normal(-100, 1), 0, 1), Truncated(Normal(27, 3), 0, Inf),