double dinvparalogis(double x, double shape, double scale, int give_log)
{
/* We work with the density expressed as
*
* shape^2 * u^shape * (1 - u) / x
*
* with u = v/(1 + v) = 1/(1 + 1/v), v = (x/scale)^shape.
*/
double tmp, logu, log1mu;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;;
if (!R_FINITE(x) || x < 0.0)
return ACT_D__0;
/* handle x == 0 separately */
if (x == 0)
{
if (shape < 1.0) return R_PosInf;
if (shape > 1.0) return ACT_D__0;
/* else */
return ACT_D_val(1.0 / scale);
}
tmp = shape * (log(x) - log(scale));
logu = - log1pexp(-tmp);
log1mu = - log1pexp(tmp);
return ACT_D_exp(2.0 * log(shape) + shape * logu + log1mu - log(x));
}
double levinvparalogis(double limit, double shape, double scale, double order,
int give_log)
{
double u, tmp1, tmp2, tmp3;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape * shape)
return R_PosInf;
tmp1 = order / shape;
tmp2 = shape + tmp1;
tmp3 = 1.0 - tmp1;
u = exp(-log1pexp(shape * (log(scale) - log(limit))));
return R_pow(scale, order) * gammafn(tmp2) * gammafn(tmp3)
* pbeta(u, tmp2, tmp3, 1, 0) / gammafn(shape)
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
double pinvparalogis(double q, double shape, double scale, int lower_tail,
int log_p)
{
double u;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;;
if (q <= 0)
return ACT_DT_0;
u = exp(-log1pexp(shape * (log(scale) - log(q))));
return ACT_DT_val(R_pow(u, shape));
}
double levinvpareto(double limit, double shape, double scale, double order,
int give_log)
{
double u;
double ex[3], lower, upper, epsabs, epsrel, result, abserr, *work;
int neval, ier, subdiv, lenw, last, *iwork;
if (!R_FINITE(shape) ||
!R_FINITE(scale) ||
!R_FINITE(order) ||
shape <= 0.0 ||
scale <= 0.0)
return R_NaN;
if (order <= -shape)
return R_PosInf;
if (limit <= 0.0)
return 0.0;
/* Parameters for the integral are pretty much fixed here */
ex[0] = shape; ex[1] = scale; ex[2] = order;
lower = 0.0; upper = limit / (limit + scale);
subdiv = 100;
epsabs = R_pow(DOUBLE_EPS, 0.25);
epsrel = epsabs;
lenw = 4 * subdiv; /* as instructed in WRE */
iwork = (int *) R_alloc(subdiv, sizeof(int)); /* idem */
work = (double *) R_alloc(lenw, sizeof(double)); /* idem */
Rdqags(fn, (void *) &ex,
&lower, &upper, &epsabs, &epsrel, &result,
&abserr, &neval, &ier, &subdiv, &lenw, &last, iwork, work);
if (ier == 0)
{
u = exp(-log1pexp(log(scale) - log(limit)));
return R_pow(scale, order) * shape * result
+ ACT_DLIM__0(limit, order) * (0.5 - R_pow(u, shape) + 0.5);
}
else
error(_("integration failed"));
}
double plogis(double x, double location, double scale,
int lower_tail, int log_p)
{
#ifdef IEEE_754
if (ISNAN(x) || ISNAN(location) || ISNAN(scale))
return x + location + scale;
#endif
if (scale <= 0.0) ML_ERR_return_NAN;
x = (x - location) / scale;
if (ISNAN(x)) ML_ERR_return_NAN;
R_P_bounds_Inf_01(x);
if(log_p) {
// log(1 / (1 + exp( +- x ))) = -log(1 + exp( +- x))
return -log1pexp(lower_tail ? -x : x);
} else {
return 1 / (1 + exp(lower_tail ? -x : x));
}
}
inline long double sum_log_prob(long double a, long double b) {
return a>b? a+log1pexp(b-a): b+log1pexp(a-b);
}
inline double sum_log_prob(double a, double b) {
return a>b? a+log1pexp(b-a): b+log1pexp(a-b);
}
inline float sum_log_prob(float a, float b) {
return a>b? a+log1pexp(b-a): b+log1pexp(a-b);
}
