double loghyperg1F1(double a, double b, double x, int laplace)
{
double y;
if (laplace == 0) {
if (x <0) {
/* Since Linux system tends to report error for negative x, we
use the following fomular to convert it to positive value
1F1(a, b, x) = 1F1(b - a, b, -x) * exp(x) */
y = log(hyperg(b-a, b, -x)) + x;
}
else {
y = log( hyperg(a, b, x));
}
}
else {
/* Laplace approximation assumes -x for x positive
if ( x <= 0.0 ){y = loghyperg1F1_laplace(a, b, -x); }
else { y = loghyperg1F1_laplace(b - a, b, x) + x;} */
y = loghyperg1F1_laplace(a, b, x);
}
// Rprintf("LOG Cephes 1F1(%lf, %lf, %lf) = %lf (%lf)\n", a,b,x,log(y), y);
// ly = hyperg1F1_laplace(a,b,x);
// Rprintf("called from hyperg1F1: LOG Pos 1F1(%lf, %lf, %lf) = %lf (%lf)\n", a,b,x,ly, exp(ly));
if (!R_FINITE(y) && laplace == 0) {
warning("Cephes 1F1 function returned NA, using Laplace approximation");
y = loghyperg1F1_laplace(a, b, x); // try Laplace approximation
}
return(y);
}
double loghyperg1F1_laplace(double a, double b, double x)
{
double mode,mode1, mode2, lprec, prec, logy;
/* int u^(a-1) (1-u)^(b-1) exp(-x u) du assuming that x >= 0 */
prec = 0.0;
logy = 0.0;
if ( x <= 0.0) {
if (x < 0.0) {
x = -x;
logy = -lgammafn(b) - lgammafn(a) + lgammafn(a+b);
// mode = (2.0 - 2.0* a + b - x - sqrt(pow(b, 2.0) - 2.0*b*x + x*(4.0*(a-1.0)+x)))/
// (2*(a - 1.0 - b));
mode1 = .5*(-a + b + x - sqrt( 4.*a*b + pow(a - b - x, 2.0)))/a;
mode1 = 1.0/(1.0 + mode1);
mode2 = .5*(-a + b + x + sqrt( 4.*a*b + pow(a - b -x, 2.0)))/a;
mode2 = 1.0/(1.0 + mode2);
if (a*log(mode1) + b*log(1.0 - mode1) - x*mode1 >
a*log(mode2) + b*log(1.0 - mode2) - x*mode2) mode = mode1;
else mode = mode2;
// Rprintf("mode 1 %lf, mode %lf\n", mode1, mode2);
if (mode < 0) {
mode = 0.0;
warning("1F1 Laplace approximation on boundary\n");
}
else{
/* prec = a*mode*(1.0 - mode) + (1.0-mode)*(1.0 - mode)*b +
x*pow(1.0-mode, 3.0) - x*mode*(1.0 -
mode)*(1.0-mode); */
prec = (1.0-mode)*((a + b - x)*pow(mode,2) + (1.0-mode)*mode*(a + b + x));
if (prec > 0) {
lprec = log(prec);
logy += a*log(mode) + b*log(1.0 - mode) - x*mode;
logy += -0.5*lprec + M_LN_SQRT_2PI;
}
else {prec = 0.0;}
}
// Rprintf("mode %lf prec %lf, Lap 1F1(%lf, %lf, %lf) = %lf\n", mode, prec, a,b,x, logy);
}
else {logy = 0.0;}
}
else {
logy = x + loghyperg1F1_laplace(b - a, a, -x);
}
return(logy);
}
double loghyperg1F1_laplace(double a, double b, double x)
{
double mode, lprec, prec, logy;
logy = lgamma(b) - lgamma(a) - lgamma(b-a);
if ( x >= 0.0)
{
if (x > 0.0) {
mode = (2.0 - 2.0* a + b - x - sqrt(pow(b, 2.0) - 2.0*b*x + x*(4.0*(a-1.0)+x)))/
(2*(a - 1.0 - b));
if (mode < 0) {
mode = 0.0;
Rprintf("1F1 Laplace approximation on boundary\n");
}
prec = -((1.0 - a)/pow(mode,2.0) + 2.0*x*mode/pow((1.0 + mode),3.0) +
(b - 2.0*x)/pow((1.0 + mode),2.0));
if (prec > 0) lprec = log(prec);
else prec = 0.0;
logy += (a - 1.0)*log(mode) - b*log(1.0 + mode) + x*mode/(1.0 + mode);
logy += -0.5*lprec + M_LN_SQRT_2PI;
logy += pnorm(0.0, mode, 1.0/sqrt(prec), 0, 1);
// Rprintf("mode %lf prec %lf, Lap 1F1(%lf, %lf, %lf) = %lf", mode, prec, a,b,x);
}}
else {
logy = x + loghyperg1F1_laplace(b - a, b, -x);
}
return(logy);
}
