incbet.c 7.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379
  1. /* incbet.c
  2. *
  3. * Incomplete beta integral
  4. *
  5. *
  6. * SYNOPSIS:
  7. *
  8. * double a, b, x, y, incbet();
  9. *
  10. * y = incbet( a, b, x );
  11. *
  12. *
  13. * DESCRIPTION:
  14. *
  15. * Returns incomplete beta integral of the arguments, evaluated
  16. * from zero to x. The function is defined as
  17. *
  18. * x
  19. * - -
  20. * | (a+b) | | a-1 b-1
  21. * ----------- | t (1-t) dt.
  22. * - - | |
  23. * | (a) | (b) -
  24. * 0
  25. *
  26. * The domain of definition is 0 <= x <= 1. In this
  27. * implementation a and b are restricted to positive values.
  28. * The integral from x to 1 may be obtained by the symmetry
  29. * relation
  30. *
  31. * 1 - incbet( a, b, x ) = incbet( b, a, 1-x ).
  32. *
  33. * The integral is evaluated by a continued fraction expansion
  34. * or, when b*x is small, by a power series.
  35. *
  36. * ACCURACY:
  37. *
  38. * Tested at uniformly distributed random points (a,b,x) with a and b
  39. * in "domain" and x between 0 and 1.
  40. * Relative error
  41. * arithmetic domain # trials peak rms
  42. * IEEE 0,5 10000 6.9e-15 4.5e-16
  43. * IEEE 0,85 250000 2.2e-13 1.7e-14
  44. * IEEE 0,1000 30000 5.3e-12 6.3e-13
  45. * IEEE 0,10000 250000 9.3e-11 7.1e-12
  46. * IEEE 0,100000 10000 8.7e-10 4.8e-11
  47. * Outputs smaller than the IEEE gradual underflow threshold
  48. * were excluded from these statistics.
  49. *
  50. * ERROR MESSAGES:
  51. * message condition value returned
  52. * incbet domain x<0, x>1 0.0
  53. * incbet underflow 0.0
  54. */
  55. /*
  56. Cephes Math Library, Release 2.8: June, 2000
  57. Copyright 1984, 1995, 2000 by Stephen L. Moshier
  58. */
  59. #include "mconf.h"
  60. #ifdef DEC
  61. #define MAXGAM 34.84425627277176174
  62. #else
  63. #define MAXGAM 171.624376956302725
  64. #endif
  65. extern double MACHEP, MINLOG, MAXLOG;
  66. #ifdef ANSIPROT
  67. extern double gamma(double);
  68. extern double lgam(double);
  69. extern double exp(double);
  70. extern double log(double);
  71. extern double pow(double, double);
  72. extern double fabs(double);
  73. static double incbcf(double, double, double);
  74. static double incbd(double, double, double);
  75. static double pseries(double, double, double);
  76. #else
  77. double gamma(), lgam(), exp(), log(), pow(), fabs();
  78. static double incbcf(), incbd(), pseries();
  79. #endif
  80. static double big = 4.503599627370496e15;
  81. static double biginv = 2.22044604925031308085e-16;
  82. double incbet(aa, bb, xx) double aa, bb, xx;
  83. {
  84. double a, b, t, x, xc, w, y;
  85. int flag;
  86. if (aa <= 0.0 || bb <= 0.0)
  87. goto domerr;
  88. if ((xx <= 0.0) || (xx >= 1.0)) {
  89. if (xx == 0.0)
  90. return (0.0);
  91. if (xx == 1.0)
  92. return (1.0);
  93. domerr:
  94. mtherr("incbet", DOMAIN);
  95. return (0.0);
  96. }
  97. flag = 0;
  98. if ((bb * xx) <= 1.0 && xx <= 0.95) {
  99. t = pseries(aa, bb, xx);
  100. goto done;
  101. }
  102. w = 1.0 - xx;
  103. /* Reverse a and b if x is greater than the mean. */
  104. if (xx > (aa / (aa + bb))) {
  105. flag = 1;
  106. a = bb;
  107. b = aa;
  108. xc = xx;
  109. x = w;
  110. } else {
  111. a = aa;
  112. b = bb;
  113. xc = w;
  114. x = xx;
  115. }
  116. if (flag == 1 && (b * x) <= 1.0 && x <= 0.95) {
  117. t = pseries(a, b, x);
  118. goto done;
  119. }
  120. /* Choose expansion for better convergence. */
  121. y = x * (a + b - 2.0) - (a - 1.0);
  122. if (y < 0.0)
  123. w = incbcf(a, b, x);
  124. else
  125. w = incbd(a, b, x) / xc;
  126. /* Multiply w by the factor
  127. a b _ _ _
  128. x (1-x) | (a+b) / ( a | (a) | (b) ) . */
  129. y = a * log(x);
  130. t = b * log(xc);
  131. if ((a + b) < MAXGAM && fabs(y) < MAXLOG && fabs(t) < MAXLOG) {
  132. t = pow(xc, b);
  133. t *= pow(x, a);
  134. t /= a;
  135. t *= w;
  136. t *= gamma(a + b) / (gamma(a) * gamma(b));
  137. goto done;
  138. }
  139. /* Resort to logarithms. */
  140. y += t + lgam(a + b) - lgam(a) - lgam(b);
  141. y += log(w / a);
  142. if (y < MINLOG)
  143. t = 0.0;
  144. else
  145. t = exp(y);
  146. done:
  147. if (flag == 1) {
  148. if (t <= MACHEP)
  149. t = 1.0 - MACHEP;
  150. else
  151. t = 1.0 - t;
  152. }
  153. return (t);
  154. }
  155. /* Continued fraction expansion #1
  156. * for incomplete beta integral
  157. */
  158. static double incbcf(a, b, x) double a, b, x;
  159. {
  160. double xk, pk, pkm1, pkm2, qk, qkm1, qkm2;
  161. double k1, k2, k3, k4, k5, k6, k7, k8;
  162. double r, t, ans, thresh;
  163. int n;
  164. k1 = a;
  165. k2 = a + b;
  166. k3 = a;
  167. k4 = a + 1.0;
  168. k5 = 1.0;
  169. k6 = b - 1.0;
  170. k7 = k4;
  171. k8 = a + 2.0;
  172. pkm2 = 0.0;
  173. qkm2 = 1.0;
  174. pkm1 = 1.0;
  175. qkm1 = 1.0;
  176. ans = 1.0;
  177. r = 1.0;
  178. n = 0;
  179. thresh = 3.0 * MACHEP;
  180. do {
  181. xk = -(x * k1 * k2) / (k3 * k4);
  182. pk = pkm1 + pkm2 * xk;
  183. qk = qkm1 + qkm2 * xk;
  184. pkm2 = pkm1;
  185. pkm1 = pk;
  186. qkm2 = qkm1;
  187. qkm1 = qk;
  188. xk = (x * k5 * k6) / (k7 * k8);
  189. pk = pkm1 + pkm2 * xk;
  190. qk = qkm1 + qkm2 * xk;
  191. pkm2 = pkm1;
  192. pkm1 = pk;
  193. qkm2 = qkm1;
  194. qkm1 = qk;
  195. if (qk != 0)
  196. r = pk / qk;
  197. if (r != 0) {
  198. t = fabs((ans - r) / r);
  199. ans = r;
  200. } else
  201. t = 1.0;
  202. if (t < thresh)
  203. goto cdone;
  204. k1 += 1.0;
  205. k2 += 1.0;
  206. k3 += 2.0;
  207. k4 += 2.0;
  208. k5 += 1.0;
  209. k6 -= 1.0;
  210. k7 += 2.0;
  211. k8 += 2.0;
  212. if ((fabs(qk) + fabs(pk)) > big) {
  213. pkm2 *= biginv;
  214. pkm1 *= biginv;
  215. qkm2 *= biginv;
  216. qkm1 *= biginv;
  217. }
  218. if ((fabs(qk) < biginv) || (fabs(pk) < biginv)) {
  219. pkm2 *= big;
  220. pkm1 *= big;
  221. qkm2 *= big;
  222. qkm1 *= big;
  223. }
  224. } while (++n < 300);
  225. cdone:
  226. return (ans);
  227. }
  228. /* Continued fraction expansion #2
  229. * for incomplete beta integral
  230. */
  231. static double incbd(a, b, x) double a, b, x;
  232. {
  233. double xk, pk, pkm1, pkm2, qk, qkm1, qkm2;
  234. double k1, k2, k3, k4, k5, k6, k7, k8;
  235. double r, t, ans, z, thresh;
  236. int n;
  237. k1 = a;
  238. k2 = b - 1.0;
  239. k3 = a;
  240. k4 = a + 1.0;
  241. k5 = 1.0;
  242. k6 = a + b;
  243. k7 = a + 1.0;
  244. ;
  245. k8 = a + 2.0;
  246. pkm2 = 0.0;
  247. qkm2 = 1.0;
  248. pkm1 = 1.0;
  249. qkm1 = 1.0;
  250. z = x / (1.0 - x);
  251. ans = 1.0;
  252. r = 1.0;
  253. n = 0;
  254. thresh = 3.0 * MACHEP;
  255. do {
  256. xk = -(z * k1 * k2) / (k3 * k4);
  257. pk = pkm1 + pkm2 * xk;
  258. qk = qkm1 + qkm2 * xk;
  259. pkm2 = pkm1;
  260. pkm1 = pk;
  261. qkm2 = qkm1;
  262. qkm1 = qk;
  263. xk = (z * k5 * k6) / (k7 * k8);
  264. pk = pkm1 + pkm2 * xk;
  265. qk = qkm1 + qkm2 * xk;
  266. pkm2 = pkm1;
  267. pkm1 = pk;
  268. qkm2 = qkm1;
  269. qkm1 = qk;
  270. if (qk != 0)
  271. r = pk / qk;
  272. if (r != 0) {
  273. t = fabs((ans - r) / r);
  274. ans = r;
  275. } else
  276. t = 1.0;
  277. if (t < thresh)
  278. goto cdone;
  279. k1 += 1.0;
  280. k2 -= 1.0;
  281. k3 += 2.0;
  282. k4 += 2.0;
  283. k5 += 1.0;
  284. k6 += 1.0;
  285. k7 += 2.0;
  286. k8 += 2.0;
  287. if ((fabs(qk) + fabs(pk)) > big) {
  288. pkm2 *= biginv;
  289. pkm1 *= biginv;
  290. qkm2 *= biginv;
  291. qkm1 *= biginv;
  292. }
  293. if ((fabs(qk) < biginv) || (fabs(pk) < biginv)) {
  294. pkm2 *= big;
  295. pkm1 *= big;
  296. qkm2 *= big;
  297. qkm1 *= big;
  298. }
  299. } while (++n < 300);
  300. cdone:
  301. return (ans);
  302. }
  303. /* Power series for incomplete beta integral.
  304. Use when b*x is small and x not too close to 1. */
  305. static double pseries(a, b, x) double a, b, x;
  306. {
  307. double s, t, u, v, n, t1, z, ai;
  308. ai = 1.0 / a;
  309. u = (1.0 - b) * x;
  310. v = u / (a + 1.0);
  311. t1 = v;
  312. t = u;
  313. n = 2.0;
  314. s = 0.0;
  315. z = MACHEP * ai;
  316. while (fabs(v) > z) {
  317. u = (n - b) * x / n;
  318. t *= u;
  319. v = t / (a + n);
  320. s += v;
  321. n += 1.0;
  322. }
  323. s += t1;
  324. s += ai;
  325. u = a * log(x);
  326. if ((a + b) < MAXGAM && fabs(u) < MAXLOG) {
  327. t = gamma(a + b) / (gamma(a) * gamma(b));
  328. s = s * t * pow(x, a);
  329. } else {
  330. t = lgam(a + b) - lgam(a) - lgam(b) + u + log(s);
  331. if (t < MINLOG)
  332. s = 0.0;
  333. else
  334. s = exp(t);
  335. }
  336. return (s);
  337. }