// 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(); }