single-r-math.c
1 //! @file single-r-math.c
2 //! @author J. Marcel van der Veer
3 //!
4 //! @section Copyright
5 //!
6 //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
7 //! Copyright 2001-2023 J. Marcel van der Veer [algol68g@xs4all.nl].
8 //!
9 //! @section License
10 //!
11 //! This program is free software; you can redistribute it and/or modify it
12 //! under the terms of the GNU General Public License as published by the
13 //! Free Software Foundation; either version 3 of the License, or
14 //! (at your option) any later version.
15 //!
16 //! This program is distributed in the hope that it will be useful, but
17 //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
18 //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
19 //! more details. You should have received a copy of the GNU General Public
20 //! License along with this program. If not, see [http://www.gnu.org/licenses/].
21
22 //! @section Synopsis
23 //!
24 //! GNU R math library interface.
25
26 #include "a68g.h"
27
28 // This file contains bindings to the GNU R standalone mathematical library.
29
30 #if defined (HAVE_MATHLIB)
31
32 #include "a68g-genie.h"
33 #include "a68g-prelude.h"
34 #include <Rmath.h>
35
36 //! @brief PROC (REAL) REAL r digamma
37
38 void genie_R_digamma_real (NODE_T * p)
39 {
40 C_FUNCTION (p, digamma);
41 }
42
43 //! @brief PROC (REAL) REAL r trigamma
44
45 void genie_R_trigamma_real (NODE_T * p)
46 {
47 C_FUNCTION (p, trigamma);
48 }
49
50 //! @brief PROC (REAL) REAL r tetragamma
51
52 void genie_R_tetragamma_real (NODE_T * p)
53 {
54 C_FUNCTION (p, tetragamma);
55 }
56
57 //! @brief PROC (REAL) REAL r pentagamma
58
59 void genie_R_pentagamma_real (NODE_T * p)
60 {
61 C_FUNCTION (p, pentagamma);
62 }
63
64 //! @brief PROC (REAL, REAL) REAL r psigamma
65
66 void genie_R_psigamma_real (NODE_T * p)
67 {
68 A68 (f_entry) = p;
69 A68_REAL *x, *s;
70 POP_OPERAND_ADDRESSES (p, x, s, A68_REAL);
71 errno = 0;
72 VALUE (x) = psigamma (VALUE (x), (int) VALUE (s));
73 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
74 }
75
76 #define D_3(a68_fun, R_fun)\
77 void a68_fun (NODE_T * p)\
78 {\
79 A68 (f_entry) = p;\
80 A68_BOOL give_log;\
81 A68_REAL a, b;\
82 POP_OBJECT (p, &give_log, A68_BOOL);\
83 POP_OBJECT (p, &b, A68_REAL);\
84 POP_OBJECT (p, &a, A68_REAL);\
85 errno = 0;\
86 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b),\
87 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
88 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
89 }
90
91 #define D_4(a68_fun, R_fun)\
92 void a68_fun (NODE_T * p)\
93 {\
94 A68 (f_entry) = p;\
95 A68_BOOL give_log;\
96 A68_REAL a, b, c;\
97 POP_OBJECT (p, &give_log, A68_BOOL);\
98 POP_OBJECT (p, &c, A68_REAL);\
99 POP_OBJECT (p, &b, A68_REAL);\
100 POP_OBJECT (p, &a, A68_REAL);\
101 errno = 0;\
102 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c),\
103 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
104 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
105 }
106
107 #define D_5(a68_fun, R_fun)\
108 void a68_fun (NODE_T * p)\
109 {\
110 A68 (f_entry) = p;\
111 A68_BOOL give_log;\
112 A68_REAL a, b, c, d;\
113 POP_OBJECT (p, &give_log, A68_BOOL);\
114 POP_OBJECT (p, &d, A68_REAL);\
115 POP_OBJECT (p, &c, A68_REAL);\
116 POP_OBJECT (p, &b, A68_REAL);\
117 POP_OBJECT (p, &a, A68_REAL);\
118 errno = 0;\
119 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c), VALUE (&d),\
120 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
121 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
122 }
123
124 #define PQ_4(a68_fun, R_fun)\
125 void a68_fun (NODE_T * p)\
126 {\
127 A68 (f_entry) = p;\
128 A68_BOOL lower_tail, log_p;\
129 A68_REAL x, a;\
130 POP_OBJECT (p, &log_p, A68_BOOL);\
131 POP_OBJECT (p, &lower_tail, A68_BOOL);\
132 POP_OBJECT (p, &a, A68_REAL);\
133 POP_OBJECT (p, &x, A68_REAL);\
134 errno = 0;\
135 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a),\
136 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
137 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
138 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
139 }
140
141 #define PQ_5(a68_fun, R_fun)\
142 void a68_fun (NODE_T * p)\
143 {\
144 A68 (f_entry) = p;\
145 A68_BOOL lower_tail, log_p;\
146 A68_REAL x, a, b;\
147 POP_OBJECT (p, &log_p, A68_BOOL);\
148 POP_OBJECT (p, &lower_tail, A68_BOOL);\
149 POP_OBJECT (p, &b, A68_REAL);\
150 POP_OBJECT (p, &a, A68_REAL);\
151 POP_OBJECT (p, &x, A68_REAL);\
152 errno = 0;\
153 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b),\
154 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
155 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
156 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
157 }
158
159 #define PQ_6(a68_fun, R_fun)\
160 void a68_fun (NODE_T * p)\
161 {\
162 A68 (f_entry) = p;\
163 A68_BOOL lower_tail, log_p;\
164 A68_REAL x, a, b, c;\
165 POP_OBJECT (p, &log_p, A68_BOOL);\
166 POP_OBJECT (p, &lower_tail, A68_BOOL);\
167 POP_OBJECT (p, &c, A68_REAL);\
168 POP_OBJECT (p, &b, A68_REAL);\
169 POP_OBJECT (p, &a, A68_REAL);\
170 POP_OBJECT (p, &x, A68_REAL);\
171 errno = 0;\
172 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b), VALUE (&c),\
173 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
174 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
175 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
176 }
177
178 #define R_1(a68_fun, R_fun)\
179 void a68_fun (NODE_T * p)\
180 {\
181 A68 (f_entry) = p;\
182 A68_REAL a;\
183 POP_OBJECT (p, &a, A68_REAL);\
184 errno = 0;\
185 PUSH_VALUE (p, R_fun (VALUE (&a)), A68_REAL);\
186 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
187 }
188
189 #define R_2(a68_fun, R_fun)\
190 void a68_fun (NODE_T * p)\
191 {\
192 A68 (f_entry) = p;\
193 A68_REAL a, b;\
194 POP_OBJECT (p, &b, A68_REAL);\
195 POP_OBJECT (p, &a, A68_REAL);\
196 errno = 0;\
197 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b)), A68_REAL);\
198 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
199 }
200
201 #define R_3(a68_fun, R_fun)\
202 void a68_fun (NODE_T * p)\
203 {\
204 A68 (f_entry) = p;\
205 A68_REAL a, b, c;\
206 POP_OBJECT (p, &c, A68_REAL);\
207 POP_OBJECT (p, &b, A68_REAL);\
208 POP_OBJECT (p, &a, A68_REAL);\
209 errno = 0;\
210 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c)), A68_REAL);\
211 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
212 }
213
214 //
215 // Distribution functions
216 //
217
218 // Chi squared
219
220 //! @brief PROC dchisq = (REAL x, df, BOOL give log) REAL
221 //! @brief PROC pchisq = (REAL x, df, BOOL lower tail, log p) REAL
222 //! @brief PROC qchisq = (REAL p, df, BOOL lower tail, log p) REAL
223 //! @brief PROC rchisq = (REAL df) REAL
224
225 D_3 (genie_R_dchisq_real, dchisq);
226 PQ_4 (genie_R_pchisq_real, pchisq);
227 PQ_4 (genie_R_qchisq_real, qchisq);
228 R_1 (genie_R_rchisq_real, rchisq);
229
230 // Exponential
231
232 //! @brief PROC dexp = (REAL x, scale, BOOL give log) REAL
233 //! @brief PROC pexp = (REAL x, scale, BOOL lower tail, log p) REAL
234 //! @brief PROC qexp = (REAL p, scale, BOOL lower tail, log p) REAL
235 //! @brief PROC rexp = (REAL scale) REAL
236
237 D_3 (genie_R_dexp_real, dexp);
238 PQ_4 (genie_R_pexp_real, pexp);
239 PQ_4 (genie_R_qexp_real, qexp);
240 R_1 (genie_R_rexp_real, rexp);
241
242 // Geometric
243
244 //! @brief PROC dgeom = (REAL x, p, BOOL give log) REAL
245 //! @brief PROC pgeom = (REAL x, p, BOOL lower tail, log p) REAL
246 //! @brief PROC qgeom = (REAL p, p, BOOL lower tail, log p) REAL
247 //! @brief PROC rgeom = (REAL p) REAL
248
249 D_3 (genie_R_dgeom_real, dgeom);
250 PQ_4 (genie_R_pgeom_real, pgeom);
251 PQ_4 (genie_R_qgeom_real, qgeom);
252 R_1 (genie_R_rgeom_real, rgeom);
253
254 // Poisson
255
256 //! @brief PROC dpois = (REAL x, lambda, BOOL give log) REAL
257 //! @brief PROC ppois = (REAL x, lambda, BOOL lower tail, log p) REAL
258 //! @brief PROC qpois = (REAL p, lambda, BOOL lower tail, log p) REAL
259 //! @brief PROC rpois = (REAL lambda) REAL
260
261 D_3 (genie_R_dpois_real, dpois);
262 PQ_4 (genie_R_ppois_real, ppois);
263 PQ_4 (genie_R_qpois_real, qpois);
264 R_1 (genie_R_rpois_real, rpois);
265
266 // Student
267
268 //! @brief PROC dt = (REAL x, n, BOOL give log) REAL
269 //! @brief PROC pt = (REAL x, n, BOOL lower tail, log p) REAL
270 //! @brief PROC qt = (REAL p, n, BOOL lower tail, log p) REAL
271 //! @brief PROC rt = (REAL n) REAL
272
273 D_3 (genie_R_dt_real, dt);
274 PQ_4 (genie_R_pt_real, pt);
275 PQ_4 (genie_R_qt_real, qt);
276 R_1 (genie_R_rt_real, rt);
277
278 // Beta
279
280 //! @brief PROC dbeta = (REAL x, a, b, BOOL give log) REAL
281 //! @brief PROC pbeta = (REAL x, a, b, BOOL lower tail, log p) REAL
282 //! @brief PROC qbeta = (REAL p, a, b, BOOL lower tail, log p) REAL
283 //! @brief PROC rbeta = (REAL p, a, b) REAL
284
285 D_4 (genie_R_dbeta_real, dbeta);
286 PQ_5 (genie_R_pbeta_real, pbeta);
287 PQ_5 (genie_R_qbeta_real, qbeta);
288 R_2 (genie_R_rbeta_real, rbeta);
289
290 // Binomial
291
292 //! @brief PROC dbinom = (REAL x, n, p, BOOL give log) REAL
293 //! @brief PROC pbinom = (REAL x, n, p, BOOL lower tail, log p) REAL
294 //! @brief PROC qbinom = (REAL p, n, p, BOOL lower tail, log p) REAL
295 //! @brief PROC rbinom = (REAL p, n, p) REAL
296
297 D_4 (genie_R_dbinom_real, dbinom);
298 PQ_5 (genie_R_pbinom_real, pbinom);
299 PQ_5 (genie_R_qbinom_real, qbinom);
300 R_2 (genie_R_rbinom_real, rbinom);
301
302 // Chi squared, non central
303
304 //! @brief PROC dnchisq = (REAL x, df, ncp, BOOL give log) REAL
305 //! @brief PROC pnchisq = (REAL x, df, ncp, BOOL lower tail, log p) REAL
306 //! @brief PROC qnchisq = (REAL p, df, ncp, BOOL lower tail, log p) REAL
307 //! @brief PROC rnchisq = (REAL p, df, ncp) REAL
308
309 D_4 (genie_R_dnchisq_real, dnchisq);
310 PQ_5 (genie_R_pnchisq_real, pnchisq);
311 PQ_5 (genie_R_qnchisq_real, qnchisq);
312
313 // Cauchy
314
315 //! @brief PROC dcauchy = (REAL x, location, scale, BOOL give log) REAL
316 //! @brief PROC pcauchy = (REAL x, location, scale, BOOL lower tail, log p) REAL
317 //! @brief PROC qcauchy = (REAL p, location, scale, BOOL lower tail, log p) REAL
318 //! @brief PROC rcauchy = (REAL p, location, scale) REAL
319
320 D_4 (genie_R_dcauchy_real, dcauchy);
321 PQ_5 (genie_R_pcauchy_real, pcauchy);
322 PQ_5 (genie_R_qcauchy_real, qcauchy);
323 R_2 (genie_R_rcauchy_real, rcauchy);
324
325 // F
326
327 //! @brief PROC df = (REAL x, n1, n2, BOOL give log) REAL
328 //! @brief PROC pf = (REAL x, n1, n2, BOOL lower tail, log p) REAL
329 //! @brief PROC qf = (REAL p, n1, n2, BOOL lower tail, log p) REAL
330 //! @brief PROC rf = (REAL p, n1, n2) REAL
331
332 D_4 (genie_R_df_real, df);
333 PQ_5 (genie_R_pf_real, pf);
334 PQ_5 (genie_R_qf_real, qf);
335 R_2 (genie_R_rf_real, rf);
336
337 // Logistic
338
339 //! @brief PROC dlogis = (REAL x, location, scale, BOOL give log) REAL
340 //! @brief PROC plogis = (REAL x, location, scale, BOOL lower tail, log p) REAL
341 //! @brief PROC qlogis = (REAL p, location, scale, BOOL lower tail, log p) REAL
342 //! @brief PROC rlogis = (REAL p, location, scale) REAL
343
344 D_4 (genie_R_dlogis_real, dlogis);
345 PQ_5 (genie_R_plogis_real, plogis);
346 PQ_5 (genie_R_qlogis_real, qlogis);
347 R_2 (genie_R_rlogis_real, rlogis);
348
349 // Log-normal
350
351 //! @brief PROC dlnorm = (REAL x, logmu, logsd, BOOL give log) REAL
352 //! @brief PROC plnorm = (REAL x, logmu, logsd, BOOL lower tail, log p) REAL
353 //! @brief PROC qlnorm = (REAL p, logmu, logsd, BOOL lower tail, log p) REAL
354 //! @brief PROC rlnorm = (REAL p, logmu, logsd) REAL
355
356 D_4 (genie_R_dlnorm_real, dlnorm);
357 PQ_5 (genie_R_plnorm_real, plnorm);
358 PQ_5 (genie_R_qlnorm_real, qlnorm);
359 R_2 (genie_R_rlnorm_real, rlnorm);
360
361 // Negative binomial
362
363 //! @brief PROC dnbinom = (REAL x, size, prob, BOOL give log) REAL
364 //! @brief PROC pnbinom = (REAL x, size, prob, BOOL lower tail, log p) REAL
365 //! @brief PROC qnbinom = (REAL p, size, prob, BOOL lower tail, log p) REAL
366 //! @brief PROC rnbinom = (REAL p, size, prob) REAL
367
368 D_4 (genie_R_dnbinom_real, dnbinom);
369 PQ_5 (genie_R_pnbinom_real, pnbinom);
370 PQ_5 (genie_R_qnbinom_real, qnbinom);
371 R_2 (genie_R_rnbinom_real, rnbinom);
372
373 // t, non-central
374
375 //! @brief PROC dnt = (REAL x, df, delta, BOOL give log) REAL
376 //! @brief PROC pnt = (REAL x, df, delta, BOOL lower tail, log p) REAL
377 //! @brief PROC qnt = (REAL p, df, delta, BOOL lower tail, log p) REAL
378
379 D_4 (genie_R_dnt_real, dnt);
380 PQ_5 (genie_R_pnt_real, pnt);
381 PQ_5 (genie_R_qnt_real, qnt);
382
383 // Normal
384
385 //! @brief PROC dnorm = (REAL x, mu, sigma, BOOL give log) REAL
386 //! @brief PROC pnorm = (REAL x, mu, sigma, BOOL lower tail, log p) REAL
387 //! @brief PROC qnorm = (REAL p, mu, sigma, BOOL lower tail, log p) REAL
388 //! @brief PROC rnorm = (REAL p, mu, sigma) REAL
389
390 D_4 (genie_R_dnorm_real, dnorm);
391 PQ_5 (genie_R_pnorm_real, pnorm);
392 PQ_5 (genie_R_qnorm_real, qnorm);
393 R_2 (genie_R_rnorm_real, rnorm);
394
395 // Uniform
396
397 //! @brief PROC dunif = (REAL x, a, b, BOOL give log) REAL
398 //! @brief PROC punif = (REAL x, a, b, BOOL lower tail, log p) REAL
399 //! @brief PROC qunif = (REAL p, a, b, BOOL lower tail, log p) REAL
400 //! @brief PROC runif = (REAL p, a, b) REAL
401
402 D_4 (genie_R_dunif_real, dunif);
403 PQ_5 (genie_R_punif_real, punif);
404 PQ_5 (genie_R_qunif_real, qunif);
405 R_2 (genie_R_runif_real, runif);
406
407 // Weibull
408
409 //! @brief PROC dweibull = (REAL x, shape, scale, BOOL give log) REAL
410 //! @brief PROC pweibull = (REAL x, shape, scale, BOOL lower tail, log p) REAL
411 //! @brief PROC qweibull = (REAL p, shape, scale, BOOL lower tail, log p) REAL
412 //! @brief PROC rweibull = (REAL p, shape, scale) REAL
413
414 D_4 (genie_R_dweibull_real, dweibull);
415 PQ_5 (genie_R_pweibull_real, pweibull);
416 PQ_5 (genie_R_qweibull_real, qweibull);
417 R_2 (genie_R_rweibull_real, rweibull);
418
419 // F, non central
420
421 //! @brief PROC dnf = (REAL x, n1, n2, ncp, BOOL give log) REAL
422 //! @brief PROC pnf = (REAL x, n1, n2, ncp, BOOL lower tail, log p) REAL
423 //! @brief PROC qnf = (REAL p, n1, n2, ncp, BOOL lower tail, log p) REAL
424
425 D_5 (genie_R_dnf_real, dnf);
426 PQ_6 (genie_R_pnf_real, pnf);
427 PQ_6 (genie_R_qnf_real, qnf);
428
429 // Hyper geometric
430
431 //! @brief PROC dhyper = (REAL x, nr, nb, n, BOOL give log) REAL
432 //! @brief PROC phyper = (REAL x, nr, nb, n, BOOL lower tail, log p) REAL
433 //! @brief PROC qhyper = (REAL p, nr, nb, n, BOOL lower tail, log p) REAL
434 //! @brief PROC rhyper = (REAL x, nr, nb, n, BOOL give log) REAL
435
436 D_5 (genie_R_dhyper_real, dhyper);
437 PQ_6 (genie_R_phyper_real, phyper);
438 PQ_6 (genie_R_qhyper_real, qhyper);
439 R_3 (genie_R_rhyper_real, rhyper);
440
441 // Tukey
442
443 //! @brief PROC ptukey = (REAL x, groups, df, treatments, BOOL lower tail, log p) REAL
444 //! @brief PROC qtukey = (REAL p, groups, df, treatments, BOOL lower tail, log p) REAL
445
446 PQ_6 (genie_R_ptukey_real, ptukey);
447 PQ_6 (genie_R_qtukey_real, qtukey);
448
449 // Wilcoxon
450
451 //! @brief PROC dwilcox = (REAL x, m, n, BOOL give log) REAL
452 //! @brief PROC pwilcox = (REAL x, m, n, BOOL lower tail, log p) REAL
453 //! @brief PROC qwilcox = (REAL p, m, n, BOOL lower tail, log p) REAL
454 //! @brief PROC rwilcox = (REAL p, m, n) REAL
455
456 void genie_R_dwilcox (NODE_T * p)
457 {
458 A68 (f_entry) = p;
459 A68_BOOL give_log;
460 A68_REAL a, b, c;
461 extern void wilcox_free (void);
462 POP_OBJECT (p, &give_log, A68_BOOL);
463 POP_OBJECT (p, &c, A68_REAL);
464 POP_OBJECT (p, &b, A68_REAL);
465 POP_OBJECT (p, &a, A68_REAL);
466 errno = 0;
467 PUSH_VALUE (p, dwilcox (VALUE (&a), VALUE (&b), VALUE (&c), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);
468 wilcox_free ();
469 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
470 }
471
472 void genie_R_pwilcox (NODE_T * p)
473 {
474 A68 (f_entry) = p;
475 A68_BOOL lower_tail, log_p;
476 A68_REAL x, a, b;
477 extern void wilcox_free (void);
478 POP_OBJECT (p, &log_p, A68_BOOL);
479 POP_OBJECT (p, &lower_tail, A68_BOOL);
480 POP_OBJECT (p, &b, A68_REAL);
481 POP_OBJECT (p, &a, A68_REAL);
482 POP_OBJECT (p, &x, A68_REAL);
483 errno = 0;
484 PUSH_VALUE (p, pwilcox (VALUE (&x), VALUE (&a), VALUE (&b), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
485 wilcox_free ();
486 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
487 }
488
489 void genie_R_qwilcox (NODE_T * p)
490 {
491 A68_BOOL lower_tail, log_p;
492 A68_REAL x, a, b;
493 extern void wilcox_free (void);
494 POP_OBJECT (p, &log_p, A68_BOOL);
495 POP_OBJECT (p, &lower_tail, A68_BOOL);
496 POP_OBJECT (p, &b, A68_REAL);
497 POP_OBJECT (p, &a, A68_REAL);
498 POP_OBJECT (p, &x, A68_REAL);
499 errno = 0;
500 PUSH_VALUE (p, qwilcox (VALUE (&x), VALUE (&a), VALUE (&b), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
501 wilcox_free ();
502 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
503 }
504
505 R_2 (genie_R_rwilcox_real, rwilcox);
506
507 // Wilcoxon sign rank
508
509 //! @brief PROC dsignrank = (REAL x, n, BOOL give log) REAL
510 //! @brief PROC psignrank = (REAL x, n, BOOL lower tail, log p) REAL
511 //! @brief PROC qsignrank = (REAL p, n, BOOL lower tail, log p) REAL
512 //! @brief PROC rsignrank = (REAL p, n) REAL
513
514 void genie_R_dsignrank (NODE_T * p)
515 {
516 A68_BOOL give_log;
517 A68_REAL a, b;
518 extern void signrank_free (void);
519 POP_OBJECT (p, &give_log, A68_BOOL);
520 POP_OBJECT (p, &b, A68_REAL);
521 POP_OBJECT (p, &a, A68_REAL);
522 errno = 0;
523 PUSH_VALUE (p, dsignrank (VALUE (&a), VALUE (&b), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);
524 signrank_free ();
525 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
526 }
527
528 void genie_R_psignrank (NODE_T * p)
529 {
530 A68_BOOL lower_tail, log_p;
531 A68_REAL x, a;
532 extern void signrank_free (void);
533 POP_OBJECT (p, &log_p, A68_BOOL);
534 POP_OBJECT (p, &lower_tail, A68_BOOL);
535 POP_OBJECT (p, &a, A68_REAL);
536 POP_OBJECT (p, &x, A68_REAL);
537 errno = 0;
538 PUSH_VALUE (p, psignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
539 signrank_free ();
540 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
541 }
542
543 void genie_R_qsignrank (NODE_T * p)
544 {
545 A68_BOOL lower_tail, log_p;
546 A68_REAL x, a;
547 extern void signrank_free (void);
548 POP_OBJECT (p, &log_p, A68_BOOL);
549 POP_OBJECT (p, &lower_tail, A68_BOOL);
550 POP_OBJECT (p, &a, A68_REAL);
551 POP_OBJECT (p, &x, A68_REAL);
552 errno = 0;
553 PUSH_VALUE (p, qsignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
554 signrank_free ();
555 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
556 }
557
558 R_1 (genie_R_rsignrank_real, rsignrank);
559
560 #endif
