The R Project SVN R

Rev

Rev 64668 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
574 ihaka 1 
/*
2 
 *  Mathlib : A C Library of Special Functions
3 
 *  Copyright (C) 1998 Ross Ihaka
64655 ripley 4 
 *  Copyright (C) 2000-2014 The R Core Team
574 ihaka 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42302 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
574 ihaka 19 
 *
20 
 *  DESCRIPTION
21 
 *
22 
 *    The quantile function of the hypergeometric distribution.
23 
 */
24 
 
8431 ripley 25 
#include "nmath.h"
8074 maechler 26 
#include "dpq.h"
574 ihaka 27 
 
7671 maechler 28 
double qhyper(double p, double NR, double NB, double n,
29 
	      int lower_tail, int log_p)
574 ihaka 30 
{
30227 maechler 31 
/* This is basically the same code as  ./phyper.c  *used* to be --> FIXME! */
574 ihaka 32 
    double N, xstart, xend, xr, xb, sum, term;
8628 pd 33 
    int small_N;
574 ihaka 34 
#ifdef IEEE_754
7671 maechler 35 
    if (ISNAN(p) || ISNAN(NR) || ISNAN(NB) || ISNAN(n))
36 
	return p + NR + NB + n;
7867 ripley 37 
#endif
7671 maechler 38 
    if(!R_FINITE(p) || !R_FINITE(NR) || !R_FINITE(NB) || !R_FINITE(n))
39 
	ML_ERR_return_NAN;
40 
 
64668 ripley 41 
    NR = R_forceint(NR);
42 
    NB = R_forceint(NB);
574 ihaka 43 
    N = NR + NB;
64668 ripley 44 
    n = R_forceint(n);
30227 maechler 45 
    if (NR < 0 || NB < 0 || n < 0 || n > N)
7671 maechler 46 
	ML_ERR_return_NAN;
47 
 
30227 maechler 48 
    /* Goal:  Find  xr (= #{red balls in sample}) such that
49 
     *   phyper(xr,  NR,NB, n) >= p > phyper(xr - 1,  NR,NB, n)
50 
     */
51 
 
7671 maechler 52 
    xstart = fmax2(0, n - NB);
53 
    xend = fmin2(n, NR);
54 
 
34956 maechler 55 
    R_Q_P01_boundaries(p, xstart, xend);
56 
 
574 ihaka 57 
    xr = xstart;
30227 maechler 58 
    xb = n - xr;/* always ( = #{black balls in sample} ) */
7671 maechler 59 
 
8628 pd 60 
    small_N = (N < 1000); /* won't have underflow in product below */
61 
    /* if N is small,  term := product.ratio( bin.coef );
62 
       otherwise work with its logarithm to protect against underflow */
63 
    term = lfastchoose(NR, xr) + lfastchoose(NB, xb) - lfastchoose(N, n);
64 
    if(small_N) term = exp(term);
65 
    NR -= xr;
66 
    NB -= xb;
67 
 
7863 maechler 68 
    if(!lower_tail || log_p) {
7980 maechler 69 
	p = R_DT_qIv(p);
7863 maechler 70 
    }
37598 ripley 71 
    p *= 1 - 1000*DBL_EPSILON; /* was 64, but failed on FreeBSD sometimes */
8628 pd 72 
    sum = small_N ? term : exp(term);
73 
 
7671 maechler 74 
    while(sum < p && xr < xend) {
574 ihaka 75 
	xr++;
76 
	NB++;
8628 pd 77 
	if (small_N) term *= (NR / xr) * (xb / NB);
78 
	else term += log((NR / xr) * (xb / NB));
79 
	sum += small_N ? term : exp(term);
574 ihaka 80 
	xb--;
81 
	NR--;
82 
    }
7675 ripley 83 
    return xr;
574 ihaka 84 
}