The R Project SVN R

Rev

Rev 8431 | Rev 34956 | 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
7671 maechler 4 
 *  Copyright (C) 2000 The R Development 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
17 
 *  along with this program; if not, write to the Free Software
5458 ripley 18 
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA.
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 
{
4562 pd 31 
/* This is basically the same code as  ./phyper.c -- keep in sync! */
574 ihaka 32 
    double N, xstart, xend, xr, xb, sum, term;
8628 pd 33 
    int small_N;
34 
 
574 ihaka 35 
#ifdef IEEE_754
7671 maechler 36 
    if (ISNAN(p) || ISNAN(NR) || ISNAN(NB) || ISNAN(n))
37 
	return p + NR + NB + n;
7867 ripley 38 
#endif
7671 maechler 39 
    if(!R_FINITE(p) || !R_FINITE(NR) || !R_FINITE(NB) || !R_FINITE(n))
40 
	ML_ERR_return_NAN;
41 
    R_Q_P01_check(p);
42 
 
574 ihaka 43 
    NR = floor(NR + 0.5);
44 
    NB = floor(NB + 0.5);
45 
    N = NR + NB;
46 
    n = floor(n + 0.5);
7671 maechler 47 
    if (NR < 0 || NR < 0 || n < 0 || n > N)
48 
	ML_ERR_return_NAN;
49 
 
50 
    xstart = fmax2(0, n - NB);
51 
    xend = fmin2(n, NR);
52 
    if(p == R_DT_0) return xstart;
53 
    if(p == R_DT_1) return xend;
54 
 
574 ihaka 55 
    xr = xstart;
56 
    xb = n - xr;
7671 maechler 57 
 
8628 pd 58 
    small_N = (N < 1000); /* won't have underflow in product below */
59 
    /* if N is small,  term := product.ratio( bin.coef );
60 
       otherwise work with its logarithm to protect against underflow */
61 
    term = lfastchoose(NR, xr) + lfastchoose(NB, xb) - lfastchoose(N, n);
62 
    if(small_N) term = exp(term);
63 
    NR -= xr;
64 
    NB -= xb;
65 
 
574 ihaka 66 
    sum = term;
7863 maechler 67 
    if(!lower_tail || log_p) {
7980 maechler 68 
	p = R_DT_qIv(p);
7863 maechler 69 
    }
70 
    p *= 1 - 64*DBL_EPSILON;
8628 pd 71 
    sum = small_N ? term : exp(term);
72 
 
7671 maechler 73 
    while(sum < p && xr < xend) {
574 ihaka 74 
	xr++;
75 
	NB++;
8628 pd 76 
	if (small_N) term *= (NR / xr) * (xb / NB);
77 
	else term += log((NR / xr) * (xb / NB));
78 
	sum += small_N ? term : exp(term);
574 ihaka 79 
	xb--;
80 
	NR--;
81 
    }
7675 ripley 82 
    return xr;
574 ihaka 83 
}