double
gsl_cdf_gamma_Q (const double x, const double a, const double b)
{
double P;
double y = x / b;
if (x <= 0.0)
{
return 1.0;
}
#if 0 /* Not currently working to sufficient accuracy in tails */
if (a > LARGE_A)
{
/*
* Peizer and Pratt's approximation mentioned above.
*/
double z = norm_arg (y, a);
P = gsl_cdf_ugaussian_Q (z);
}
else
#endif
{
P = gsl_sf_gamma_inc_Q (a, y);
}
return P;
}
static void
apply_gammq_call( Reduce *rc,
const char *name, HeapNode **arg, PElement *out )
{
PElement rhs;
double a, x, Q;
PEPOINTRIGHT( arg[1], &rhs );
a = PEGETREAL( &rhs );
PEPOINTRIGHT( arg[0], &rhs );
x = PEGETREAL( &rhs );
if( a <= 0 || x < 0 ) {
error_top( _( "Out of range." ) );
error_sub( _( "gammq arguments must be a > 0, x >= 0." ) );
reduce_throw( rc );
}
#ifdef HAVE_GSL
Q = gsl_sf_gamma_inc_Q( a, x );
#else /*!HAVE_GSL*/
error_top( _( "Not available." ) );
error_sub( _( "No GSL library available for gammq." ) );
reduce_throw( rc );
#endif /*HAVE_GSL*/
if( !heap_real_new( rc->heap, Q, out ) )
reduce_throw( rc );
}
static double
beta_inc_AXPY (const double A, const double Y,
const double a, const double b, const double x)
{
if (x == 0.0)
{
return A * 0 + Y;
}
else if (x == 1.0)
{
return A * 1 + Y;
}
else if (a > 1e5 && b < 10 && x > a / (a + b))
{
/* Handle asymptotic regime, large a, small b, x > peak [AS 26.5.17] */
double N = a + (b - 1.0) / 2.0;
return A * gsl_sf_gamma_inc_Q (b, -N * log (x)) + Y;
}
else if (b > 1e5 && a < 10 && x < b / (a + b))
{
/* Handle asymptotic regime, small a, large b, x < peak [AS 26.5.17] */
double N = b + (a - 1.0) / 2.0;
return A * gsl_sf_gamma_inc_P (a, -N * log1p (-x)) + Y;
}
else
{
double ln_beta = gsl_sf_lnbeta (a, b);
double ln_pre = -ln_beta + a * log (x) + b * log1p (-x);
double prefactor = exp (ln_pre);
if (x < (a + 1.0) / (a + b + 2.0))
{
/* Apply continued fraction directly. */
double epsabs = fabs (Y / (A * prefactor / a)) * GSL_DBL_EPSILON;
double cf = beta_cont_frac (a, b, x, epsabs);
return A * (prefactor * cf / a) + Y;
}
else
{
/* Apply continued fraction after hypergeometric transformation. */
double epsabs =
fabs ((A + Y) / (A * prefactor / b)) * GSL_DBL_EPSILON;
double cf = beta_cont_frac (b, a, 1.0 - x, epsabs);
double term = prefactor * cf / b;
if (A == -Y)
{
return -A * term;
}
else
{
return A * (1 - term) + Y;
}
}
}
}
/*
* This does the pearson above, but computes histogram occupation using a
* binomial distribution. This is useful to compute e.g. the pvalue for a
* vector of tally results from flipping 100 coins, performed 100 times.
* It automatically cuts off the tails where bin membership isn't large
* enough to give a good result.
*/
double chisq_binomial(double *observed,double prob,unsigned int kmax,unsigned int nsamp)
{
unsigned int n,nmax,ndof;
double expected,delchisq,chisq,pvalue,obstotal,exptotal;
chisq = 0.0;
obstotal = 0.0;
exptotal = 0.0;
ndof = 0;
nmax = kmax;
if(verbose){
printf("# %7s %3s %3s %10s %10s %9s\n",
"bit/bin","DoF","X","Y","del-chisq","chisq");
printf("#==================================================================\n");
}
for(n = 0;n <= nmax;n++){
if(observed[n] > 10.0){
expected = nsamp*gsl_ran_binomial_pdf(n,prob,nmax);
obstotal += observed[n];
exptotal += expected;
delchisq = (observed[n] - expected)*(observed[n] - expected)/expected;
chisq += delchisq;
if(verbose){
printf("# %5u %3u %10.4f %10.4f %10.4f %10.4f\n",
n,ndof,observed[n],expected,delchisq,chisq);
}
ndof++;
}
}
if(verbose){
printf("Total: %10.4f %10.4f\n",obstotal,exptotal);
printf("#==================================================================\n");
printf("Evaluated chisq = %f for %u degrees of freedom\n",chisq,ndof);
}
/*
* Now evaluate the corresponding pvalue. The only real question
* is what is the correct number of degrees of freedom. I'd argue we
* did use a constraint when we set expected = binomial*nsamp, so we'll
* go for ndof (count of bins tallied) - 1.
*/
ndof--;
pvalue = gsl_sf_gamma_inc_Q((double)(ndof)/2.0,chisq/2.0);
if(verbose){
printf("Evaluted pvalue = %6.4f in chisq_binomial.\n",pvalue);
}
return(pvalue);
}
double chisq_poisson(unsigned int *observed,double lambda,int kmax,unsigned int nsamp)
{
unsigned int k;
double *expected;
double delchisq,chisq,pvalue;
/*
* Allocate a vector for the expected value of the bin frequencies up
* to kmax-1.
*/
expected = (double *)malloc(kmax*sizeof(double));
for(k = 0;k<kmax;k++){
expected[k] = nsamp*gsl_ran_poisson_pdf(k,lambda);
}
/*
* Compute Pearson's chisq for this vector of the data with poisson
* expected values.
*/
chisq = 0.0;
for(k = 0;k < kmax;k++){
delchisq = ((double) observed[k] - expected[k])*
((double) observed[k] - expected[k])/expected[k];
chisq += delchisq;
if(verbose == D_CHISQ || verbose == D_ALL){
printf("%u: observed = %f, expected = %f, delchisq = %f, chisq = %f\n",
k,(double)observed[k],expected[k],delchisq,chisq);
}
}
if(verbose == D_CHISQ || verbose == D_ALL){
printf("Evaluated chisq = %f for %u k values\n",chisq,kmax);
}
/*
* Now evaluate the corresponding pvalue. The only real question
* is what is the correct number of degrees of freedom. We have
* kmax bins, so it should be kmax-1.
*/
pvalue = gsl_sf_gamma_inc_Q((double)(kmax-1)/2.0,chisq/2.0);
if(verbose == D_CHISQ || verbose == D_ALL){
printf("pvalue = %f in chisq_poisson.\n",pvalue);
}
free(expected);
return(pvalue);
}
double
gsl_cdf_exppow_Q (const double x, const double a, const double b)
{
const double u = x / a;
if (u < 0)
{
double Q = 0.5 * (1.0 + gsl_sf_gamma_inc_P (1.0 / b, pow (-u, b)));
return Q;
}
else
{
double Q = 0.5 * gsl_sf_gamma_inc_Q (1.0 / b, pow (u, b));
return Q;
}
}
/*
* Contributed by David Bauer to do a Pearson chisq on a 2D
* histogram.
*/
double chisq2d(unsigned int *obs, unsigned int rows, unsigned int columns, unsigned int N) {
double chisq = 0.0;
unsigned int i, j, k;
unsigned int ndof = (rows - 1) * (columns - 1);
for (i = 0; i < rows; i++) {
for (j = 0; j < columns; j++) {
unsigned int sum1 = 0, sum2 = 0;
double expected, top;
for (k = 0; k < columns; k++) sum1 += obs[i * columns + k];
for (k = 0; k < rows; k++) sum2 += obs[k * columns + j];
expected = (double) sum1 * sum2 / N;
top = (double) obs[i * columns + j] - expected;
chisq += (top * top) / expected;
}
}
return( gsl_sf_gamma_inc_Q((double)(ndof)/2.0,chisq/2.0) );
}
double
gsl_cdf_gamma_P (const double x, const double a, const double b)
{
double P;
double y = x / b;
if (x <= 0.0)
{
return 0.0;
}
if (y > a)
{
P = 1 - gsl_sf_gamma_inc_Q (a, y);
}
else
{
P = gsl_sf_gamma_inc_P (a, y);
}
return P;
}
double
gsl_cdf_gamma_Q (const double x, const double a, const double b)
{
double Q;
double y = x / b;
if (x <= 0.0)
{
return 1.0;
}
if (y < a)
{
Q = 1 - gsl_sf_gamma_inc_P (a, y);
}
else
{
Q = gsl_sf_gamma_inc_Q (a, y);
}
return Q;
}
/*
* Pearson is the test for a straight up binned histogram, where bin
* membership is with "independent" probabilities (that sum to 1).
* Observed is the vector of observed histogram values. Expected is
* the vector of expected histogram values (where the two should
* agree in total count). kmax is the dimension of the data vectors.
* It returns a pvalue PRESUMING kmax-1 degrees of freedom (independent
* bin probabilities, but with a constraint that they sum to 1).
*/
double chisq_pearson(double *observed,double *expected,int kmax)
{
unsigned int k;
double delchisq,chisq,pvalue;
/*
* Compute Pearson's chisq for this vector of the data.
*/
chisq = 0.0;
for(k = 0;k < kmax;k++){
delchisq = (observed[k] - expected[k])*
(observed[k] - expected[k])/expected[k];
chisq += delchisq;
if(verbose){
printf("%u: observed = %f, expected = %f, delchisq = %f, chisq = %f\n",
k,observed[k],expected[k],delchisq,chisq);
}
}
if(verbose){
printf("Evaluated chisq = %f for %u k values\n",chisq,kmax);
}
/*
* Now evaluate the corresponding pvalue. The only real question
* is what is the correct number of degrees of freedom. We have
* kmax bins, so it should be kmax-1.
*/
pvalue = gsl_sf_gamma_inc_Q((double)(kmax-1)/2.0,chisq/2.0);
if(verbose){
printf("pvalue = %f in chisq_pearson.\n",pvalue);
}
return(pvalue);
}
inline double gamma_q(double x, double y)
{ return gsl_sf_gamma_inc_Q(x, y); }
inline long double gamma_q(long double x, long double y)
{ return gsl_sf_gamma_inc_Q(x, y); }
inline float gamma_q(float x, float y)
{ return (float)gsl_sf_gamma_inc_Q(x, y); }
int main()
{
# include "igamma_med_data.ipp"
# include "igamma_small_data.ipp"
# include "igamma_big_data.ipp"
# include "igamma_int_data.ipp"
add_data(igamma_med_data);
add_data(igamma_small_data);
add_data(igamma_big_data);
add_data(igamma_int_data);
unsigned data_total = data.size();
std::cout << "Screening Boost data:\n";
screen_data([](const std::vector<double>& v){ return boost::math::gamma_q(v[0], v[1]); }, [](const std::vector<double>& v){ return v[3]; });
#if defined(TEST_GSL) && !defined(COMPILER_COMPARISON_TABLES)
std::cout << "Screening GSL data:\n";
screen_data([](const std::vector<double>& v){ return gsl_sf_gamma_inc_Q(v[0], v[1]); }, [](const std::vector<double>& v){ return v[3]; });
#endif
#if defined(TEST_RMATH) && !defined(COMPILER_COMPARISON_TABLES)
std::cout << "Screening GSL data:\n";
screen_data([](const std::vector<double>& v){ return pgamma(v[1], v[0], 1.0, 0, 0); }, [](const std::vector<double>& v){ return v[3]; });
#endif
unsigned data_used = data.size();
std::string function = "gamma_q[br](" + boost::lexical_cast<std::string>(data_used) + "/" + boost::lexical_cast<std::string>(data_total) + " tests selected)";
std::string function_short = "gamma_q";
double time;
time = exec_timed_test([](const std::vector<double>& v){ return boost::math::gamma_q(v[0], v[1]); });
std::cout << time << std::endl;
#if !defined(COMPILER_COMPARISON_TABLES) && (defined(TEST_GSL) || defined(TEST_RMATH))
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, boost_name());
#endif
report_execution_time(time, std::string("Compiler Comparison on ") + std::string(platform_name()), function_short, compiler_name() + std::string("[br]") + boost_name());
//
// Boost again, but with promotion to long double turned off:
//
#if !defined(COMPILER_COMPARISON_TABLES)
if(sizeof(long double) != sizeof(double))
{
time = exec_timed_test([](const std::vector<double>& v){ return boost::math::gamma_q(v[0], v[1], boost::math::policies::make_policy(boost::math::policies::promote_double<false>())); });
std::cout << time << std::endl;
#if !defined(COMPILER_COMPARISON_TABLES) && (defined(TEST_GSL) || defined(TEST_RMATH))
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, boost_name() + "[br]promote_double<false>");
#endif
report_execution_time(time, std::string("Compiler Comparison on ") + std::string(platform_name()), function_short, compiler_name() + std::string("[br]") + boost_name() + "[br]promote_double<false>");
}
#endif
#if defined(TEST_GSL) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return gsl_sf_gamma_inc_Q(v[0], v[1]); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "GSL " GSL_VERSION);
#endif
#if defined(TEST_RMATH) && !defined(COMPILER_COMPARISON_TABLES)
time = exec_timed_test([](const std::vector<double>& v){ return pgamma(v[1], v[0], 1.0, 0, 0); });
std::cout << time << std::endl;
report_execution_time(time, std::string("Library Comparison with ") + std::string(compiler_name()) + std::string(" on ") + platform_name(), function, "Rmath " R_VERSION_STRING);
#endif
return 0;
}
double pchisq(double q, double k){
return gsl_sf_gamma_inc_Q(k/2.0, q/2.0);
}
int diehard_runs(Test **test, int irun)
{
int i,j,k,t;
unsigned int ucount,dcount;
int upruns[RUN_MAX],downruns[RUN_MAX];
double uv,dv,up_pks,dn_pks;
uint first, last, next = 0;
/*
* This is just for display.
*/
test[0]->ntuple = 0;
test[1]->ntuple = 0;
/*
* Clear up and down run bins
*/
for(k=0;k<RUN_MAX;k++){
upruns[k] = 0;
downruns[k] = 0;
}
/*
* Now count up and down runs and increment the bins. Note
* that each successive up counts as a run of one down, and
* each successive down counts as a run of one up.
*/
ucount = dcount = 1;
if(verbose){
printf("j rand ucount dcount\n");
}
first = last = gsl_rng_get(rng);
for(t=1;t<test[0]->tsamples;t++) {
next = gsl_rng_get(rng);
if(verbose){
printf("%d: %10u %u %u\n",t,next,ucount,dcount);
}
/*
* Did we increase?
*/
if(next > last){
ucount++;
if(ucount > RUN_MAX) ucount = RUN_MAX;
downruns[dcount-1]++;
dcount = 1;
} else {
dcount++;
if(dcount > RUN_MAX) dcount = RUN_MAX;
upruns[ucount-1]++;
ucount = 1;
}
last = next;
}
if(next > first){
ucount++;
if(ucount > RUN_MAX) ucount = RUN_MAX;
downruns[dcount-1]++;
dcount = 1;
} else {
dcount++;
if(dcount > RUN_MAX) dcount = RUN_MAX;
upruns[ucount-1]++;
ucount = 1;
}
/*
* This ends a single sample.
* Compute the test statistic for up and down runs.
*/
uv=0.0;
dv=0.0;
if(verbose){
printf(" i upruns downruns\n");
}
for(i=0;i<RUN_MAX;i++) {
if(verbose){
printf("%d: %7d %7d\n",i,upruns[i],downruns[i]);
}
for(j=0;j<RUN_MAX;j++) {
uv += ((double)upruns[i] - test[0]->tsamples*b[i])*(upruns[j] - test[0]->tsamples*b[j])*a[i][j];
dv += ((double)downruns[i] - test[0]->tsamples*b[i])*(downruns[j] - test[0]->tsamples*b[j])*a[i][j];
}
}
uv /= (double)test[0]->tsamples;
dv /= (double)test[0]->tsamples;
/*
* This NEEDS WORK! It isn't right, somehow...
*/
up_pks = 1.0 - exp ( -0.5 * uv ) * ( 1.0 + 0.5 * uv + 0.125 * uv*uv );
dn_pks = 1.0 - exp ( -0.5 * dv ) * ( 1.0 + 0.5 * dv + 0.125 * dv*dv );
MYDEBUG(D_DIEHARD_RUNS) {
printf("uv = %f dv = %f\n",uv,dv);
}
test[0]->pvalues[irun] = gsl_sf_gamma_inc_Q(3.0,uv/2.0);
test[1]->pvalues[irun] = gsl_sf_gamma_inc_Q(3.0,dv/2.0);
MYDEBUG(D_DIEHARD_RUNS) {
printf("# diehard_runs(): test[0]->pvalues[%u] = %10.5f\n",irun,test[0]->pvalues[irun]);
printf("# diehard_runs(): test[1]->pvalues[%u] = %10.5f\n",irun,test[1]->pvalues[irun]);
}
return(0);
}
double FC_FUNC_(oct_incomplete_gamma, OCT_INCOMPLETE_GAMMA)
(const double *a, const double *x)
{
return gsl_sf_gamma_inc_Q(*a, *x);
}
