/src/igraph/src/random/random.c
Line | Count | Source (jump to first uncovered line) |
1 | | /* -*- mode: C -*- */ |
2 | | /* |
3 | | IGraph library. |
4 | | Copyright (C) 2005-2012 Gabor Csardi <csardi.gabor@gmail.com> |
5 | | 334 Harvard street, Cambridge, MA 02139 USA |
6 | | |
7 | | This program is free software; you can redistribute it and/or modify |
8 | | it under the terms of the GNU General Public License as published by |
9 | | the Free Software Foundation; either version 2 of the License, or |
10 | | (at your option) any later version. |
11 | | |
12 | | This program is distributed in the hope that it will be useful, |
13 | | but WITHOUT ANY WARRANTY; without even the implied warranty of |
14 | | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
15 | | GNU General Public License for more details. |
16 | | |
17 | | You should have received a copy of the GNU General Public License |
18 | | along with this program; if not, write to the Free Software |
19 | | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
20 | | 02110-1301 USA |
21 | | |
22 | | */ |
23 | | |
24 | | |
25 | | #include "igraph_random.h" |
26 | | |
27 | | #include "igraph_nongraph.h" |
28 | | #include "igraph_error.h" |
29 | | #include "igraph_types.h" |
30 | | #include "igraph_vector.h" |
31 | | |
32 | | #include "core/math.h" |
33 | | #include "math/safe_intop.h" |
34 | | #include "random/random_internal.h" |
35 | | |
36 | | #include "config.h" /* IGRAPH_THREAD_LOCAL, HAVE___UINT128_T, HAVE__UMUL128 */ |
37 | | |
38 | | #if defined(HAVE__UMUL128) || defined(HAVE___UMULH) |
39 | | #include <intrin.h> /* _umul128() or __umulh() are defined in intrin.h */ |
40 | | #endif |
41 | | |
42 | | #include <assert.h> |
43 | | #include <math.h> |
44 | | #include <float.h> /* DBL_MANT_DIG */ |
45 | | |
46 | | /** |
47 | | * \section about_rngs |
48 | | * |
49 | | * <section id="about-random-numbers-in-igraph"> |
50 | | * <title>About random numbers in igraph</title> |
51 | | * |
52 | | * <para> |
53 | | * Some algorithms in igraph, such as sampling from random graph models, |
54 | | * require random number generators (RNGs). igraph includes a flexible |
55 | | * RNG framework that allows hooking up arbitrary random number generators, |
56 | | * and comes with several ready-to-use generators. This framework is used |
57 | | * in igraph's high-level interfaces to integrate with the host language's |
58 | | * own RNG. |
59 | | * </para> |
60 | | * </section> |
61 | | * |
62 | | */ |
63 | | |
64 | | /** |
65 | | * \section rng_use_cases |
66 | | * |
67 | | * <section id="random-use-cases"><title>Use cases</title> |
68 | | * |
69 | | * <section id="random-normal-use"><title>Normal (default) use</title> |
70 | | * <para> |
71 | | * If the user does not use any of the RNG functions explicitly, but calls |
72 | | * some of the randomized igraph functions, then a default RNG is set |
73 | | * up the first time an igraph function needs random numbers. The |
74 | | * seed of this RNG is the output of the <code>time(0)</code> function |
75 | | * call, using the <code>time</code> function from the standard C |
76 | | * library. This ensures that igraph creates a different random graph, |
77 | | * each time the C program is called. |
78 | | * </para> |
79 | | * |
80 | | * <para> |
81 | | * The created default generator is stored internally and can be |
82 | | * queried with the \ref igraph_rng_default() function. |
83 | | * </para> |
84 | | * </section> |
85 | | * |
86 | | * <section id="random-reproducible-simulations"><title>Reproducible simulations</title> |
87 | | * <para> |
88 | | * If reproducible results are needed, then the user should set the |
89 | | * seed of the default random number generator explicitly, using the |
90 | | * \ref igraph_rng_seed() function on the default generator, \ref |
91 | | * igraph_rng_default(). When setting the seed to the same number, |
92 | | * igraph generates exactly the same random graph (or series of random |
93 | | * graphs). |
94 | | * </para> |
95 | | * </section> |
96 | | * |
97 | | * <section id="random-changing-default-generator"><title>Changing the default generator</title> |
98 | | * <para> |
99 | | * By default igraph uses the \ref igraph_rng_default() random number |
100 | | * generator. This can be changed any time by calling \ref |
101 | | * igraph_rng_set_default(), with an already initialized random number |
102 | | * generator. Note that the old (replaced) generator is not |
103 | | * destroyed, so no memory is deallocated. |
104 | | * </para> |
105 | | * </section> |
106 | | * |
107 | | * <section id="random-using-multiple-generators"><title>Using multiple generators</title> |
108 | | * <para> |
109 | | * igraph also provides functions to set up multiple random number |
110 | | * generators, using the \ref igraph_rng_init() function, and then |
111 | | * generating random numbers from them, e.g. with \ref igraph_rng_get_integer() |
112 | | * and/or \ref igraph_rng_get_unif() calls. |
113 | | * </para> |
114 | | * |
115 | | * <para> |
116 | | * Note that initializing a new random number generator is |
117 | | * independent of the generator that the igraph functions themselves |
118 | | * use. If you want to replace that, then please use \ref |
119 | | * igraph_rng_set_default(). |
120 | | * </para> |
121 | | * </section> |
122 | | * |
123 | | * <section id="random-example"><title>Example</title> |
124 | | * <para> |
125 | | * \example examples/simple/random_seed.c |
126 | | * </para> |
127 | | * </section> |
128 | | * |
129 | | * </section> |
130 | | */ |
131 | | |
132 | | /* ------------------------------------ */ |
133 | | |
134 | | /** |
135 | | * \var igraph_i_rng_default |
136 | | * The default igraph random number generator |
137 | | * |
138 | | * This generator is used by all builtin igraph functions that need to |
139 | | * generate random numbers; e.g. all random graph generators. |
140 | | * |
141 | | * You can use \ref igraph_i_rng_default with \ref igraph_rng_seed() |
142 | | * to set its seed. |
143 | | * |
144 | | * You can change the default generator using the \ref |
145 | | * igraph_rng_set_default() function. |
146 | | */ |
147 | | |
148 | | extern IGRAPH_THREAD_LOCAL igraph_rng_t igraph_i_rng_default; /* defined in rng_pcg32.c */ |
149 | | |
150 | | /** |
151 | | * \function igraph_rng_set_default |
152 | | * \brief Set the default igraph random number generator. |
153 | | * |
154 | | * This function \em copies the internal structure of the given \type igraph_rng_t |
155 | | * object to igraph's internal default RNG structure. The structure itself |
156 | | * contains two pointers only, one to the "methods" of the RNG and one to the |
157 | | * memory buffer holding the internal state of the RNG. This means that if you |
158 | | * keep on generating random numbers from the RNG after setting it as the |
159 | | * default, it will affect the state of the default RNG as well because the two |
160 | | * share the same state pointer. However, do \em not expect |
161 | | * \ref igraph_rng_default() to return the same pointer as the one you passed |
162 | | * in here - the state is shared, but the entire structure is not. |
163 | | * |
164 | | * \param rng The random number generator to use as default from now |
165 | | * on. Calling \ref igraph_rng_destroy() on it, while it is still |
166 | | * being used as the default will result in crashes and/or |
167 | | * unpredictable results. |
168 | | * |
169 | | * Time complexity: O(1). |
170 | | */ |
171 | | |
172 | 0 | void igraph_rng_set_default(igraph_rng_t *rng) { |
173 | 0 | igraph_i_rng_default = (*rng); |
174 | 0 | } |
175 | | |
176 | | |
177 | | /* ------------------------------------ */ |
178 | | |
179 | | /** |
180 | | * \function igraph_rng_default |
181 | | * \brief Query the default random number generator. |
182 | | * |
183 | | * \return A pointer to the default random number generator. |
184 | | * |
185 | | * \sa \ref igraph_rng_set_default() |
186 | | */ |
187 | | |
188 | 0 | igraph_rng_t *igraph_rng_default(void) { |
189 | 0 | return &igraph_i_rng_default; |
190 | 0 | } |
191 | | |
192 | | /* ------------------------------------ */ |
193 | | |
194 | | static igraph_uint_t igraph_i_rng_get_random_bits(igraph_rng_t *rng, uint8_t bits); |
195 | | static uint64_t igraph_i_rng_get_random_bits_uint64(igraph_rng_t *rng, uint8_t bits); |
196 | | |
197 | | static igraph_uint_t igraph_i_rng_get_uint(igraph_rng_t *rng); |
198 | | static igraph_uint_t igraph_i_rng_get_uint_bounded(igraph_rng_t *rng, igraph_uint_t range); |
199 | | |
200 | | static uint32_t igraph_i_rng_get_uint32(igraph_rng_t *rng); |
201 | | static uint32_t igraph_i_rng_get_uint32_bounded(igraph_rng_t *rng, uint32_t range); |
202 | | |
203 | | #if IGRAPH_INTEGER_SIZE == 64 |
204 | | static uint64_t igraph_i_rng_get_uint64(igraph_rng_t *rng); |
205 | | static uint64_t igraph_i_rng_get_uint64_bounded(igraph_rng_t *rng, uint64_t range); |
206 | | #endif |
207 | | |
208 | | static double igraph_i_norm_rand(igraph_rng_t *rng); |
209 | | static double igraph_i_exp_rand(igraph_rng_t *rng); |
210 | | static double igraph_i_rbinom(igraph_rng_t *rng, igraph_integer_t n, double pp); |
211 | | static double igraph_i_rexp(igraph_rng_t *rng, double rate); |
212 | | static double igraph_i_rgamma(igraph_rng_t *rng, double shape, double scale); |
213 | | static double igraph_i_rpois(igraph_rng_t *rng, double rate); |
214 | | |
215 | | /** |
216 | | * \function igraph_rng_init |
217 | | * \brief Initializes a random number generator. |
218 | | * |
219 | | * This function allocates memory for a random number generator, with |
220 | | * the given type, and sets its seed to the default. |
221 | | * |
222 | | * \param rng Pointer to an uninitialized RNG. |
223 | | * \param type The type of the RNG, such as \ref igraph_rngtype_mt19937, |
224 | | * \ref igraph_rngtype_glibc2, \ref igraph_rngtype_pcg32 or |
225 | | * \ref igraph_rngtype_pcg64. |
226 | | * \return Error code. |
227 | | */ |
228 | | |
229 | 0 | igraph_error_t igraph_rng_init(igraph_rng_t *rng, const igraph_rng_type_t *type) { |
230 | 0 | rng->type = type; |
231 | 0 | IGRAPH_CHECK(rng->type->init(&rng->state)); |
232 | 0 | return IGRAPH_SUCCESS; |
233 | 0 | } |
234 | | |
235 | | /** |
236 | | * \function igraph_rng_destroy |
237 | | * \brief Deallocates memory associated with a random number generator. |
238 | | * |
239 | | * \param rng The RNG to destroy. Do not destroy an RNG that is used |
240 | | * as the default igraph RNG. |
241 | | * |
242 | | * Time complexity: O(1). |
243 | | */ |
244 | | |
245 | 0 | void igraph_rng_destroy(igraph_rng_t *rng) { |
246 | 0 | rng->type->destroy(rng->state); |
247 | 0 | } |
248 | | |
249 | | /** |
250 | | * \function igraph_rng_seed |
251 | | * \brief Seeds a random number generator. |
252 | | * |
253 | | * \param rng The RNG. |
254 | | * \param seed The new seed. |
255 | | * \return Error code. |
256 | | * |
257 | | * Time complexity: usually O(1), but may depend on the type of the |
258 | | * RNG. |
259 | | */ |
260 | 0 | igraph_error_t igraph_rng_seed(igraph_rng_t *rng, igraph_uint_t seed) { |
261 | 0 | const igraph_rng_type_t *type = rng->type; |
262 | 0 | IGRAPH_CHECK(type->seed(rng->state, seed)); |
263 | 0 | rng->is_seeded = 1; |
264 | 0 | return IGRAPH_SUCCESS; |
265 | 0 | } |
266 | | |
267 | | /** |
268 | | * \function igraph_rng_bits |
269 | | * \brief The number of random bits that a random number generator can produces in a single round. |
270 | | * |
271 | | * \param rng The RNG. |
272 | | * \return The number of random bits that can be generated in a single round |
273 | | * with the RNG. |
274 | | * |
275 | | * Time complexity: O(1). |
276 | | */ |
277 | 0 | IGRAPH_EXPORT igraph_integer_t igraph_rng_bits(const igraph_rng_t* rng) { |
278 | 0 | return rng->type->bits; |
279 | 0 | } |
280 | | |
281 | | /** |
282 | | * \function igraph_rng_max |
283 | | * \brief The maximum possible integer for a random number generator. |
284 | | * |
285 | | * Note that this number is only for informational purposes; it returns the |
286 | | * maximum possible integer that can be generated with the RNG with a single |
287 | | * call to its internals. It is derived directly from the number of random |
288 | | * \em bits that the RNG can generate in a single round. When this is smaller |
289 | | * than what would be needed by other RNG functions like \ref igraph_rng_get_integer(), |
290 | | * igraph will call the RNG multiple times to generate more random bits. |
291 | | * |
292 | | * \param rng The RNG. |
293 | | * \return The largest possible integer that can be generated in a single round |
294 | | * with the RNG. |
295 | | * |
296 | | * Time complexity: O(1). |
297 | | */ |
298 | | |
299 | 0 | igraph_uint_t igraph_rng_max(const igraph_rng_t *rng) { |
300 | 0 | const igraph_rng_type_t *type = rng->type; |
301 | 0 | #if IGRAPH_INTEGER_SIZE == 64 |
302 | 0 | return (type->bits >= 64) ? 0xFFFFFFFFFFFFFFFFULL : ((1ULL << type->bits) - 1); |
303 | | #else |
304 | | return (type->bits >= 32) ? 0xFFFFFFFFUL : ((1ULL << type->bits) - 1); |
305 | | #endif |
306 | 0 | } |
307 | | |
308 | | /** |
309 | | * \function igraph_rng_name |
310 | | * \brief The type of a random number generator. |
311 | | * |
312 | | * \param rng The RNG. |
313 | | * \return The name of the type of the generator. Do not deallocate or |
314 | | * change the returned string. |
315 | | * |
316 | | * Time complexity: O(1). |
317 | | */ |
318 | | |
319 | 0 | const char *igraph_rng_name(const igraph_rng_t *rng) { |
320 | 0 | const igraph_rng_type_t *type = rng->type; |
321 | 0 | return type->name; |
322 | 0 | } |
323 | | |
324 | | /** |
325 | | * Generates a given number of random bits, possibly invoking the underlying |
326 | | * RNG multiple times if needed, and returns the result in an \c igraph_uint_t . |
327 | | * |
328 | | * \param rng The RNG. |
329 | | * \param bits The number of random bits needed. Must be smaller than or equal |
330 | | * to the size of the \c igraph_uint_t data type. Passing a value larger |
331 | | * than the size of \c igraph_uint_t will throw away random bits except |
332 | | * the last few that are needed to fill an \c igraph_uint_t . |
333 | | * \return The random bits, packed into the low bits of an \c igraph_uint_t . |
334 | | * The upper, unused bits of \c igraph_uint_t will be set to zero. |
335 | | */ |
336 | 0 | static igraph_uint_t igraph_i_rng_get_random_bits(igraph_rng_t *rng, uint8_t bits) { |
337 | 0 | const igraph_rng_type_t *type = rng->type; |
338 | 0 | igraph_integer_t rng_bitwidth = igraph_rng_bits(rng); |
339 | 0 | igraph_uint_t result; |
340 | |
|
341 | 0 | if (rng_bitwidth >= bits) { |
342 | | /* keep the high bits as RNGs sometimes tend to have lower entropy in |
343 | | * low bits than in high bits */ |
344 | 0 | result = type->get(rng->state) >> (rng_bitwidth - bits); |
345 | 0 | } else { |
346 | 0 | result = 0; |
347 | 0 | do { |
348 | 0 | result = (result << rng_bitwidth) + type->get(rng->state); |
349 | 0 | bits -= rng_bitwidth; |
350 | 0 | } while (bits > rng_bitwidth); |
351 | | |
352 | | /* and now the last piece */ |
353 | 0 | result = (result << bits) + (type->get(rng->state) >> (rng_bitwidth - bits)); |
354 | 0 | } |
355 | |
|
356 | 0 | return result; |
357 | 0 | } |
358 | | |
359 | | /** |
360 | | * Generates a given number of random bits, possibly invoking the underlying |
361 | | * RNG multiple times if needed, and returns the result in an \c uint64_t . |
362 | | * |
363 | | * Prefer \c igraph_i_rng_get_random_bits() if you know that you need at most |
364 | | * 32 bits due to the type of the return value. This function might perform |
365 | | * worse on 32-bit platforms because the result is always 64 bits. |
366 | | * |
367 | | * \param rng The RNG. |
368 | | * \param bits The number of random bits needed. Must be smaller than or equal |
369 | | * to the size of the \c uint64_t data type. Passing a value larger |
370 | | * than the size of \c uint64_t will throw away random bits except |
371 | | * the last few that are needed to fill an \c uint64_t . |
372 | | * \return The random bits, packed into the low bits of an \c uint64_t . |
373 | | * The upper, unused bits of \c uint64_t will be set to zero. |
374 | | */ |
375 | 0 | static uint64_t igraph_i_rng_get_random_bits_uint64(igraph_rng_t *rng, uint8_t bits) { |
376 | 0 | const igraph_rng_type_t *type = rng->type; |
377 | 0 | igraph_integer_t rng_bitwidth = igraph_rng_bits(rng); |
378 | 0 | uint64_t result; |
379 | |
|
380 | 0 | if (rng_bitwidth >= bits) { |
381 | | /* keep the high bits as RNGs sometimes tend to have lower entropy in |
382 | | * low bits than in high bits */ |
383 | 0 | result = type->get(rng->state) >> (rng_bitwidth - bits); |
384 | 0 | } else { |
385 | 0 | result = 0; |
386 | 0 | do { |
387 | 0 | result = (result << rng_bitwidth) + type->get(rng->state); |
388 | 0 | bits -= rng_bitwidth; |
389 | 0 | } while (bits > rng_bitwidth); |
390 | | |
391 | | /* and now the last piece */ |
392 | 0 | result = (result << bits) + (type->get(rng->state) >> (rng_bitwidth - bits)); |
393 | 0 | } |
394 | |
|
395 | 0 | return result; |
396 | 0 | } |
397 | | |
398 | | /** |
399 | | * Generates a random integer in the full range of the \c igraph_uint_t |
400 | | * data type. |
401 | | * |
402 | | * \param rng The RNG. |
403 | | * \return The random integer. |
404 | | */ |
405 | 0 | static igraph_uint_t igraph_i_rng_get_uint(igraph_rng_t *rng) { |
406 | 0 | return igraph_i_rng_get_random_bits(rng, sizeof(igraph_uint_t) * 8); |
407 | 0 | } |
408 | | |
409 | | /** |
410 | | * Generates a random integer in the full range of the \c uint32_t |
411 | | * data type. |
412 | | * |
413 | | * \param rng The RNG. |
414 | | * \return The random integer. |
415 | | */ |
416 | 0 | static uint32_t igraph_i_rng_get_uint32(igraph_rng_t *rng) { |
417 | 0 | return igraph_i_rng_get_random_bits(rng, 32); |
418 | 0 | } |
419 | | |
420 | | /** |
421 | | * Generates a random integer in the range [0; range) (upper bound exclusive), |
422 | | * restricted to at most 32 bits. |
423 | | * |
424 | | * \param rng The RNG. |
425 | | * \param range The upper bound (exclusive). |
426 | | * \return The random integer. |
427 | | */ |
428 | 0 | static uint32_t igraph_i_rng_get_uint32_bounded(igraph_rng_t *rng, uint32_t range) { |
429 | | /* Debiased integer multiplication -- Lemire's method |
430 | | * from https://www.pcg-random.org/posts/bounded-rands.html */ |
431 | 0 | uint32_t x, l, t = (-range) % range; |
432 | 0 | uint64_t m; |
433 | 0 | do { |
434 | 0 | x = igraph_i_rng_get_uint32(rng); |
435 | 0 | m = (uint64_t)(x) * (uint64_t)(range); |
436 | 0 | l = (uint32_t)m; |
437 | 0 | } while (l < t); |
438 | 0 | return m >> 32; |
439 | 0 | } |
440 | | |
441 | | #if IGRAPH_INTEGER_SIZE == 64 |
442 | | /** |
443 | | * Generates a random integer in the full range of the \c uint64_t |
444 | | * data type. |
445 | | * |
446 | | * \param rng The RNG. |
447 | | * \param range The upper bound (inclusive). |
448 | | * \return The random integer. |
449 | | */ |
450 | 0 | static uint64_t igraph_i_rng_get_uint64(igraph_rng_t *rng) { |
451 | 0 | return igraph_i_rng_get_random_bits(rng, 64); |
452 | 0 | } |
453 | | |
454 | | #if !defined(HAVE___UINT128_T) |
455 | | static uint64_t igraph_i_umul128(uint64_t a, uint64_t b, uint64_t *hi) { |
456 | | #if defined(HAVE__UMUL128) |
457 | | /* MSVC has _umul128() on x64 but not on arm64 */ |
458 | | return _umul128(a, b, hi); |
459 | | #elif defined(HAVE___UMULH) |
460 | | /* MSVC has __umulh() on arm64 */ |
461 | | *hi = __umulh(a, b); |
462 | | return a*b; |
463 | | #else |
464 | | /* Portable but slow fallback implementation of unsigned |
465 | | * 64-bit multiplication obtaining a 128-bit result. |
466 | | * Based on https://stackoverflow.com/a/28904636/695132 |
467 | | */ |
468 | | |
469 | | uint64_t a_lo = (uint32_t) a; |
470 | | uint64_t a_hi = a >> 32; |
471 | | uint64_t b_lo = (uint32_t) b; |
472 | | uint64_t b_hi = b >> 32; |
473 | | |
474 | | uint64_t a_x_b_hi = a_hi * b_hi; |
475 | | uint64_t a_x_b_mid = a_hi * b_lo; |
476 | | uint64_t b_x_a_mid = b_hi * a_lo; |
477 | | uint64_t a_x_b_lo = a_lo * b_lo; |
478 | | |
479 | | uint64_t carry_bit = ((uint64_t) (uint32_t) a_x_b_mid + |
480 | | (uint64_t) (uint32_t) b_x_a_mid + |
481 | | (a_x_b_lo >> 32) ) >> 32; |
482 | | |
483 | | *hi = a_x_b_hi + |
484 | | (a_x_b_mid >> 32) + (b_x_a_mid >> 32) + |
485 | | carry_bit; |
486 | | |
487 | | return a*b; |
488 | | #endif |
489 | | } |
490 | | #endif /* !defined(HAVE___UINT128_T) */ |
491 | | |
492 | | /** |
493 | | * Generates a random integer in the range [0; range) (upper bound exclusive), |
494 | | * restricted to at most 64 bits. |
495 | | * |
496 | | * \param rng The RNG. |
497 | | * \param range The upper bound (exclusive). |
498 | | * \return The random integer. |
499 | | */ |
500 | 0 | static uint64_t igraph_i_rng_get_uint64_bounded(igraph_rng_t *rng, uint64_t range) { |
501 | | /* Debiased integer multiplication -- Lemire's method |
502 | | * from https://www.pcg-random.org/posts/bounded-rands.html */ |
503 | 0 | uint64_t x, l, t = (-range) % range; |
504 | 0 | #if defined(HAVE___UINT128_T) |
505 | | /* gcc and clang have __uint128_t */ |
506 | 0 | __uint128_t m; |
507 | 0 | do { |
508 | 0 | x = igraph_i_rng_get_uint64(rng); |
509 | 0 | m = (__uint128_t)(x) * (__uint128_t)(range); |
510 | 0 | l = (uint64_t)m; |
511 | 0 | } while (l < t); |
512 | 0 | return m >> 64; |
513 | | #else |
514 | | uint64_t hi; |
515 | | do { |
516 | | x = igraph_i_rng_get_uint64(rng); |
517 | | l = igraph_i_umul128(x, range, &hi); |
518 | | } while (l < t); |
519 | | return hi; |
520 | | #endif |
521 | 0 | } |
522 | | |
523 | | #endif /* IGRAPH_INTEGER_SIZE == 64 */ |
524 | | |
525 | | /** |
526 | | * Generates a random integer in the range [0; range) (upper bound exclusive). |
527 | | * |
528 | | * \param rng The RNG. |
529 | | * \param range The upper bound (exclusive). |
530 | | * \return The random integer. |
531 | | */ |
532 | 0 | static igraph_uint_t igraph_i_rng_get_uint_bounded(igraph_rng_t *rng, igraph_uint_t range) { |
533 | | /* We must make this function behave the same way for range < 2^32 so igraph |
534 | | * behaves the same way on 32-bit and 64-bit platforms as long as we stick |
535 | | * to integers less than 2^32. This is to ensure that the unit tests are |
536 | | * consistent */ |
537 | |
|
538 | | #if IGRAPH_INTEGER_SIZE == 32 |
539 | | return igraph_i_rng_get_uint32_bounded(rng, range); |
540 | | #else |
541 | 0 | if (range <= UINT32_MAX) { |
542 | 0 | return igraph_i_rng_get_uint32_bounded(rng, range); |
543 | 0 | } else { |
544 | 0 | return igraph_i_rng_get_uint64_bounded(rng, range); |
545 | 0 | } |
546 | 0 | #endif |
547 | 0 | } |
548 | | |
549 | | /** |
550 | | * \function igraph_rng_get_integer |
551 | | * \brief Generate an integer random number from an interval. |
552 | | * |
553 | | * \param rng Pointer to the RNG to use for the generation. Use \ref |
554 | | * igraph_rng_default() here to use the default igraph RNG. |
555 | | * \param l Lower limit, inclusive, it can be negative as well. |
556 | | * \param h Upper limit, inclusive, it can be negative as well, but it |
557 | | * should be at least <code>l</code>. |
558 | | * \return The generated random integer. |
559 | | * |
560 | | * Time complexity: O(log2(h-l) / bits) where bits is the value of |
561 | | * \ref igraph_rng_bits(rng). |
562 | | */ |
563 | | |
564 | | igraph_integer_t igraph_rng_get_integer( |
565 | | igraph_rng_t *rng, igraph_integer_t l, igraph_integer_t h |
566 | 0 | ) { |
567 | 0 | const igraph_rng_type_t *type = rng->type; |
568 | 0 | igraph_uint_t range; |
569 | |
|
570 | 0 | assert(h >= l); |
571 | | |
572 | 0 | if (h == l) { |
573 | 0 | return l; |
574 | 0 | } |
575 | | |
576 | 0 | if (type->get_int) { |
577 | 0 | return type->get_int(rng->state, l, h); |
578 | 0 | } |
579 | | |
580 | 0 | if (IGRAPH_UNLIKELY(l == IGRAPH_INTEGER_MIN && h == IGRAPH_INTEGER_MAX)) { |
581 | | /* Full uint range is needed, we can just grab a random number from |
582 | | * the uint range and cast it to a signed integer */ |
583 | 0 | return (igraph_integer_t) igraph_i_rng_get_uint(rng); |
584 | 0 | } else if (l >= 0 || h < 0) { |
585 | | /* this is okay, (h - l) will not overflow an igraph_integer_t */ |
586 | 0 | range = (igraph_uint_t)(h - l) + 1; |
587 | 0 | } else { |
588 | | /* (h - l) could potentially overflow so we need to play it safe. If we |
589 | | * are here, l < 0 and h >= 0 so we can cast -l into an igraph_uint_t |
590 | | * safely and do the subtraction that way */ |
591 | 0 | range = ((igraph_uint_t)(h)) + ((igraph_uint_t)(-l)) + 1; |
592 | 0 | } |
593 | | |
594 | 0 | return l + igraph_i_rng_get_uint_bounded(rng, range); |
595 | 0 | } |
596 | | |
597 | | /** |
598 | | * \function igraph_rng_get_normal |
599 | | * \brief Samples from a normal distribution. |
600 | | * |
601 | | * Generates random variates from a normal distribution with probability |
602 | | * density |
603 | | * |
604 | | * </para><para> |
605 | | * <code>exp( -(x - m)^2 / (2 s^2) )</code>. |
606 | | * |
607 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
608 | | * here to use the default igraph RNG. |
609 | | * \param m The mean. |
610 | | * \param s The standard deviation. |
611 | | * \return The generated normally distributed random number. |
612 | | * |
613 | | * Time complexity: depends on the type of the RNG. |
614 | | */ |
615 | | |
616 | | igraph_real_t igraph_rng_get_normal(igraph_rng_t *rng, |
617 | 0 | igraph_real_t m, igraph_real_t s) { |
618 | 0 | const igraph_rng_type_t *type = rng->type; |
619 | 0 | if (type->get_norm) { |
620 | 0 | return type->get_norm(rng->state) * s + m; |
621 | 0 | } else { |
622 | 0 | return igraph_i_norm_rand(rng) * s + m; |
623 | 0 | } |
624 | 0 | } |
625 | | |
626 | | /** |
627 | | * \function igraph_rng_get_unif |
628 | | * \brief Samples real numbers from a given interval. |
629 | | * |
630 | | * Generates uniformly distributed real numbers from the <code>[l, h)</code> |
631 | | * half-open interval. |
632 | | * |
633 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
634 | | * here to use the default igraph RNG. |
635 | | * \param l The lower bound, it can be negative. |
636 | | * \param h The upper bound, it can be negative, but it has to be |
637 | | * larger than the lower bound. |
638 | | * \return The generated uniformly distributed random number. |
639 | | * |
640 | | * Time complexity: depends on the type of the RNG. |
641 | | */ |
642 | | |
643 | | igraph_real_t igraph_rng_get_unif(igraph_rng_t *rng, |
644 | 0 | igraph_real_t l, igraph_real_t h) { |
645 | 0 | assert(h >= l); |
646 | | |
647 | 0 | if (l == h) return h; |
648 | | |
649 | | /* Ensure that 'h' is never produced due to numerical roundoff errors, except when l == h. */ |
650 | 0 | igraph_real_t r; |
651 | 0 | do { |
652 | 0 | r = igraph_rng_get_unif01(rng) * (h - l) + l; |
653 | 0 | } while (IGRAPH_UNLIKELY(r == h)); |
654 | 0 | return r; |
655 | 0 | } |
656 | | |
657 | | /** |
658 | | * \function igraph_rng_get_unif01 |
659 | | * \brief Samples uniformly from the unit interval. |
660 | | * |
661 | | * Generates uniformly distributed real numbers from the <code>[0, 1)</code> |
662 | | * half-open interval. |
663 | | * |
664 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
665 | | * here to use the default igraph RNG. |
666 | | * \return The generated uniformly distributed random number. |
667 | | * |
668 | | * Time complexity: depends on the type of the RNG. |
669 | | */ |
670 | | |
671 | 0 | igraph_real_t igraph_rng_get_unif01(igraph_rng_t *rng) { |
672 | 0 | const igraph_rng_type_t *type = rng->type; |
673 | 0 | if (type->get_real) { |
674 | 0 | return type->get_real(rng->state); |
675 | 0 | } else { |
676 | | /* We extract 52 random bits from a 64-bit uint and fill that directly |
677 | | * into the mantissa of a double, bit-by-bit, clear the sign bit and |
678 | | * set the exponent to 2^0. This way we get a 52-bit random double |
679 | | * between 1 (inclusive) and 2 (exclusive), uniformly distributed. |
680 | | * Then we subtract 1 to arrive at the [0; 1) interval. This is fast |
681 | | * but we lose one bit of precision as there are 2^53 possible doubles |
682 | | * between 0 and 1. */ |
683 | 0 | uint64_t r = (igraph_i_rng_get_random_bits_uint64(rng, 52) & 0xFFFFFFFFFFFFFull) | 0x3FF0000000000000ull; |
684 | 0 | return *(double *)(&r) - 1.0; |
685 | 0 | } |
686 | 0 | } |
687 | | |
688 | | /** |
689 | | * \function igraph_rng_get_geom |
690 | | * \brief Samples from a geometric distribution. |
691 | | * |
692 | | * Generates random variates from a geometric distribution. The number \c k is |
693 | | * generated with probability |
694 | | * |
695 | | * </para><para> |
696 | | * <code>(1 - p)^k p</code>, <code>k = 0, 1, 2, ...</code>. |
697 | | * |
698 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
699 | | * here to use the default igraph RNG. |
700 | | * \param p The probability of success in each trial. Must be larger |
701 | | * than zero and smaller or equal to 1. |
702 | | * \return The generated geometrically distributed random number. |
703 | | * |
704 | | * Time complexity: depends on the RNG. |
705 | | */ |
706 | | |
707 | 0 | igraph_real_t igraph_rng_get_geom(igraph_rng_t *rng, igraph_real_t p) { |
708 | 0 | const igraph_rng_type_t *type = rng->type; |
709 | 0 | if (!isfinite(p) || p <= 0 || p > 1) { |
710 | 0 | return IGRAPH_NAN; |
711 | 0 | } |
712 | 0 | if (type->get_geom) { |
713 | 0 | return type->get_geom(rng->state, p); |
714 | 0 | } else { |
715 | 0 | return igraph_rng_get_pois(rng, igraph_i_exp_rand(rng) * ((1 - p) / p)); |
716 | 0 | } |
717 | 0 | } |
718 | | |
719 | | /** |
720 | | * \function igraph_rng_get_binom |
721 | | * \brief Samples from a binomial distribution. |
722 | | * |
723 | | * Generates random variates from a binomial distribution. The number \c k is generated |
724 | | * with probability |
725 | | * |
726 | | * </para><para> |
727 | | * <code>(n \choose k) p^k (1-p)^(n-k)</code>, <code>k = 0, 1, ..., n</code>. |
728 | | * |
729 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
730 | | * here to use the default igraph RNG. |
731 | | * \param n Number of observations. |
732 | | * \param p Probability of an event. |
733 | | * \return The generated binomially distributed random number. |
734 | | * |
735 | | * Time complexity: depends on the RNG. |
736 | | */ |
737 | | |
738 | 0 | igraph_real_t igraph_rng_get_binom(igraph_rng_t *rng, igraph_integer_t n, igraph_real_t p) { |
739 | 0 | const igraph_rng_type_t *type = rng->type; |
740 | 0 | if (type->get_binom) { |
741 | 0 | return type->get_binom(rng->state, n, p); |
742 | 0 | } else { |
743 | 0 | return igraph_i_rbinom(rng, n, p); |
744 | 0 | } |
745 | 0 | } |
746 | | |
747 | | /** |
748 | | * \function igraph_rng_get_gamma |
749 | | * \brief Samples from a gamma distribution. |
750 | | * |
751 | | * Generates random variates from a gamma distribution with probability |
752 | | * density proportional to |
753 | | * |
754 | | * </para><para> |
755 | | * <code>x^(shape-1) exp(-x / scale)</code>. |
756 | | * |
757 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
758 | | * here to use the default igraph RNG. |
759 | | * \param shape Shape parameter. |
760 | | * \param scale Scale parameter. |
761 | | * \return The generated sample. |
762 | | * |
763 | | * Time complexity: depends on the RNG. |
764 | | */ |
765 | | |
766 | | igraph_real_t igraph_rng_get_gamma(igraph_rng_t *rng, igraph_real_t shape, |
767 | 0 | igraph_real_t scale) { |
768 | 0 | const igraph_rng_type_t *type = rng->type; |
769 | 0 | if (type->get_gamma) { |
770 | 0 | return type->get_gamma(rng->state, shape, scale); |
771 | 0 | } else { |
772 | 0 | return igraph_i_rgamma(rng, shape, scale); |
773 | 0 | } |
774 | 0 | } |
775 | | |
776 | | /** |
777 | | * \function igraph_rng_get_exp |
778 | | * \brief Samples from an exponential distribution. |
779 | | * |
780 | | * Generates random variates from an exponential distribution with probability |
781 | | * density proportional to |
782 | | * |
783 | | * </para><para> |
784 | | * <code>exp(-rate x)</code>. |
785 | | * |
786 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
787 | | * here to use the default igraph RNG. |
788 | | * \param rate Rate parameter. |
789 | | * \return The generated sample. |
790 | | * |
791 | | * Time complexity: depends on the RNG. |
792 | | */ |
793 | | |
794 | 0 | igraph_real_t igraph_rng_get_exp(igraph_rng_t *rng, igraph_real_t rate) { |
795 | 0 | const igraph_rng_type_t *type = rng->type; |
796 | 0 | if (type->get_exp) { |
797 | 0 | return type->get_exp(rng->state, rate); |
798 | 0 | } else { |
799 | 0 | return igraph_i_rexp(rng, rate); |
800 | 0 | } |
801 | 0 | } |
802 | | |
803 | | /** |
804 | | * \function igraph_rng_get_pois |
805 | | * \brief Samples from a Poisson distribution. |
806 | | * |
807 | | * Generates random variates from a Poisson distribution. The number \c k is generated |
808 | | * with probability |
809 | | * |
810 | | * </para><para> |
811 | | * <code>rate^k * exp(-rate) / k!</code>, <code>k = 0, 1, 2, ...</code>. |
812 | | * |
813 | | * \param rng Pointer to the RNG to use. Use \ref igraph_rng_default() |
814 | | * here to use the default igraph RNG. |
815 | | * \param rate The rate parameter of the Poisson distribution. Must not be negative. |
816 | | * \return The generated geometrically distributed random number. |
817 | | * |
818 | | * Time complexity: depends on the RNG. |
819 | | */ |
820 | | |
821 | 0 | igraph_real_t igraph_rng_get_pois(igraph_rng_t *rng, igraph_real_t rate) { |
822 | 0 | const igraph_rng_type_t *type = rng->type; |
823 | 0 | if (isnan(rate) || rate < 0) { |
824 | 0 | return IGRAPH_NAN; |
825 | 0 | } else if (rate == 0) { |
826 | 0 | return 0; |
827 | 0 | } else if (type->get_pois) { |
828 | 0 | return type->get_pois(rng->state, rate); |
829 | 0 | } else { |
830 | 0 | return igraph_i_rpois(rng, rate); |
831 | 0 | } |
832 | 0 | } |
833 | | |
834 | | |
835 | | /** |
836 | | * \ingroup internal |
837 | | * |
838 | | * This function appends the rest of the needed random numbers to the |
839 | | * result vector. It is Algoirthm A in Vitter's paper. |
840 | | */ |
841 | | |
842 | | static void igraph_i_random_sample_alga(igraph_vector_int_t *res, |
843 | | igraph_integer_t l, igraph_integer_t h, |
844 | 0 | igraph_integer_t length) { |
845 | | /* Vitter: Variables V, quot, Nreal, and top are of type real */ |
846 | |
|
847 | 0 | igraph_integer_t N = h - l + 1; |
848 | 0 | igraph_integer_t n = length; |
849 | |
|
850 | 0 | igraph_real_t top = N - n; |
851 | 0 | igraph_real_t Nreal = N; |
852 | 0 | igraph_integer_t S = 0; |
853 | 0 | igraph_real_t V, quot; |
854 | |
|
855 | 0 | l = l - 1; |
856 | |
|
857 | 0 | while (n >= 2) { |
858 | 0 | V = RNG_UNIF01(); |
859 | 0 | S = 1; |
860 | 0 | quot = top / Nreal; |
861 | 0 | while (quot > V) { |
862 | 0 | S += 1; |
863 | 0 | top = -1.0 + top; |
864 | 0 | Nreal = -1.0 + Nreal; |
865 | 0 | quot = (quot * top) / Nreal; |
866 | 0 | } |
867 | 0 | l += S; |
868 | 0 | igraph_vector_int_push_back(res, l); /* allocated */ |
869 | 0 | Nreal = -1.0 + Nreal; n = -1 + n; |
870 | 0 | } |
871 | |
|
872 | 0 | S = trunc(round(Nreal) * RNG_UNIF01()); |
873 | 0 | l += S + 1; |
874 | 0 | igraph_vector_int_push_back(res, l); /* allocated */ |
875 | 0 | } |
876 | | |
877 | | /** |
878 | | * \ingroup nongraph |
879 | | * \function igraph_random_sample |
880 | | * \brief Generates an increasing random sequence of integers. |
881 | | * |
882 | | * This function generates an increasing sequence of random integer |
883 | | * numbers from a given interval. The algorithm is taken literally |
884 | | * from (Vitter 1987). This method can be used for generating numbers from a |
885 | | * \em very large interval. It is primarily created for randomly |
886 | | * selecting some edges from the sometimes huge set of possible edges |
887 | | * in a large graph. |
888 | | * |
889 | | * </para><para> |
890 | | * Reference: |
891 | | * |
892 | | * </para><para> |
893 | | * J. S. Vitter. An efficient algorithm for sequential random sampling. |
894 | | * ACM Transactions on Mathematical Software, 13(1):58--67, 1987. |
895 | | * https://doi.org/10.1145/23002.23003 |
896 | | * |
897 | | * \param res Pointer to an initialized vector. This will hold the |
898 | | * result. It will be resized to the proper size. |
899 | | * \param l The lower limit of the generation interval (inclusive). This must |
900 | | * be less than or equal to the upper limit, and it must be integral. |
901 | | * \param h The upper limit of the generation interval (inclusive). This must |
902 | | * be greater than or equal to the lower limit, and it must be integral. |
903 | | * \param length The number of random integers to generate. |
904 | | * \return The error code \c IGRAPH_EINVAL is returned in each of the |
905 | | * following cases: (1) The given lower limit is greater than the |
906 | | * given upper limit, i.e. \c l > \c h. (2) Assuming that |
907 | | * \c l < \c h and N is the sample size, the above error code is |
908 | | * returned if N > |\c h - \c l|, i.e. the sample size exceeds the |
909 | | * size of the candidate pool. |
910 | | * |
911 | | * Time complexity: according to (Vitter 1987), the expected |
912 | | * running time is O(length). |
913 | | * |
914 | | * \example examples/simple/igraph_random_sample.c |
915 | | */ |
916 | | |
917 | | igraph_error_t igraph_random_sample(igraph_vector_int_t *res, igraph_integer_t l, igraph_integer_t h, |
918 | 0 | igraph_integer_t length) { |
919 | 0 | igraph_integer_t N; /* := h - l + 1 */ |
920 | 0 | IGRAPH_SAFE_ADD(h, -l, &N); |
921 | 0 | IGRAPH_SAFE_ADD(N, 1, &N); |
922 | | |
923 | 0 | igraph_integer_t n = length; |
924 | |
|
925 | 0 | igraph_real_t nreal = length; |
926 | 0 | igraph_real_t ninv = (nreal != 0) ? 1.0 / nreal : 0.0; |
927 | 0 | igraph_real_t Nreal = N; |
928 | 0 | igraph_real_t Vprime; |
929 | 0 | igraph_integer_t qu1 = -n + 1 + N; |
930 | 0 | igraph_real_t qu1real = -nreal + 1.0 + Nreal; |
931 | 0 | igraph_real_t negalphainv = -13; |
932 | 0 | igraph_real_t threshold = -negalphainv * n; |
933 | 0 | igraph_integer_t S; |
934 | | |
935 | | /* getting back some sense of sanity */ |
936 | 0 | if (l > h) { |
937 | 0 | IGRAPH_ERROR("Lower limit is greater than upper limit.", IGRAPH_EINVAL); |
938 | 0 | } |
939 | | /* now we know that l <= h */ |
940 | 0 | if (length > N) { |
941 | 0 | IGRAPH_ERROR("Sample size exceeds size of candidate pool.", IGRAPH_EINVAL); |
942 | 0 | } |
943 | | |
944 | | /* treat rare cases quickly */ |
945 | 0 | if (l == h) { |
946 | 0 | IGRAPH_CHECK(igraph_vector_int_resize(res, 1)); |
947 | 0 | VECTOR(*res)[0] = l; |
948 | 0 | return IGRAPH_SUCCESS; |
949 | 0 | } |
950 | 0 | if (length == 0) { |
951 | 0 | igraph_vector_int_clear(res); |
952 | 0 | return IGRAPH_SUCCESS; |
953 | 0 | } |
954 | 0 | if (length == N) { |
955 | 0 | IGRAPH_CHECK(igraph_vector_int_resize(res, length)); |
956 | 0 | for (igraph_integer_t i = 0; i < length; i++) { |
957 | 0 | VECTOR(*res)[i] = l++; |
958 | 0 | } |
959 | 0 | return IGRAPH_SUCCESS; |
960 | 0 | } |
961 | | |
962 | 0 | igraph_vector_int_clear(res); |
963 | 0 | IGRAPH_CHECK(igraph_vector_int_reserve(res, length)); |
964 | | |
965 | 0 | RNG_BEGIN(); |
966 | |
|
967 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
968 | 0 | l = l - 1; |
969 | |
|
970 | 0 | while (n > 1 && threshold < N) { |
971 | 0 | igraph_real_t X, U; |
972 | 0 | igraph_real_t limit, t; |
973 | 0 | igraph_real_t negSreal, y1, y2, top, bottom; |
974 | 0 | igraph_real_t nmin1inv = 1.0 / (-1.0 + nreal); |
975 | 0 | while (1) { |
976 | 0 | while (1) { |
977 | 0 | X = Nreal * (-Vprime + 1.0); |
978 | 0 | S = floor(X); |
979 | | /* if (S==0) { S=1; } */ |
980 | 0 | if (S < qu1) { |
981 | 0 | break; |
982 | 0 | } |
983 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
984 | 0 | } |
985 | 0 | U = RNG_UNIF01(); |
986 | 0 | negSreal = -S; |
987 | |
|
988 | 0 | y1 = exp(log(U * Nreal / qu1real) * nmin1inv); |
989 | 0 | Vprime = y1 * (-X / Nreal + 1.0) * (qu1real / (negSreal + qu1real)); |
990 | 0 | if (Vprime <= 1.0) { |
991 | 0 | break; |
992 | 0 | } |
993 | | |
994 | 0 | y2 = 1.0; |
995 | 0 | top = -1.0 + Nreal; |
996 | 0 | if (-1 + n > S) { |
997 | 0 | bottom = -nreal + Nreal; |
998 | 0 | limit = -S + N; |
999 | 0 | } else { |
1000 | 0 | bottom = -1.0 + negSreal + Nreal; |
1001 | 0 | limit = qu1; |
1002 | 0 | } |
1003 | 0 | for (t = -1 + N; t >= limit; t--) { |
1004 | 0 | y2 = (y2 * top) / bottom; |
1005 | 0 | top = -1.0 + top; |
1006 | 0 | bottom = -1.0 + bottom; |
1007 | 0 | } |
1008 | 0 | if (Nreal / (-X + Nreal) >= y1 * exp(log(y2)*nmin1inv)) { |
1009 | 0 | Vprime = exp(log(RNG_UNIF01()) * nmin1inv); |
1010 | 0 | break; |
1011 | 0 | } |
1012 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
1013 | 0 | } |
1014 | |
|
1015 | 0 | l += S + 1; |
1016 | 0 | igraph_vector_int_push_back(res, l); /* allocated */ |
1017 | 0 | N = -S + (-1 + N); Nreal = negSreal + (-1.0 + Nreal); |
1018 | 0 | n = -1 + n; nreal = -1.0 + nreal; ninv = nmin1inv; |
1019 | 0 | qu1 = -S + qu1; qu1real = negSreal + qu1real; |
1020 | 0 | threshold = threshold + negalphainv; |
1021 | 0 | } |
1022 | |
|
1023 | 0 | if (n > 1) { |
1024 | 0 | igraph_i_random_sample_alga(res, l + 1, h, n); |
1025 | 0 | } else { |
1026 | 0 | S = floor(N * Vprime); |
1027 | 0 | l += S + 1; |
1028 | 0 | igraph_vector_int_push_back(res, l); /* allocated */ |
1029 | 0 | } |
1030 | |
|
1031 | 0 | RNG_END(); |
1032 | |
|
1033 | 0 | return IGRAPH_SUCCESS; |
1034 | 0 | } |
1035 | | |
1036 | | static void igraph_i_random_sample_alga_real(igraph_vector_t *res, |
1037 | | igraph_real_t l, igraph_real_t h, |
1038 | 0 | igraph_real_t length) { |
1039 | 0 | igraph_real_t N = h - l + 1; |
1040 | 0 | igraph_real_t n = length; |
1041 | |
|
1042 | 0 | igraph_real_t top = N - n; |
1043 | 0 | igraph_real_t Nreal = N; |
1044 | 0 | igraph_real_t S = 0; |
1045 | 0 | igraph_real_t V, quot; |
1046 | |
|
1047 | 0 | l = l - 1; |
1048 | |
|
1049 | 0 | while (n >= 2) { |
1050 | 0 | V = RNG_UNIF01(); |
1051 | 0 | S = 1; |
1052 | 0 | quot = top / Nreal; |
1053 | 0 | while (quot > V) { |
1054 | 0 | S += 1; |
1055 | 0 | top = -1.0 + top; |
1056 | 0 | Nreal = -1.0 + Nreal; |
1057 | 0 | quot = (quot * top) / Nreal; |
1058 | 0 | } |
1059 | 0 | l += S; |
1060 | 0 | igraph_vector_push_back(res, l); /* allocated */ |
1061 | 0 | Nreal = -1.0 + Nreal; n = -1 + n; |
1062 | 0 | } |
1063 | |
|
1064 | 0 | S = trunc(round(Nreal) * RNG_UNIF01()); |
1065 | 0 | l += S + 1; |
1066 | 0 | igraph_vector_push_back(res, l); /* allocated */ |
1067 | 0 | } |
1068 | | |
1069 | | /** |
1070 | | * \ingroup nongraph |
1071 | | * \function igraph_random_sample_real |
1072 | | * \brief Generates an increasing random sequence of integers (igraph_real_t version). |
1073 | | * |
1074 | | * This function is the 'real' version of \ref igraph_random_sample(), and was added |
1075 | | * so \ref igraph_erdos_renyi_game_gnm() and related functions can use a random sample |
1076 | | * of doubles instead of integers to prevent overflows on systems with 32-bit |
1077 | | * \type igraph_integer_t. |
1078 | | * |
1079 | | * \param res Pointer to an initialized vector. This will hold the |
1080 | | * result. It will be resized to the proper size. |
1081 | | * \param l The lower limit of the generation interval (inclusive). This must |
1082 | | * be less than or equal to the upper limit, and it must be integral. |
1083 | | * Passing a fractional number here results in undefined behaviour. |
1084 | | * \param h The upper limit of the generation interval (inclusive). This must |
1085 | | * be greater than or equal to the lower limit, and it must be integral. |
1086 | | * Passing a fractional number here results in undefined behaviour. |
1087 | | * \param length The number of random integers to generate. |
1088 | | * \return The error code \c IGRAPH_EINVAL is returned in each of the |
1089 | | * following cases: (1) The given lower limit is greater than the |
1090 | | * given upper limit, i.e. \c l > \c h. (2) Assuming that |
1091 | | * \c l < \c h and N is the sample size, the above error code is |
1092 | | * returned if N > |\c h - \c l|, i.e. the sample size exceeds the |
1093 | | * size of the candidate pool. |
1094 | | */ |
1095 | | |
1096 | | igraph_error_t igraph_random_sample_real(igraph_vector_t *res, igraph_real_t l, |
1097 | 0 | igraph_real_t h, igraph_integer_t length) { |
1098 | | /* This function is the 'real' version of igraph_random_sample, and was added |
1099 | | * so erdos_renyi_game_gnm can use a random sample of doubles instead of integers |
1100 | | * to prevent overflows on systems with 32-bits igraph_integer_t. |
1101 | | */ |
1102 | 0 | igraph_real_t N = h - l + 1; |
1103 | 0 | igraph_real_t n = length; |
1104 | |
|
1105 | 0 | igraph_real_t nreal = length; |
1106 | 0 | igraph_real_t ninv = (nreal != 0) ? 1.0 / nreal : 0.0; |
1107 | 0 | igraph_real_t Nreal = N; |
1108 | 0 | igraph_real_t Vprime; |
1109 | 0 | igraph_real_t qu1 = -n + 1 + N; |
1110 | 0 | igraph_real_t qu1real = -nreal + 1.0 + Nreal; |
1111 | 0 | igraph_real_t negalphainv = -13; |
1112 | 0 | igraph_real_t threshold = -negalphainv * n; |
1113 | 0 | igraph_real_t S; |
1114 | | |
1115 | | /* getting back some sense of sanity */ |
1116 | 0 | if (l > h) { |
1117 | 0 | IGRAPH_ERROR("Lower limit is greater than upper limit.", IGRAPH_EINVAL); |
1118 | 0 | } |
1119 | | /* now we know that l <= h */ |
1120 | 0 | if (length > N) { |
1121 | 0 | IGRAPH_ERROR("Sample size exceeds size of candidate pool.", IGRAPH_EINVAL); |
1122 | 0 | } |
1123 | | |
1124 | | /* ensure that we work in the range where igraph_real_t can represent integers exactly */ |
1125 | 0 | if (h > IGRAPH_MAX_EXACT_REAL || l < -IGRAPH_MAX_EXACT_REAL || N > IGRAPH_MAX_EXACT_REAL) { |
1126 | 0 | IGRAPH_ERROR("Sampling interval too large.", IGRAPH_EOVERFLOW); |
1127 | 0 | } |
1128 | | |
1129 | | /* treat rare cases quickly */ |
1130 | 0 | if (l == h) { |
1131 | 0 | IGRAPH_CHECK(igraph_vector_resize(res, 1)); |
1132 | 0 | VECTOR(*res)[0] = l; |
1133 | 0 | return IGRAPH_SUCCESS; |
1134 | 0 | } |
1135 | 0 | if (length == 0) { |
1136 | 0 | igraph_vector_clear(res); |
1137 | 0 | return IGRAPH_SUCCESS; |
1138 | 0 | } |
1139 | 0 | if (length == N) { |
1140 | 0 | IGRAPH_CHECK(igraph_vector_resize(res, length)); |
1141 | 0 | for (igraph_integer_t i = 0; i < length; i++) { |
1142 | 0 | VECTOR(*res)[i] = l++; |
1143 | 0 | } |
1144 | 0 | return IGRAPH_SUCCESS; |
1145 | 0 | } |
1146 | | |
1147 | 0 | igraph_vector_clear(res); |
1148 | 0 | IGRAPH_CHECK(igraph_vector_reserve(res, length)); |
1149 | | |
1150 | 0 | RNG_BEGIN(); |
1151 | |
|
1152 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
1153 | 0 | l = l - 1; |
1154 | |
|
1155 | 0 | while (n > 1 && threshold < N) { |
1156 | 0 | igraph_real_t X, U; |
1157 | 0 | igraph_real_t limit, t; |
1158 | 0 | igraph_real_t negSreal, y1, y2, top, bottom; |
1159 | 0 | igraph_real_t nmin1inv = 1.0 / (-1.0 + nreal); |
1160 | 0 | while (1) { |
1161 | 0 | while (1) { |
1162 | 0 | X = Nreal * (-Vprime + 1.0); |
1163 | 0 | S = floor(X); |
1164 | | /* if (S==0) { S=1; } */ |
1165 | 0 | if (S < qu1) { |
1166 | 0 | break; |
1167 | 0 | } |
1168 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
1169 | 0 | } |
1170 | 0 | U = RNG_UNIF01(); |
1171 | 0 | negSreal = -S; |
1172 | |
|
1173 | 0 | y1 = exp(log(U * Nreal / qu1real) * nmin1inv); |
1174 | 0 | Vprime = y1 * (-X / Nreal + 1.0) * (qu1real / (negSreal + qu1real)); |
1175 | 0 | if (Vprime <= 1.0) { |
1176 | 0 | break; |
1177 | 0 | } |
1178 | | |
1179 | 0 | y2 = 1.0; |
1180 | 0 | top = -1.0 + Nreal; |
1181 | 0 | if (-1 + n > S) { |
1182 | 0 | bottom = -nreal + Nreal; |
1183 | 0 | limit = -S + N; |
1184 | 0 | } else { |
1185 | 0 | bottom = -1.0 + negSreal + Nreal; |
1186 | 0 | limit = qu1; |
1187 | 0 | } |
1188 | 0 | for (t = -1 + N; t >= limit; t--) { |
1189 | 0 | y2 = (y2 * top) / bottom; |
1190 | 0 | top = -1.0 + top; |
1191 | 0 | bottom = -1.0 + bottom; |
1192 | 0 | } |
1193 | 0 | if (Nreal / (-X + Nreal) >= y1 * exp(log(y2)*nmin1inv)) { |
1194 | 0 | Vprime = exp(log(RNG_UNIF01()) * nmin1inv); |
1195 | 0 | break; |
1196 | 0 | } |
1197 | 0 | Vprime = exp(log(RNG_UNIF01()) * ninv); |
1198 | 0 | } |
1199 | |
|
1200 | 0 | l += S + 1; |
1201 | 0 | igraph_vector_push_back(res, l); /* allocated */ |
1202 | 0 | N = -S + (-1 + N); Nreal = negSreal + (-1.0 + Nreal); |
1203 | 0 | n = -1 + n; nreal = -1.0 + nreal; ninv = nmin1inv; |
1204 | 0 | qu1 = -S + qu1; qu1real = negSreal + qu1real; |
1205 | 0 | threshold = threshold + negalphainv; |
1206 | 0 | } |
1207 | |
|
1208 | 0 | if (n > 1) { |
1209 | 0 | igraph_i_random_sample_alga_real(res, l + 1, h, n); |
1210 | 0 | } else { |
1211 | 0 | S = floor(N * Vprime); |
1212 | 0 | l += S + 1; |
1213 | 0 | igraph_vector_push_back(res, l); /* allocated */ |
1214 | 0 | } |
1215 | |
|
1216 | 0 | RNG_END(); |
1217 | |
|
1218 | 0 | return IGRAPH_SUCCESS; |
1219 | 0 | } |
1220 | | |
1221 | | /* |
1222 | | * Mathlib : A C Library of Special Functions |
1223 | | * Copyright (C) 1998 Ross Ihaka |
1224 | | * Copyright (C) 2000 The R Development Core Team |
1225 | | * based on AS 111 (C) 1977 Royal Statistical Society |
1226 | | * and on AS 241 (C) 1988 Royal Statistical Society |
1227 | | * |
1228 | | * This program is free software; you can redistribute it and/or modify |
1229 | | * it under the terms of the GNU General Public License as published by |
1230 | | * the Free Software Foundation; either version 2 of the License, or |
1231 | | * (at your option) any later version. |
1232 | | * |
1233 | | * This program is distributed in the hope that it will be useful, |
1234 | | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
1235 | | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
1236 | | * GNU General Public License for more details. |
1237 | | * |
1238 | | * You should have received a copy of the GNU General Public License |
1239 | | * along with this program; if not, write to the Free Software |
1240 | | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. |
1241 | | * |
1242 | | * SYNOPSIS |
1243 | | * |
1244 | | * double qnorm5(double p, double mu, double sigma, |
1245 | | * int lower_tail, int log_p) |
1246 | | * {qnorm (..) is synonymous and preferred inside R} |
1247 | | * |
1248 | | * DESCRIPTION |
1249 | | * |
1250 | | * Compute the quantile function for the normal distribution. |
1251 | | * |
1252 | | * For small to moderate probabilities, algorithm referenced |
1253 | | * below is used to obtain an initial approximation which is |
1254 | | * polished with a final Newton step. |
1255 | | * |
1256 | | * For very large arguments, an algorithm of Wichura is used. |
1257 | | * |
1258 | | * REFERENCE |
1259 | | * |
1260 | | * Beasley, J. D. and S. G. Springer (1977). |
1261 | | * Algorithm AS 111: The percentage points of the normal distribution, |
1262 | | * Applied Statistics, 26, 118-121. |
1263 | | * |
1264 | | * Wichura, M.J. (1988). |
1265 | | * Algorithm AS 241: The Percentage Points of the Normal Distribution. |
1266 | | * Applied Statistics, 37, 477-484. |
1267 | | */ |
1268 | | |
1269 | | /* |
1270 | | * Mathlib : A C Library of Special Functions |
1271 | | * Copyright (C) 1998-2004 The R Development Core Team |
1272 | | * |
1273 | | * This program is free software; you can redistribute it and/or modify |
1274 | | * it under the terms of the GNU General Public License as published by |
1275 | | * the Free Software Foundation; either version 2 of the License, or |
1276 | | * (at your option) any later version. |
1277 | | * |
1278 | | * This program is distributed in the hope that it will be useful, |
1279 | | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
1280 | | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
1281 | | * GNU General Public License for more details. |
1282 | | * |
1283 | | * You should have received a copy of the GNU General Public License |
1284 | | * along with this program; if not, write to the Free Software |
1285 | | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA |
1286 | | * |
1287 | | */ |
1288 | | |
1289 | | /* The ISNAN macro is used in some of the code borrowed from R below. */ |
1290 | 0 | #define ISNAN isnan |
1291 | | |
1292 | | /* Indicates that we use systems which support NaN values. */ |
1293 | | #define IEEE_754 1 |
1294 | | |
1295 | | /* Private header file for use during compilation of Mathlib */ |
1296 | | #ifndef MATHLIB_PRIVATE_H |
1297 | | #define MATHLIB_PRIVATE_H |
1298 | | |
1299 | 0 | #define ML_POSINF IGRAPH_INFINITY |
1300 | 0 | #define ML_NEGINF -IGRAPH_INFINITY |
1301 | 0 | #define ML_NAN IGRAPH_NAN |
1302 | | |
1303 | | #define ML_ERROR(x) /* nothing */ |
1304 | | #define ML_UNDERFLOW (DBL_MIN * DBL_MIN) |
1305 | | #define ML_VALID(x) (!ISNAN(x)) |
1306 | | |
1307 | | #define ME_NONE 0 |
1308 | | /* no error */ |
1309 | | #define ME_DOMAIN 1 |
1310 | | /* argument out of domain */ |
1311 | | #define ME_RANGE 2 |
1312 | | /* value out of range */ |
1313 | | #define ME_NOCONV 4 |
1314 | | /* process did not converge */ |
1315 | | #define ME_PRECISION 8 |
1316 | | /* does not have "full" precision */ |
1317 | | #define ME_UNDERFLOW 16 |
1318 | | /* and underflow occurred (important for IEEE)*/ |
1319 | | |
1320 | 0 | #define ML_ERR_return_NAN { ML_ERROR(ME_DOMAIN); return ML_NAN; } |
1321 | | |
1322 | | #endif /* MATHLIB_PRIVATE_H */ |
1323 | | |
1324 | | |
1325 | | /* Utilities for `dpq' handling (density/probability/quantile) */ |
1326 | | |
1327 | | /* give_log in "d"; log_p in "p" & "q" : */ |
1328 | | #define give_log log_p |
1329 | | /* "DEFAULT" */ |
1330 | | /* --------- */ |
1331 | 0 | #define R_D__0 (log_p ? ML_NEGINF : 0.) /* 0 */ |
1332 | 0 | #define R_D__1 (log_p ? 0. : 1.) /* 1 */ |
1333 | 0 | #define R_DT_0 (lower_tail ? R_D__0 : R_D__1) /* 0 */ |
1334 | 0 | #define R_DT_1 (lower_tail ? R_D__1 : R_D__0) /* 1 */ |
1335 | | |
1336 | 0 | #define R_D_Lval(p) (lower_tail ? (p) : (1 - (p))) /* p */ |
1337 | 0 | #define R_D_Cval(p) (lower_tail ? (1 - (p)) : (p)) /* 1 - p */ |
1338 | | |
1339 | | #define R_D_val(x) (log_p ? log(x) : (x)) /* x in pF(x,..) */ |
1340 | | #define R_D_qIv(p) (log_p ? exp(p) : (p)) /* p in qF(p,..) */ |
1341 | | #define R_D_exp(x) (log_p ? (x) : exp(x)) /* exp(x) */ |
1342 | | #define R_D_log(p) (log_p ? (p) : log(p)) /* log(p) */ |
1343 | | #define R_D_Clog(p) (log_p ? log1p(-(p)) : (1 - (p)))/* [log](1-p) */ |
1344 | | |
1345 | | /* log(1-exp(x)): R_D_LExp(x) == (log1p(- R_D_qIv(x))) but even more stable:*/ |
1346 | | #define R_D_LExp(x) (log_p ? R_Log1_Exp(x) : log1p(-x)) |
1347 | | |
1348 | | /*till 1.8.x: |
1349 | | * #define R_DT_val(x) R_D_val(R_D_Lval(x)) |
1350 | | * #define R_DT_Cval(x) R_D_val(R_D_Cval(x)) */ |
1351 | | #define R_DT_val(x) (lower_tail ? R_D_val(x) : R_D_Clog(x)) |
1352 | | #define R_DT_Cval(x) (lower_tail ? R_D_Clog(x) : R_D_val(x)) |
1353 | | |
1354 | | /*#define R_DT_qIv(p) R_D_Lval(R_D_qIv(p)) * p in qF ! */ |
1355 | 0 | #define R_DT_qIv(p) (log_p ? (lower_tail ? exp(p) : - expm1(p)) \ |
1356 | 0 | : R_D_Lval(p)) |
1357 | | |
1358 | | /*#define R_DT_CIv(p) R_D_Cval(R_D_qIv(p)) * 1 - p in qF */ |
1359 | 0 | #define R_DT_CIv(p) (log_p ? (lower_tail ? -expm1(p) : exp(p)) \ |
1360 | 0 | : R_D_Cval(p)) |
1361 | | |
1362 | | #define R_DT_exp(x) R_D_exp(R_D_Lval(x)) /* exp(x) */ |
1363 | | #define R_DT_Cexp(x) R_D_exp(R_D_Cval(x)) /* exp(1 - x) */ |
1364 | | |
1365 | | #define R_DT_log(p) (lower_tail? R_D_log(p) : R_D_LExp(p))/* log(p) in qF */ |
1366 | | #define R_DT_Clog(p) (lower_tail? R_D_LExp(p): R_D_log(p))/* log(1-p) in qF*/ |
1367 | | #define R_DT_Log(p) (lower_tail? (p) : R_Log1_Exp(p)) |
1368 | | /* == R_DT_log when we already "know" log_p == TRUE :*/ |
1369 | | |
1370 | | #define R_Q_P01_check(p) \ |
1371 | 0 | if ((log_p && p > 0) || \ |
1372 | 0 | (!log_p && (p < 0 || p > 1)) ) \ |
1373 | 0 | ML_ERR_return_NAN |
1374 | | |
1375 | | /* additions for density functions (C.Loader) */ |
1376 | | #define R_D_fexp(f,x) (give_log ? -0.5*log(f)+(x) : exp(x)/sqrt(f)) |
1377 | | #define R_D_forceint(x) floor((x) + 0.5) |
1378 | | #define R_D_nonint(x) (fabs((x) - floor((x)+0.5)) > 1e-7) |
1379 | | /* [neg]ative or [non int]eger : */ |
1380 | | #define R_D_negInonint(x) (x < 0. || R_D_nonint(x)) |
1381 | | |
1382 | | #define R_D_nonint_check(x) \ |
1383 | | if (R_D_nonint(x)) { \ |
1384 | | MATHLIB_WARNING("non-integer x = %f", x); \ |
1385 | | return R_D__0; \ |
1386 | | } |
1387 | | |
1388 | 0 | static double igraph_i_qnorm5(double p, double mu, double sigma, igraph_bool_t lower_tail, igraph_bool_t log_p) { |
1389 | 0 | double p_, q, r, val; |
1390 | |
|
1391 | 0 | #ifdef IEEE_754 |
1392 | 0 | if (ISNAN(p) || ISNAN(mu) || ISNAN(sigma)) { |
1393 | 0 | return p + mu + sigma; |
1394 | 0 | } |
1395 | 0 | #endif |
1396 | 0 | if (p == R_DT_0) { |
1397 | 0 | return ML_NEGINF; |
1398 | 0 | } |
1399 | 0 | if (p == R_DT_1) { |
1400 | 0 | return ML_POSINF; |
1401 | 0 | } |
1402 | 0 | R_Q_P01_check(p); |
1403 | |
|
1404 | 0 | if (sigma < 0) { |
1405 | 0 | ML_ERR_return_NAN; |
1406 | 0 | } |
1407 | 0 | if (sigma == 0) { |
1408 | 0 | return mu; |
1409 | 0 | } |
1410 | | |
1411 | 0 | p_ = R_DT_qIv(p);/* real lower_tail prob. p */ |
1412 | 0 | q = p_ - 0.5; |
1413 | | |
1414 | | /*-- use AS 241 --- */ |
1415 | | /* double ppnd16_(double *p, long *ifault)*/ |
1416 | | /* ALGORITHM AS241 APPL. STATIST. (1988) VOL. 37, NO. 3 |
1417 | | |
1418 | | Produces the normal deviate Z corresponding to a given lower |
1419 | | tail area of P; Z is accurate to about 1 part in 10**16. |
1420 | | |
1421 | | (original fortran code used PARAMETER(..) for the coefficients |
1422 | | and provided hash codes for checking them...) |
1423 | | */ |
1424 | 0 | if (fabs(q) <= .425) {/* 0.075 <= p <= 0.925 */ |
1425 | 0 | r = .180625 - q * q; |
1426 | 0 | val = |
1427 | 0 | q * (((((((r * 2509.0809287301226727 + |
1428 | 0 | 33430.575583588128105) * r + 67265.770927008700853) * r + |
1429 | 0 | 45921.953931549871457) * r + 13731.693765509461125) * r + |
1430 | 0 | 1971.5909503065514427) * r + 133.14166789178437745) * r + |
1431 | 0 | 3.387132872796366608) |
1432 | 0 | / (((((((r * 5226.495278852854561 + |
1433 | 0 | 28729.085735721942674) * r + 39307.89580009271061) * r + |
1434 | 0 | 21213.794301586595867) * r + 5394.1960214247511077) * r + |
1435 | 0 | 687.1870074920579083) * r + 42.313330701600911252) * r + 1.); |
1436 | 0 | } else { /* closer than 0.075 from {0,1} boundary */ |
1437 | | |
1438 | | /* r = min(p, 1-p) < 0.075 */ |
1439 | 0 | if (q > 0) { |
1440 | 0 | r = R_DT_CIv(p); /* 1-p */ |
1441 | 0 | } else { |
1442 | 0 | r = p_; /* = R_DT_Iv(p) ^= p */ |
1443 | 0 | } |
1444 | |
|
1445 | 0 | r = sqrt(- ((log_p && |
1446 | 0 | ((lower_tail && q <= 0) || (!lower_tail && q > 0))) ? |
1447 | 0 | p : /* else */ log(r))); |
1448 | | /* r = sqrt(-log(r)) <==> min(p, 1-p) = exp( - r^2 ) */ |
1449 | |
|
1450 | 0 | if (r <= 5.) { /* <==> min(p,1-p) >= exp(-25) ~= 1.3888e-11 */ |
1451 | 0 | r += -1.6; |
1452 | 0 | val = (((((((r * 7.7454501427834140764e-4 + |
1453 | 0 | .0227238449892691845833) * r + .24178072517745061177) * |
1454 | 0 | r + 1.27045825245236838258) * r + |
1455 | 0 | 3.64784832476320460504) * r + 5.7694972214606914055) * |
1456 | 0 | r + 4.6303378461565452959) * r + |
1457 | 0 | 1.42343711074968357734) |
1458 | 0 | / (((((((r * |
1459 | 0 | 1.05075007164441684324e-9 + 5.475938084995344946e-4) * |
1460 | 0 | r + .0151986665636164571966) * r + |
1461 | 0 | .14810397642748007459) * r + .68976733498510000455) * |
1462 | 0 | r + 1.6763848301838038494) * r + |
1463 | 0 | 2.05319162663775882187) * r + 1.); |
1464 | 0 | } else { /* very close to 0 or 1 */ |
1465 | 0 | r += -5.; |
1466 | 0 | val = (((((((r * 2.01033439929228813265e-7 + |
1467 | 0 | 2.71155556874348757815e-5) * r + |
1468 | 0 | .0012426609473880784386) * r + .026532189526576123093) * |
1469 | 0 | r + .29656057182850489123) * r + |
1470 | 0 | 1.7848265399172913358) * r + 5.4637849111641143699) * |
1471 | 0 | r + 6.6579046435011037772) |
1472 | 0 | / (((((((r * |
1473 | 0 | 2.04426310338993978564e-15 + 1.4215117583164458887e-7) * |
1474 | 0 | r + 1.8463183175100546818e-5) * r + |
1475 | 0 | 7.868691311456132591e-4) * r + .0148753612908506148525) |
1476 | 0 | * r + .13692988092273580531) * r + |
1477 | 0 | .59983220655588793769) * r + 1.); |
1478 | 0 | } |
1479 | |
|
1480 | 0 | if (q < 0.0) { |
1481 | 0 | val = -val; |
1482 | 0 | } |
1483 | | /* return (q >= 0.)? r : -r ;*/ |
1484 | 0 | } |
1485 | 0 | return mu + sigma * val; |
1486 | 0 | } |
1487 | | |
1488 | 0 | static igraph_integer_t imax2(igraph_integer_t x, igraph_integer_t y) { |
1489 | 0 | return (x < y) ? y : x; |
1490 | 0 | } |
1491 | | |
1492 | 0 | static igraph_integer_t imin2(igraph_integer_t x, igraph_integer_t y) { |
1493 | 0 | return (x < y) ? x : y; |
1494 | 0 | } |
1495 | | |
1496 | 0 | static double igraph_i_norm_rand(igraph_rng_t *rng) { |
1497 | 0 | double r; |
1498 | | |
1499 | | /* Use the inversion method based on uniform variates from (0, 1). |
1500 | | * We exclude 0.0 as it would lead to generating -infinity. |
1501 | | * It is assumed that unif01() provides sufficient accuracy. |
1502 | | * A resolution of 2^-32 may not be sufficient. igraph's default |
1503 | | * implementaton provides an accuracy of 2^-52. |
1504 | | */ |
1505 | 0 | do { |
1506 | 0 | r = igraph_rng_get_unif01(rng); |
1507 | 0 | } while (r == 0.0); |
1508 | |
|
1509 | 0 | return igraph_i_qnorm5(r, 0.0, 1.0, 1, 0); |
1510 | 0 | } |
1511 | | |
1512 | | /* |
1513 | | * The following function is igraph code (not R / Mathlib). |
1514 | | * |
1515 | | * We use simple inverse transform sampling, with the assumption that the |
1516 | | * quality/resolution of uniform variates is high (52 bits in the default |
1517 | | * implementation). The quantile function is -log(1 - r) but given that |
1518 | | * r is sampled uniformly form the unit interval, -log(r) is equivalent. |
1519 | | * r = 0 is disallowed as it would yield infinity. |
1520 | | */ |
1521 | | |
1522 | 0 | static double igraph_i_exp_rand(igraph_rng_t *rng) { |
1523 | 0 | igraph_real_t r = igraph_rng_get_unif01(rng); |
1524 | 0 | if (r == 0.0) r = 1.0; /* sample from (0, 1] instead of [0, 1) */ |
1525 | 0 | return -log(r); |
1526 | 0 | } |
1527 | | |
1528 | | /* |
1529 | | * Mathlib : A C Library of Special Functions |
1530 | | * Copyright (C) 1998 Ross Ihaka |
1531 | | * Copyright (C) 2000-2001 The R Development Core Team |
1532 | | * |
1533 | | * This program is free software; you can redistribute it and/or modify |
1534 | | * it under the terms of the GNU General Public License as published by |
1535 | | * the Free Software Foundation; either version 2 of the License, or |
1536 | | * (at your option) any later version. |
1537 | | * |
1538 | | * This program is distributed in the hope that it will be useful, |
1539 | | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
1540 | | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
1541 | | * GNU General Public License for more details. |
1542 | | * |
1543 | | * You should have received a copy of the GNU General Public License |
1544 | | * along with this program; if not, write to the Free Software |
1545 | | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. |
1546 | | * |
1547 | | * SYNOPSIS |
1548 | | * |
1549 | | * #include <Rmath.h> |
1550 | | * double rpois(double lambda) |
1551 | | * |
1552 | | * DESCRIPTION |
1553 | | * |
1554 | | * Random variates from the Poisson distribution. |
1555 | | * |
1556 | | * REFERENCE |
1557 | | * |
1558 | | * Ahrens, J.H. and Dieter, U. (1982). |
1559 | | * Computer generation of Poisson deviates |
1560 | | * from modified normal distributions. |
1561 | | * ACM Trans. Math. Software 8, 163-179. |
1562 | | */ |
1563 | | |
1564 | 0 | #define a0 -0.5 |
1565 | 0 | #define a1 0.3333333 |
1566 | 0 | #define a2 -0.2500068 |
1567 | 0 | #define a3 0.2000118 |
1568 | 0 | #define a4 -0.1661269 |
1569 | 0 | #define a5 0.1421878 |
1570 | 0 | #define a6 -0.1384794 |
1571 | 0 | #define a7 0.1250060 |
1572 | | |
1573 | 0 | #define one_7 0.1428571428571428571 |
1574 | 0 | #define one_12 0.0833333333333333333 |
1575 | 0 | #define one_24 0.0416666666666666667 |
1576 | | |
1577 | 0 | #define repeat for(;;) |
1578 | | |
1579 | 0 | #define FALSE 0 |
1580 | 0 | #define TRUE 1 |
1581 | 0 | #define M_1_SQRT_2PI 0.398942280401432677939946059934 /* 1/sqrt(2pi) */ |
1582 | | |
1583 | 0 | static double igraph_i_rpois(igraph_rng_t *rng, double mu) { |
1584 | | /* Factorial Table (0:9)! */ |
1585 | 0 | const double fact[10] = { |
1586 | 0 | 1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880. |
1587 | 0 | }; |
1588 | | |
1589 | | /* These are static --- persistent between calls for same mu : */ |
1590 | 0 | static IGRAPH_THREAD_LOCAL int l; |
1591 | 0 | static IGRAPH_THREAD_LOCAL igraph_integer_t m; |
1592 | |
|
1593 | 0 | static IGRAPH_THREAD_LOCAL double b1, b2, c, c0, c1, c2, c3; |
1594 | 0 | static IGRAPH_THREAD_LOCAL double pp[36], p0, p, q, s, d, omega; |
1595 | 0 | static IGRAPH_THREAD_LOCAL double big_l;/* integer "w/o overflow" */ |
1596 | 0 | static IGRAPH_THREAD_LOCAL double muprev = 0., muprev2 = 0.;/*, muold = 0.*/ |
1597 | | |
1598 | | /* Local Vars [initialize some for -Wall]: */ |
1599 | 0 | double del, difmuk = 0., E = 0., fk = 0., fx, fy, g, px, py, t, u = 0., v, x; |
1600 | 0 | double pois = -1.; |
1601 | 0 | int k, kflag, big_mu, new_big_mu = FALSE; |
1602 | |
|
1603 | 0 | if (!isfinite(mu) || mu < 0) { |
1604 | 0 | ML_ERR_return_NAN; |
1605 | 0 | } |
1606 | | |
1607 | 0 | if (mu <= 0.) { |
1608 | 0 | return 0.; |
1609 | 0 | } |
1610 | | |
1611 | 0 | big_mu = mu >= 10.; |
1612 | 0 | if (big_mu) { |
1613 | 0 | new_big_mu = FALSE; |
1614 | 0 | } |
1615 | |
|
1616 | 0 | if (!(big_mu && mu == muprev)) {/* maybe compute new persistent par.s */ |
1617 | |
|
1618 | 0 | if (big_mu) { |
1619 | 0 | new_big_mu = TRUE; |
1620 | | /* Case A. (recalculation of s,d,l because mu has changed): |
1621 | | * The Poisson probabilities pk exceed the discrete normal |
1622 | | * probabilities fk whenever k >= m(mu). |
1623 | | */ |
1624 | 0 | muprev = mu; |
1625 | 0 | s = sqrt(mu); |
1626 | 0 | d = 6. * mu * mu; |
1627 | 0 | big_l = floor(mu - 1.1484); |
1628 | | /* = an upper bound to m(mu) for all mu >= 10.*/ |
1629 | 0 | } else { /* Small mu ( < 10) -- not using normal approx. */ |
1630 | | |
1631 | | /* Case B. (start new table and calculate p0 if necessary) */ |
1632 | | |
1633 | | /*muprev = 0.;-* such that next time, mu != muprev ..*/ |
1634 | 0 | if (mu != muprev) { |
1635 | 0 | muprev = mu; |
1636 | 0 | m = imax2(1, (igraph_integer_t) mu); |
1637 | 0 | l = 0; /* pp[] is already ok up to pp[l] */ |
1638 | 0 | q = p0 = p = exp(-mu); |
1639 | 0 | } |
1640 | |
|
1641 | 0 | repeat { |
1642 | | /* Step U. uniform sample for inversion method */ |
1643 | 0 | u = igraph_rng_get_unif01(rng); |
1644 | 0 | if (u <= p0) { |
1645 | 0 | return 0.; |
1646 | 0 | } |
1647 | | |
1648 | | /* Step T. table comparison until the end pp[l] of the |
1649 | | pp-table of cumulative Poisson probabilities |
1650 | | (0.458 > ~= pp[9](= 0.45792971447) for mu=10 ) */ |
1651 | 0 | if (l != 0) { |
1652 | 0 | for (k = (u <= 0.458) ? 1 : imin2(l, m); k <= l; k++) |
1653 | 0 | if (u <= pp[k]) { |
1654 | 0 | return (double)k; |
1655 | 0 | } |
1656 | 0 | if (l == 35) { /* u > pp[35] */ |
1657 | 0 | continue; |
1658 | 0 | } |
1659 | 0 | } |
1660 | | /* Step C. creation of new Poisson |
1661 | | probabilities p[l..] and their cumulatives q =: pp[k] */ |
1662 | 0 | l++; |
1663 | 0 | for (k = l; k <= 35; k++) { |
1664 | 0 | p *= mu / k; |
1665 | 0 | q += p; |
1666 | 0 | pp[k] = q; |
1667 | 0 | if (u <= q) { |
1668 | 0 | l = k; |
1669 | 0 | return (double)k; |
1670 | 0 | } |
1671 | 0 | } |
1672 | 0 | l = 35; |
1673 | 0 | } /* end(repeat) */ |
1674 | 0 | }/* mu < 10 */ |
1675 | |
|
1676 | 0 | } /* end {initialize persistent vars} */ |
1677 | | |
1678 | | /* Only if mu >= 10 : ----------------------- */ |
1679 | | |
1680 | | /* Step N. normal sample */ |
1681 | 0 | g = mu + s * igraph_i_norm_rand(rng);/* norm_rand() ~ N(0,1), standard normal */ |
1682 | |
|
1683 | 0 | if (g >= 0.) { |
1684 | 0 | pois = floor(g); |
1685 | | /* Step I. immediate acceptance if pois is large enough */ |
1686 | 0 | if (pois >= big_l) { |
1687 | 0 | return pois; |
1688 | 0 | } |
1689 | | /* Step S. squeeze acceptance */ |
1690 | 0 | fk = pois; |
1691 | 0 | difmuk = mu - fk; |
1692 | 0 | u = igraph_rng_get_unif01(rng); /* ~ U(0,1) - sample */ |
1693 | 0 | if (d * u >= difmuk * difmuk * difmuk) { |
1694 | 0 | return pois; |
1695 | 0 | } |
1696 | 0 | } |
1697 | | |
1698 | | /* Step P. preparations for steps Q and H. |
1699 | | (recalculations of parameters if necessary) */ |
1700 | | |
1701 | 0 | if (new_big_mu || mu != muprev2) { |
1702 | | /* Careful! muprev2 is not always == muprev |
1703 | | because one might have exited in step I or S |
1704 | | */ |
1705 | 0 | muprev2 = mu; |
1706 | 0 | omega = M_1_SQRT_2PI / s; |
1707 | | /* The quantities b1, b2, c3, c2, c1, c0 are for the Hermite |
1708 | | * approximations to the discrete normal probabilities fk. */ |
1709 | |
|
1710 | 0 | b1 = one_24 / mu; |
1711 | 0 | b2 = 0.3 * b1 * b1; |
1712 | 0 | c3 = one_7 * b1 * b2; |
1713 | 0 | c2 = b2 - 15. * c3; |
1714 | 0 | c1 = b1 - 6. * b2 + 45. * c3; |
1715 | 0 | c0 = 1. - b1 + 3. * b2 - 15. * c3; |
1716 | 0 | c = 0.1069 / mu; /* guarantees majorization by the 'hat'-function. */ |
1717 | 0 | } |
1718 | |
|
1719 | 0 | if (g >= 0.) { |
1720 | | /* 'Subroutine' F is called (kflag=0 for correct return) */ |
1721 | 0 | kflag = 0; |
1722 | 0 | goto Step_F; |
1723 | 0 | } |
1724 | | |
1725 | | |
1726 | 0 | repeat { |
1727 | | /* Step E. Exponential Sample */ |
1728 | |
|
1729 | 0 | E = igraph_i_exp_rand(rng);/* ~ Exp(1) (standard exponential) */ |
1730 | | |
1731 | | /* sample t from the laplace 'hat' |
1732 | | (if t <= -0.6744 then pk < fk for all mu >= 10.) */ |
1733 | 0 | u = 2 * igraph_rng_get_unif01(rng) - 1.; |
1734 | 0 | t = 1.8 + copysign(E, u); |
1735 | 0 | if (t > -0.6744) { |
1736 | 0 | pois = floor(mu + s * t); |
1737 | 0 | fk = pois; |
1738 | 0 | difmuk = mu - fk; |
1739 | | |
1740 | | /* 'subroutine' F is called (kflag=1 for correct return) */ |
1741 | 0 | kflag = 1; |
1742 | |
|
1743 | 0 | Step_F: /* 'subroutine' F : calculation of px,py,fx,fy. */ |
1744 | |
|
1745 | 0 | if (pois < 10) { /* use factorials from table fact[] */ |
1746 | 0 | px = -mu; |
1747 | 0 | py = pow(mu, pois) / fact[(int)pois]; |
1748 | 0 | } else { |
1749 | | /* Case pois >= 10 uses polynomial approximation |
1750 | | a0-a7 for accuracy when advisable */ |
1751 | 0 | del = one_12 / fk; |
1752 | 0 | del = del * (1. - 4.8 * del * del); |
1753 | 0 | v = difmuk / fk; |
1754 | 0 | if (fabs(v) <= 0.25) |
1755 | 0 | px = fk * v * v * (((((((a7 * v + a6) * v + a5) * v + a4) * |
1756 | 0 | v + a3) * v + a2) * v + a1) * v + a0) |
1757 | 0 | - del; |
1758 | 0 | else { /* |v| > 1/4 */ |
1759 | 0 | px = fk * log(1. + v) - difmuk - del; |
1760 | 0 | } |
1761 | 0 | py = M_1_SQRT_2PI / sqrt(fk); |
1762 | 0 | } |
1763 | 0 | x = (0.5 - difmuk) / s; |
1764 | 0 | x *= x;/* x^2 */ |
1765 | 0 | fx = -0.5 * x; |
1766 | 0 | fy = omega * (((c3 * x + c2) * x + c1) * x + c0); |
1767 | 0 | if (kflag > 0) { |
1768 | | /* Step H. Hat acceptance (E is repeated on rejection) */ |
1769 | 0 | if (c * fabs(u) <= py * exp(px + E) - fy * exp(fx + E)) { |
1770 | 0 | break; |
1771 | 0 | } |
1772 | 0 | } else |
1773 | | /* Step Q. Quotient acceptance (rare case) */ |
1774 | 0 | if (fy - u * fy <= py * exp(px - fx)) { |
1775 | 0 | break; |
1776 | 0 | } |
1777 | 0 | }/* t > -.67.. */ |
1778 | 0 | } |
1779 | 0 | return pois; |
1780 | 0 | } |
1781 | | |
1782 | | #undef a1 |
1783 | | #undef a2 |
1784 | | #undef a3 |
1785 | | #undef a4 |
1786 | | #undef a5 |
1787 | | #undef a6 |
1788 | | #undef a7 |
1789 | | |
1790 | | /* This is from nmath/rbinom.c */ |
1791 | | |
1792 | 0 | #define repeat for(;;) |
1793 | | |
1794 | 0 | static double igraph_i_rbinom(igraph_rng_t *rng, igraph_integer_t n, double pp) { |
1795 | |
|
1796 | 0 | static IGRAPH_THREAD_LOCAL double c, fm, npq, p1, p2, p3, p4, qn; |
1797 | 0 | static IGRAPH_THREAD_LOCAL double xl, xll, xlr, xm, xr; |
1798 | |
|
1799 | 0 | static IGRAPH_THREAD_LOCAL double psave = -1.0; |
1800 | 0 | static IGRAPH_THREAD_LOCAL igraph_integer_t nsave = -1; |
1801 | 0 | static IGRAPH_THREAD_LOCAL igraph_integer_t m; |
1802 | |
|
1803 | 0 | double f, f1, f2, u, v, w, w2, x, x1, x2, z, z2; |
1804 | 0 | double p, q, np, g, r, al, alv, amaxp, ffm, ynorm; |
1805 | 0 | igraph_integer_t i, ix, k; |
1806 | |
|
1807 | 0 | if (!isfinite(pp) || |
1808 | | /* n=0, p=0, p=1 are not errors <TSL>*/ |
1809 | 0 | n < 0 || pp < 0. || pp > 1.) { |
1810 | 0 | ML_ERR_return_NAN; |
1811 | 0 | } |
1812 | | |
1813 | 0 | if (n == 0 || pp == 0.) { |
1814 | 0 | return 0; |
1815 | 0 | } |
1816 | 0 | if (pp == 1.) { |
1817 | 0 | return n; |
1818 | 0 | } |
1819 | | |
1820 | 0 | p = fmin(pp, 1. - pp); |
1821 | 0 | q = 1. - p; |
1822 | 0 | np = n * p; |
1823 | 0 | r = p / q; |
1824 | 0 | g = r * (n + 1); |
1825 | | |
1826 | | /* Setup, perform only when parameters change [using static (globals): */ |
1827 | | |
1828 | | /* FIXING: Want this thread safe |
1829 | | -- use as little (thread globals) as possible |
1830 | | */ |
1831 | 0 | if (pp != psave || n != nsave) { |
1832 | 0 | psave = pp; |
1833 | 0 | nsave = n; |
1834 | 0 | if (np < 30.0) { |
1835 | | /* inverse cdf logic for mean less than 30 */ |
1836 | 0 | qn = pow(q, (double) n); |
1837 | 0 | goto L_np_small; |
1838 | 0 | } else { |
1839 | 0 | ffm = np + p; |
1840 | 0 | m = ffm; |
1841 | 0 | fm = m; |
1842 | 0 | npq = np * q; |
1843 | | /* Note (igraph): Original code used a cast to (int) for rounding. However, |
1844 | | * the max npq = n*p*(1-p) value is 0.25*n, thus 2.195 * sqrt(npq) may be |
1845 | | * as large as 1.0975 * sqrt(n). This is not representable on a 32-bit signed |
1846 | | * integer when n is a 64-bit signed integer. Thus we use trunc() instead. */ |
1847 | 0 | p1 = trunc(2.195 * sqrt(npq) - 4.6 * q) + 0.5; |
1848 | 0 | xm = fm + 0.5; |
1849 | 0 | xl = xm - p1; |
1850 | 0 | xr = xm + p1; |
1851 | 0 | c = 0.134 + 20.5 / (15.3 + fm); |
1852 | 0 | al = (ffm - xl) / (ffm - xl * p); |
1853 | 0 | xll = al * (1.0 + 0.5 * al); |
1854 | 0 | al = (xr - ffm) / (xr * q); |
1855 | 0 | xlr = al * (1.0 + 0.5 * al); |
1856 | 0 | p2 = p1 * (1.0 + c + c); |
1857 | 0 | p3 = p2 + c / xll; |
1858 | 0 | p4 = p3 + c / xlr; |
1859 | 0 | } |
1860 | 0 | } else if (n == nsave) { |
1861 | 0 | if (np < 30.0) { |
1862 | 0 | goto L_np_small; |
1863 | 0 | } |
1864 | 0 | } |
1865 | | |
1866 | | /*-------------------------- np = n*p >= 30 : ------------------- */ |
1867 | 0 | repeat { |
1868 | 0 | u = igraph_rng_get_unif01(rng) * p4; |
1869 | 0 | v = igraph_rng_get_unif01(rng); |
1870 | | /* triangular region */ |
1871 | 0 | if (u <= p1) { |
1872 | 0 | ix = xm - p1 * v + u; |
1873 | 0 | goto finis; |
1874 | 0 | } |
1875 | | /* parallelogram region */ |
1876 | 0 | if (u <= p2) { |
1877 | 0 | x = xl + (u - p1) / c; |
1878 | 0 | v = v * c + 1.0 - fabs(xm - x) / p1; |
1879 | 0 | if (v > 1.0 || v <= 0.) { |
1880 | 0 | continue; |
1881 | 0 | } |
1882 | 0 | ix = x; |
1883 | 0 | } else { |
1884 | 0 | if (u > p3) { /* right tail */ |
1885 | 0 | ix = xr - log(v) / xlr; |
1886 | 0 | if (ix > n) { |
1887 | 0 | continue; |
1888 | 0 | } |
1889 | 0 | v = v * (u - p3) * xlr; |
1890 | 0 | } else {/* left tail */ |
1891 | 0 | ix = xl + log(v) / xll; |
1892 | 0 | if (ix < 0) { |
1893 | 0 | continue; |
1894 | 0 | } |
1895 | 0 | v = v * (u - p2) * xll; |
1896 | 0 | } |
1897 | 0 | } |
1898 | | /* determine appropriate way to perform accept/reject test */ |
1899 | 0 | k = imaxabs(ix - m); |
1900 | 0 | if (k <= 20 || k >= npq / 2 - 1) { |
1901 | | /* explicit evaluation */ |
1902 | 0 | f = 1.0; |
1903 | 0 | if (m < ix) { |
1904 | 0 | for (i = m + 1; i <= ix; i++) { |
1905 | 0 | f *= (g / i - r); |
1906 | 0 | } |
1907 | 0 | } else if (m != ix) { |
1908 | 0 | for (i = ix + 1; i <= m; i++) { |
1909 | 0 | f /= (g / i - r); |
1910 | 0 | } |
1911 | 0 | } |
1912 | 0 | if (v <= f) { |
1913 | 0 | goto finis; |
1914 | 0 | } |
1915 | 0 | } else { |
1916 | | /* squeezing using upper and lower bounds on log(f(x)) */ |
1917 | 0 | amaxp = (k / npq) * ((k * (k / 3. + 0.625) + 0.1666666666666) / npq + 0.5); |
1918 | 0 | ynorm = -k * k / (2.0 * npq); |
1919 | 0 | alv = log(v); |
1920 | 0 | if (alv < ynorm - amaxp) { |
1921 | 0 | goto finis; |
1922 | 0 | } |
1923 | 0 | if (alv <= ynorm + amaxp) { |
1924 | | /* Stirling's formula to machine accuracy */ |
1925 | | /* for the final acceptance/rejection test */ |
1926 | 0 | x1 = ix + 1; |
1927 | 0 | f1 = fm + 1.0; |
1928 | 0 | z = n + 1 - fm; |
1929 | 0 | w = n - ix + 1.0; |
1930 | 0 | z2 = z * z; |
1931 | 0 | x2 = x1 * x1; |
1932 | 0 | f2 = f1 * f1; |
1933 | 0 | w2 = w * w; |
1934 | 0 | if (alv <= xm * log(f1 / x1) + (n - m + 0.5) * log(z / w) + (ix - m) * log(w * p / (x1 * q)) + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / f2) / f2) / f2) / f2) / f1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / z2) / z2) / z2) / z2) / z / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / x2) / x2) / x2) / x2) / x1 / 166320.0 + (13860.0 - (462.0 - (132.0 - (99.0 - 140.0 / w2) / w2) / w2) / w2) / w / 166320.) { |
1935 | 0 | goto finis; |
1936 | 0 | } |
1937 | 0 | } |
1938 | 0 | } |
1939 | 0 | } |
1940 | | |
1941 | 0 | L_np_small: |
1942 | | /*---------------------- np = n*p < 30 : ------------------------- */ |
1943 | |
|
1944 | 0 | repeat { |
1945 | 0 | ix = 0; |
1946 | 0 | f = qn; |
1947 | 0 | u = igraph_rng_get_unif01(rng); |
1948 | 0 | repeat { |
1949 | 0 | if (u < f) { |
1950 | 0 | goto finis; |
1951 | 0 | } |
1952 | 0 | if (ix > 110) { |
1953 | 0 | break; |
1954 | 0 | } |
1955 | 0 | u -= f; |
1956 | 0 | ix++; |
1957 | 0 | f *= (g / ix - r); |
1958 | 0 | } |
1959 | 0 | } |
1960 | 0 | finis: |
1961 | 0 | if (psave > 0.5) { |
1962 | 0 | ix = n - ix; |
1963 | 0 | } |
1964 | 0 | return (double)ix; |
1965 | 0 | } |
1966 | | |
1967 | 0 | static igraph_real_t igraph_i_rexp(igraph_rng_t *rng, double rate) { |
1968 | 0 | igraph_real_t scale = 1.0 / rate; |
1969 | 0 | if (!isfinite(scale) || scale <= 0.0) { |
1970 | 0 | if (scale == 0.0) { |
1971 | 0 | return 0.0; |
1972 | 0 | } |
1973 | 0 | return IGRAPH_NAN; |
1974 | 0 | } |
1975 | 0 | return scale * igraph_i_exp_rand(rng); |
1976 | 0 | } |
1977 | | |
1978 | | /* This is from nmath/rgamma.c */ |
1979 | | |
1980 | | /* |
1981 | | * Mathlib : A C Library of Special Functions |
1982 | | * Copyright (C) 1998 Ross Ihaka |
1983 | | * Copyright (C) 2000--2008 The R Core Team |
1984 | | * |
1985 | | * This program is free software; you can redistribute it and/or modify |
1986 | | * it under the terms of the GNU General Public License as published by |
1987 | | * the Free Software Foundation; either version 2 of the License, or |
1988 | | * (at your option) any later version. |
1989 | | * |
1990 | | * This program is distributed in the hope that it will be useful, |
1991 | | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
1992 | | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
1993 | | * GNU General Public License for more details. |
1994 | | * |
1995 | | * You should have received a copy of the GNU General Public License |
1996 | | * along with this program; if not, a copy is available at |
1997 | | * http://www.r-project.org/Licenses/ |
1998 | | * |
1999 | | * SYNOPSIS |
2000 | | * |
2001 | | * #include <Rmath.h> |
2002 | | * double rgamma(double a, double scale); |
2003 | | * |
2004 | | * DESCRIPTION |
2005 | | * |
2006 | | * Random variates from the gamma distribution. |
2007 | | * |
2008 | | * REFERENCES |
2009 | | * |
2010 | | * [1] Shape parameter a >= 1. Algorithm GD in: |
2011 | | * |
2012 | | * Ahrens, J.H. and Dieter, U. (1982). |
2013 | | * Generating gamma variates by a modified |
2014 | | * rejection technique. |
2015 | | * Comm. ACM, 25, 47-54. |
2016 | | * |
2017 | | * |
2018 | | * [2] Shape parameter 0 < a < 1. Algorithm GS in: |
2019 | | * |
2020 | | * Ahrens, J.H. and Dieter, U. (1974). |
2021 | | * Computer methods for sampling from gamma, beta, |
2022 | | * poisson and binomial distributions. |
2023 | | * Computing, 12, 223-246. |
2024 | | * |
2025 | | * Input: a = parameter (mean) of the standard gamma distribution. |
2026 | | * Output: a variate from the gamma(a)-distribution |
2027 | | */ |
2028 | | |
2029 | 0 | static double igraph_i_rgamma(igraph_rng_t *rng, double a, double scale) { |
2030 | | /* Constants : */ |
2031 | 0 | static const double sqrt32 = 5.656854; |
2032 | 0 | static const double exp_m1 = 0.36787944117144232159;/* exp(-1) = 1/e */ |
2033 | | |
2034 | | /* Coefficients q[k] - for q0 = sum(q[k]*a^(-k)) |
2035 | | * Coefficients a[k] - for q = q0+(t*t/2)*sum(a[k]*v^k) |
2036 | | * Coefficients e[k] - for exp(q)-1 = sum(e[k]*q^k) |
2037 | | */ |
2038 | 0 | static const double q1 = 0.04166669; |
2039 | 0 | static const double q2 = 0.02083148; |
2040 | 0 | static const double q3 = 0.00801191; |
2041 | 0 | static const double q4 = 0.00144121; |
2042 | 0 | static const double q5 = -7.388e-5; |
2043 | 0 | static const double q6 = 2.4511e-4; |
2044 | 0 | static const double q7 = 2.424e-4; |
2045 | |
|
2046 | 0 | static const double a1 = 0.3333333; |
2047 | 0 | static const double a2 = -0.250003; |
2048 | 0 | static const double a3 = 0.2000062; |
2049 | 0 | static const double a4 = -0.1662921; |
2050 | 0 | static const double a5 = 0.1423657; |
2051 | 0 | static const double a6 = -0.1367177; |
2052 | 0 | static const double a7 = 0.1233795; |
2053 | | |
2054 | | /* State variables: */ |
2055 | 0 | static IGRAPH_THREAD_LOCAL double aa = 0.; |
2056 | 0 | static IGRAPH_THREAD_LOCAL double aaa = 0.; |
2057 | 0 | static IGRAPH_THREAD_LOCAL double s, s2, d; /* no. 1 (step 1) */ |
2058 | 0 | static IGRAPH_THREAD_LOCAL double q0, b, si, c;/* no. 2 (step 4) */ |
2059 | |
|
2060 | 0 | double e, p, q, r, t, u, v, w, x, ret_val; |
2061 | |
|
2062 | 0 | if (!isfinite(a) || !isfinite(scale) || a < 0.0 || scale <= 0.0) { |
2063 | 0 | if (scale == 0.) { |
2064 | 0 | return 0.; |
2065 | 0 | } |
2066 | 0 | ML_ERR_return_NAN; |
2067 | 0 | } |
2068 | | |
2069 | 0 | if (a < 1.) { /* GS algorithm for parameters a < 1 */ |
2070 | 0 | if (a == 0) { |
2071 | 0 | return 0.; |
2072 | 0 | } |
2073 | 0 | e = 1.0 + exp_m1 * a; |
2074 | 0 | repeat { |
2075 | 0 | p = e * igraph_rng_get_unif01(rng); |
2076 | 0 | if (p >= 1.0) { |
2077 | 0 | x = -log((e - p) / a); |
2078 | 0 | if (igraph_i_exp_rand(rng) >= (1.0 - a) * log(x)) { |
2079 | 0 | break; |
2080 | 0 | } |
2081 | 0 | } else { |
2082 | 0 | x = exp(log(p) / a); |
2083 | 0 | if (igraph_i_exp_rand(rng) >= x) { |
2084 | 0 | break; |
2085 | 0 | } |
2086 | 0 | } |
2087 | 0 | } |
2088 | 0 | return scale * x; |
2089 | 0 | } |
2090 | | |
2091 | | /* --- a >= 1 : GD algorithm --- */ |
2092 | | |
2093 | | /* Step 1: Recalculations of s2, s, d if a has changed */ |
2094 | 0 | if (a != aa) { |
2095 | 0 | aa = a; |
2096 | 0 | s2 = a - 0.5; |
2097 | 0 | s = sqrt(s2); |
2098 | 0 | d = sqrt32 - s * 12.0; |
2099 | 0 | } |
2100 | | /* Step 2: t = standard normal deviate, |
2101 | | x = (s,1/2) -normal deviate. */ |
2102 | | |
2103 | | /* immediate acceptance (i) */ |
2104 | 0 | t = igraph_i_norm_rand(rng); |
2105 | 0 | x = s + 0.5 * t; |
2106 | 0 | ret_val = x * x; |
2107 | 0 | if (t >= 0.0) { |
2108 | 0 | return scale * ret_val; |
2109 | 0 | } |
2110 | | |
2111 | | /* Step 3: u = 0,1 - uniform sample. squeeze acceptance (s) */ |
2112 | 0 | u = igraph_rng_get_unif01(rng); |
2113 | 0 | if (d * u <= t * t * t) { |
2114 | 0 | return scale * ret_val; |
2115 | 0 | } |
2116 | | |
2117 | | /* Step 4: recalculations of q0, b, si, c if necessary */ |
2118 | | |
2119 | 0 | if (a != aaa) { |
2120 | 0 | aaa = a; |
2121 | 0 | r = 1.0 / a; |
2122 | 0 | q0 = ((((((q7 * r + q6) * r + q5) * r + q4) * r + q3) * r |
2123 | 0 | + q2) * r + q1) * r; |
2124 | | |
2125 | | /* Approximation depending on size of parameter a */ |
2126 | | /* The constants in the expressions for b, si and c */ |
2127 | | /* were established by numerical experiments */ |
2128 | |
|
2129 | 0 | if (a <= 3.686) { |
2130 | 0 | b = 0.463 + s + 0.178 * s2; |
2131 | 0 | si = 1.235; |
2132 | 0 | c = 0.195 / s - 0.079 + 0.16 * s; |
2133 | 0 | } else if (a <= 13.022) { |
2134 | 0 | b = 1.654 + 0.0076 * s2; |
2135 | 0 | si = 1.68 / s + 0.275; |
2136 | 0 | c = 0.062 / s + 0.024; |
2137 | 0 | } else { |
2138 | 0 | b = 1.77; |
2139 | 0 | si = 0.75; |
2140 | 0 | c = 0.1515 / s; |
2141 | 0 | } |
2142 | 0 | } |
2143 | | /* Step 5: no quotient test if x not positive */ |
2144 | |
|
2145 | 0 | if (x > 0.0) { |
2146 | | /* Step 6: calculation of v and quotient q */ |
2147 | 0 | v = t / (s + s); |
2148 | 0 | if (fabs(v) <= 0.25) |
2149 | 0 | q = q0 + 0.5 * t * t * ((((((a7 * v + a6) * v + a5) * v + a4) * v |
2150 | 0 | + a3) * v + a2) * v + a1) * v; |
2151 | 0 | else { |
2152 | 0 | q = q0 - s * t + 0.25 * t * t + (s2 + s2) * log(1.0 + v); |
2153 | 0 | } |
2154 | | |
2155 | | |
2156 | | /* Step 7: quotient acceptance (q) */ |
2157 | 0 | if (log(1.0 - u) <= q) { |
2158 | 0 | return scale * ret_val; |
2159 | 0 | } |
2160 | 0 | } |
2161 | | |
2162 | 0 | repeat { |
2163 | | /* Step 8: e = standard exponential deviate |
2164 | | * u = 0,1 -uniform deviate |
2165 | | * t = (b,si)-double exponential (laplace) sample */ |
2166 | 0 | e = igraph_i_exp_rand(rng); |
2167 | 0 | u = igraph_rng_get_unif01(rng); |
2168 | 0 | u = u + u - 1.0; |
2169 | 0 | if (u < 0.0) { |
2170 | 0 | t = b - si * e; |
2171 | 0 | } else { |
2172 | 0 | t = b + si * e; |
2173 | 0 | } |
2174 | | /* Step 9: rejection if t < tau(1) = -0.71874483771719 */ |
2175 | 0 | if (t >= -0.71874483771719) { |
2176 | | /* Step 10: calculation of v and quotient q */ |
2177 | 0 | v = t / (s + s); |
2178 | 0 | if (fabs(v) <= 0.25) |
2179 | 0 | q = q0 + 0.5 * t * t * |
2180 | 0 | ((((((a7 * v + a6) * v + a5) * v + a4) * v + a3) * v |
2181 | 0 | + a2) * v + a1) * v; |
2182 | 0 | else { |
2183 | 0 | q = q0 - s * t + 0.25 * t * t + (s2 + s2) * log(1.0 + v); |
2184 | 0 | } |
2185 | | /* Step 11: hat acceptance (h) */ |
2186 | | /* (if q not positive go to step 8) */ |
2187 | 0 | if (q > 0.0) { |
2188 | 0 | w = expm1(q); |
2189 | | /* ^^^^^ original code had approximation with rel.err < 2e-7 */ |
2190 | | /* if t is rejected sample again at step 8 */ |
2191 | 0 | if (c * fabs(u) <= w * exp(e - 0.5 * t * t)) { |
2192 | 0 | break; |
2193 | 0 | } |
2194 | 0 | } |
2195 | 0 | } |
2196 | 0 | } /* repeat .. until `t' is accepted */ |
2197 | 0 | x = s + 0.5 * t; |
2198 | 0 | return scale * x * x; |
2199 | 0 | } |
2200 | | |
2201 | | igraph_error_t igraph_rng_get_dirichlet(igraph_rng_t *rng, |
2202 | | const igraph_vector_t *alpha, |
2203 | 0 | igraph_vector_t *result) { |
2204 | |
|
2205 | 0 | igraph_integer_t len = igraph_vector_size(alpha); |
2206 | 0 | igraph_integer_t j; |
2207 | 0 | igraph_real_t sum = 0.0; |
2208 | |
|
2209 | 0 | if (len < 2) { |
2210 | 0 | IGRAPH_ERROR("Dirichlet parameter vector too short, must have at least two entries.", |
2211 | 0 | IGRAPH_EINVAL); |
2212 | 0 | } |
2213 | 0 | if (igraph_vector_min(alpha) <= 0) { |
2214 | 0 | IGRAPH_ERROR("Dirichlet concentration parameters must be positive.", |
2215 | 0 | IGRAPH_EINVAL); |
2216 | 0 | } |
2217 | | |
2218 | 0 | IGRAPH_CHECK(igraph_vector_resize(result, len)); |
2219 | | |
2220 | 0 | RNG_BEGIN(); |
2221 | |
|
2222 | 0 | for (j = 0; j < len; j++) { |
2223 | 0 | VECTOR(*result)[j] = igraph_rng_get_gamma(rng, VECTOR(*alpha)[j], 1.0); |
2224 | 0 | sum += VECTOR(*result)[j]; |
2225 | 0 | } |
2226 | 0 | for (j = 0; j < len; j++) { |
2227 | 0 | VECTOR(*result)[j] /= sum; |
2228 | 0 | } |
2229 | |
|
2230 | 0 | RNG_END(); |
2231 | |
|
2232 | 0 | return IGRAPH_SUCCESS; |
2233 | 0 | } |