// logit(p) = log(p/(1-p))
// The argument p must be greater than 0 and less than 1.
double Logit(double p)
{
if( (p <= 0.0) || (p >= 1.0) )
{
std::stringstream os;
os << "argument (" << p << ") must be greater than 0 and less than 1.";
throw std::invalid_argument( os.str() );
}
static const double smallCutOff = 0.25;
double retval;
if (p < smallCutOff)
{
// Avoid calculating 1-p since the lower bits of p would be lost.
retval = log(p) - LogOnePlusX(-p);
}
else
{
// The argument p is large enough that direct calculation is OK.
retval = log(p/(1-p));
}
return retval;
}
// Calculate log( -log(1 - p) ) avoiding problems for small values of p.
// Input p must be strictly between 0 and 1
double ComplementaryLogLog(double p)
{
if (p <= 0.0 || p >= 1.0)
{
std::stringstream os;
os << "Invalid input argument (" << p << "); must be greater than 0 and less than 1.";
throw std::invalid_argument(os.str());
}
return log( -LogOnePlusX(-p) );
}
/*
if (x <= -1.0)
{
std::stringstream os;
os << "Invalid input argument (" << x << "); must be greater than -1.0";
throw std::invalid_argument(os.str());
}
*/
if (fabs(x) > 0.375)
{
// x is sufficiently large that the obvious evaluation is OK
return log(1.0 + x);
}
// For smaller arguments we use a rational approximation
// to the function log(1+x) to avoid the loss of precision
// that would occur if we simply added 1 to x then took the log.
const double p1 = -0.129418923021993e+01;
const double p2 = 0.405303492862024e+00;
const double p3 = -0.178874546012214e-01;
const double q1 = -0.162752256355323e+01;
const double q2 = 0.747811014037616e+00;
const double q3 = -0.845104217945565e-01;
double t, t2, w;
t = x/(x + 2.0);
t2 = t*t;
w = (((p3*t2 + p2)*t2 + p1)*t2 + 1.0)/(((q3*t2 + q2)*t2 + q1)*t2 + 1.0);
return 2.0*t*w;
}
//-----------------------------------------------------------------------------
// Calculate exp(x) - 1.
// The most direct method is inaccurate for very small arguments.
double ExpMinusOne(double x)
{
const double p1 = 0.914041914819518e-09;
const double p2 = 0.238082361044469e-01;
const double q1 = -0.499999999085958e+00;
const double q2 = 0.107141568980644e+00;
const double q3 = -0.119041179760821e-01;
const double q4 = 0.595130811860248e-03;
double rexp = 0.0;
// Use rational approximation for small arguments.
if( fabs(x) < 0.15 )
{
rexp = x*(((p2*x + p1)*x + 1.0)/((((q4*x + q3)*x + q2)*x + q1)*x + 1.0));
return rexp;
}
// For large negative arguments, direct calculation is OK.
double w = exp(x);
if( x <= -0.15 )
{
rexp = w - 1.0;
return rexp;
}
// The following expression is algebraically equal to exp(x) - 1.
// The advantage in finite precision arithmetic is that
// it avoids subtracting nearly equal numbers.
rexp = w * ( 0.5 + ( 0.5 - 1.0/w ));
return rexp;
}
//-----------------------------------------------------------------------------
// logit(p) = log(p/(1-p))
// The argument p must be greater than 0 and less than 1.
double Logit(double p)
{
if( (p <= 0.0) || (p >= 1.0) )
{
std::stringstream os;
os << "argument (" << p << ") must be greater than 0 and less than 1.";
throw std::invalid_argument( os.str() );
}
static const double smallCutOff = 0.25;
double retval;
if (p < smallCutOff)
{
// Avoid calculating 1-p since the lower bits of p would be lost.
retval = log(p) - LogOnePlusX(-p);
}
else
{
// The argument p is large enough that direct calculation is OK.
retval = log(p/(1-p));
}
return retval;
}
//-----------------------------------------------------------------------------
// The inverse of the Logit function. Return exp(x)/(1 + exp(x)).
// Avoid overflow and underflow for extreme inputs.
double LogitInverse(double x)
{
static const double X_MAX = -log(DBL_EPSILON);
static const double X_MIN = log(DBL_MIN);
double retval;
if (x > X_MAX)
{
// For large arguments x, logit(x) equals 1 to double precision.
retval = 1.0; // avoids overflow of calculating e^x for large x
}
else if (x < X_MIN)
{
// logit(x) is approximately e^x for x very negative
// and so logit would underflow when e^x underflows
retval = 0.0;
}
else
{
// Direct calculation is safe in this range.
// Save value to avoid two calls to e^x
double t = exp(x);
retval = t/(1+t);
}
return retval;
}
//-----------------------------------------------------------------------------
// The natural logorithm of the logit inverse function.
// Return log( exp(x)/(1 + exp(x)) )
double LogLogitInverse(double x)
{
// log( exp(x)/(1 + exp(x) ) = x - log(1 + exp(x)).
// For x < -30, x - log(1 + exp(x)) = x to machine precision
// since the log term is extremely small relative to x.
if (x < -30)
return x;
// The obvious implementation is OK in the middle range.
if (x < 12)
return log(LogitInverse(x));
// Set y = exp(x). Then x - log(1 + exp(x)) = log(y) - log(y + 1).
// Expand in Taylor series around y.
// log(y) - log(y+1) = - 1/y - 1/y^2 + O(1/y^3).
// Since x >= 12, 1/y^3 is extremely small.
double one_over_y = exp(-x);
return -(1.0 - 0.5*one_over_y)*one_over_y;
}
//-----------------------------------------------------------------------------
// Compute LogitInverse(x) - LogitInverse(y) accurately,
// especially for approximately equal values of x and y
// and for large values of x and y.
double LogitInverseDifference(double x, double y)
{
static const double CLOSE_CUTOFF = 0.25;
static const double LOG_DBL_MAX = log(DBL_MAX);
static const double LOG_DBL_MIN = log(DBL_MIN);
if (fabs(x-y) < CLOSE_CUTOFF)
{
if (x > LOG_DBL_MAX || x < LOG_DBL_MIN)
{
// For numbers this large in absolute value, the difference
// of their logitInverse values is 0 to machine precision.
// Return 0 and avoid overflow.
return 0.0;
}
else
{
// Use expMinusOne to avoid cancellation in exp(x-y) - 1.
// This cannot overflow since |x-y| < CLOSE_CUTOFF.
// Other exponents safe due to range of x (and thus y).
return ExpMinusOne(x-y)/((exp(x) + 1.0)*(exp(-y) + 1.0));
}
}
else
{
bool x_positive = (x > 0.0);
bool y_positive = (y > 0.0);
if (x_positive && y_positive)
{
// logitInverse(x) - logitInverse(y) == logitInverse(-y) - logitInverse(-x)
// swap (x, y) with (-y, -x) so that both arguments are negative
double temp = x; x = -y; y = -temp;
// might underflow, but cannot overflow since arguments are negative
double a = exp(x), b = exp(y);
// The following subtraction won't lose precision since |x-y| > SMALL_CUTOFF.
return (a - b)/((1.0 + a)*(1.0 + b));
}
else if (!x_positive && !y_positive)
{
// See comments for case x > 0 and y > 0.
double a = exp(x), b = exp(y);
return (a - b)/((1.0 + a)*(1.0 + b));
}
else if (x_positive && !y_positive)
{
return (1.0 - exp(y-x))/((1.0 + exp(-x))*(1.0 + exp(y)));
}
else
{
return (exp(x-y) - 1.0)/((1.0 + exp(-y))*(1.0 + exp(x)));
}
}
}
//-----------------------------------------------------------------------------
// return log(1 + exp(x)), preventing cancellation and overflow */
double LogOnePlusExpX(double x)
{
static const double LOG_DBL_EPSILON = log(DBL_EPSILON);
static const double LOG_ONE_QUARTER = log(0.25);
if (x > -LOG_DBL_EPSILON)
{
// log(exp(x) + 1) == x to machine precision
return x;
}
else if (x > LOG_ONE_QUARTER)
{
return log( 1.0 + exp(x) );
}
else
{
// Prevent loss of precision that would result from adding small argument to 1.
return LogOnePlusX( exp(x) );
}
}
// http://stackoverflow.com/questions/15539116/atanh-arc-hyperbolic-tangent-function-missing-in-ms-visual-c
double atanh(double x) //implements: return (log(1+x) - log(1-x))/2
{
return (LogOnePlusX(x) - LogOnePlusX(-x)) / 2.0;
}
void gibbsOneWayAnova(double *y, int *N, int J, int sumN, int *whichJ, double rscale, int iterations, double *chains, double *CMDE, SEXP debug, int progress, SEXP pBar, SEXP rho)
{
int i=0,j=0,m=0,Jp1sq = (J+1)*(J+1),Jsq=J*J,Jp1=J+1,npars=0;
double ySum[J],yBar[J],sumy2[J],densDelta=0;
double sig2=1,g=1;
double XtX[Jp1sq], ZtZ[Jsq];
double Btemp[Jp1sq],B2temp[Jsq],tempBetaSq=0;
double muTemp[J],oneOverSig2temp=0;
double beta[J+1],grandSum=0,grandSumSq=0;
double shapeSig2 = (sumN+J*1.0)/2, shapeg = (J+1.0)/2;
double scaleSig2=0, scaleg=0;
double Xty[J+1],Zty[J];
double logDet=0;
double rscaleSq=rscale*rscale;
double logSumSingle=0,logSumDouble=0;
// for Kahan sum
double kahanSumSingle=0, kahanSumDouble=0;
double kahanCSingle=0,kahanCDouble=0;
double kahanTempT=0, kahanTempY=0;
int iOne=1, info;
double dZero=0;
// progress stuff
SEXP sampCounter, R_fcall;
int *pSampCounter;
PROTECT(R_fcall = lang2(pBar, R_NilValue));
PROTECT(sampCounter = NEW_INTEGER(1));
pSampCounter = INTEGER_POINTER(sampCounter);
npars=J+5;
GetRNGstate();
// Initialize to 0
AZERO(XtX,Jp1sq);
AZERO(ZtZ,Jsq);
AZERO(beta,Jp1);
AZERO(ySum,J);
AZERO(sumy2,J);
// Create vectors
for(i=0;i<sumN;i++)
{
j = whichJ[i];
ySum[j] += y[i];
sumy2[j] += y[i]*y[i];
grandSum += y[i];
grandSumSq += y[i]*y[i];
}
// create design matrices
XtX[0]=sumN;
for(j=0;j<J;j++)
{
XtX[j+1]=N[j];
XtX[(J+1)*(j+1)]=N[j];
XtX[(j+1)*(J+1) + (j+1)] = N[j];
ZtZ[j*J + j] = N[j];
yBar[j] = ySum[j]/(1.0*N[j]);
}
Xty[0] = grandSum;
Memcpy(Xty+1,ySum,J);
Memcpy(Zty,ySum,J);
// start MCMC
for(m=0; m<iterations; m++)
{
R_CheckUserInterrupt();
//Check progress
if(progress && !((m+1)%progress)){
pSampCounter[0]=m+1;
SETCADR(R_fcall, sampCounter);
eval(R_fcall, rho); //Update the progress bar
}
// sample beta
Memcpy(Btemp,XtX,Jp1sq);
for(j=0;j<J;j++){
Btemp[(j+1)*(J+1)+(j+1)] += 1/g;
}
InvMatrixUpper(Btemp, J+1);
internal_symmetrize(Btemp,J+1);
for(j=0;j<Jp1sq;j++)
Btemp[j] *= sig2;
oneOverSig2temp = 1/sig2;
F77_CALL(dsymv)("U", &Jp1, &oneOverSig2temp, Btemp, &Jp1, Xty, &iOne, &dZero, beta, &iOne);
rmvGaussianC(beta, Btemp, J+1);
Memcpy(&chains[npars*m],beta,J+1);
// calculate density (Single Standardized)
Memcpy(B2temp,ZtZ,Jsq);
densDelta = -J*0.5*log(2*M_PI);
for(j=0;j<J;j++)
{
B2temp[j*J+j] += 1/g;
muTemp[j] = (ySum[j]-N[j]*beta[0])/sqrt(sig2);
}
InvMatrixUpper(B2temp, J);
internal_symmetrize(B2temp,J);
logDet = matrixDet(B2temp,J,J,1, &info);
densDelta += -0.5*quadform(muTemp, B2temp, J, 1, J);
densDelta += -0.5*logDet;
if(m==0){
logSumSingle = densDelta;
kahanSumSingle = exp(densDelta);
}else{
logSumSingle = logSumSingle + LogOnePlusX(exp(densDelta-logSumSingle));
kahanTempY = exp(densDelta) - kahanCSingle;
kahanTempT = kahanSumSingle + kahanTempY;
kahanCSingle = (kahanTempT - kahanSumSingle) - kahanTempY;
kahanSumSingle = kahanTempT;
}
chains[npars*m + (J+1) + 0] = densDelta;
// calculate density (Double Standardized)
densDelta += 0.5*J*log(g);
if(m==0){
logSumDouble = densDelta;
kahanSumDouble = exp(densDelta);
}else{
logSumDouble = logSumDouble + LogOnePlusX(exp(densDelta-logSumDouble));
kahanTempY = exp(densDelta) - kahanCDouble;
kahanTempT = kahanSumDouble + kahanTempY;
kahanCDouble = (kahanTempT - kahanSumDouble) - kahanTempY;
kahanSumDouble = kahanTempT;
}
chains[npars*m + (J+1) + 1] = densDelta;
// sample sig2
tempBetaSq = 0;
scaleSig2 = grandSumSq - 2*beta[0]*grandSum + beta[0]*beta[0]*sumN;
for(j=0;j<J;j++)
{
scaleSig2 += -2.0*(yBar[j]-beta[0])*N[j]*beta[j+1] + (N[j]+1/g)*beta[j+1]*beta[j+1];
tempBetaSq += beta[j+1]*beta[j+1];
}
scaleSig2 *= 0.5;
sig2 = 1/rgamma(shapeSig2,1/scaleSig2);
chains[npars*m + (J+1) + 2] = sig2;
// sample g
scaleg = 0.5*(tempBetaSq/sig2 + rscaleSq);
g = 1/rgamma(shapeg,1/scaleg);
chains[npars*m + (J+1) + 3] = g;
}
CMDE[0] = logSumSingle - log(iterations);
CMDE[1] = logSumDouble - log(iterations);
CMDE[2] = log(kahanSumSingle) - log(iterations);
CMDE[3] = log(kahanSumDouble) - log(iterations);
UNPROTECT(2);
PutRNGstate();
}
