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-2024 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 //! REAL GNU R math routines.
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_REAL *x, *s;
69 POP_OPERAND_ADDRESSES (p, x, s, A68_REAL);
70 errno = 0;
71 VALUE (x) = psigamma (VALUE (x), (int) VALUE (s));
72 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
73 }
74
75 #define D_3(a68_fun, R_fun)\
76 void a68_fun (NODE_T * p)\
77 {\
78 A68_BOOL give_log;\
79 A68_REAL a, b;\
80 POP_OBJECT (p, &give_log, A68_BOOL);\
81 POP_OBJECT (p, &b, A68_REAL);\
82 POP_OBJECT (p, &a, A68_REAL);\
83 errno = 0;\
84 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b),\
85 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
86 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
87 }
88
89 #define D_4(a68_fun, R_fun)\
90 void a68_fun (NODE_T * p)\
91 {\
92 A68_BOOL give_log;\
93 A68_REAL a, b, c;\
94 POP_OBJECT (p, &give_log, A68_BOOL);\
95 POP_OBJECT (p, &c, A68_REAL);\
96 POP_OBJECT (p, &b, A68_REAL);\
97 POP_OBJECT (p, &a, A68_REAL);\
98 errno = 0;\
99 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c),\
100 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
101 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
102 }
103
104 #define D_5(a68_fun, R_fun)\
105 void a68_fun (NODE_T * p)\
106 {\
107 A68_BOOL give_log;\
108 A68_REAL a, b, c, d;\
109 POP_OBJECT (p, &give_log, A68_BOOL);\
110 POP_OBJECT (p, &d, A68_REAL);\
111 POP_OBJECT (p, &c, A68_REAL);\
112 POP_OBJECT (p, &b, A68_REAL);\
113 POP_OBJECT (p, &a, A68_REAL);\
114 errno = 0;\
115 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c), VALUE (&d),\
116 (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);\
117 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
118 }
119
120 #define PQ_4(a68_fun, R_fun)\
121 void a68_fun (NODE_T * p)\
122 {\
123 A68_BOOL lower_tail, log_p;\
124 A68_REAL x, a;\
125 POP_OBJECT (p, &log_p, A68_BOOL);\
126 POP_OBJECT (p, &lower_tail, A68_BOOL);\
127 POP_OBJECT (p, &a, A68_REAL);\
128 POP_OBJECT (p, &x, A68_REAL);\
129 errno = 0;\
130 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a),\
131 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
132 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
133 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
134 }
135
136 #define PQ_5(a68_fun, R_fun)\
137 void a68_fun (NODE_T * p)\
138 {\
139 A68_BOOL lower_tail, log_p;\
140 A68_REAL x, a, b;\
141 POP_OBJECT (p, &log_p, A68_BOOL);\
142 POP_OBJECT (p, &lower_tail, A68_BOOL);\
143 POP_OBJECT (p, &b, A68_REAL);\
144 POP_OBJECT (p, &a, A68_REAL);\
145 POP_OBJECT (p, &x, A68_REAL);\
146 errno = 0;\
147 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b),\
148 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
149 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
150 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
151 }
152
153 #define PQ_6(a68_fun, R_fun)\
154 void a68_fun (NODE_T * p)\
155 {\
156 A68_BOOL lower_tail, log_p;\
157 A68_REAL x, a, b, c;\
158 POP_OBJECT (p, &log_p, A68_BOOL);\
159 POP_OBJECT (p, &lower_tail, A68_BOOL);\
160 POP_OBJECT (p, &c, A68_REAL);\
161 POP_OBJECT (p, &b, A68_REAL);\
162 POP_OBJECT (p, &a, A68_REAL);\
163 POP_OBJECT (p, &x, A68_REAL);\
164 errno = 0;\
165 PUSH_VALUE (p, R_fun (VALUE (&x), VALUE (&a), VALUE (&b), VALUE (&c),\
166 (VALUE (&lower_tail) == A68_TRUE ? 1 : 0),\
167 (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);\
168 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
169 }
170
171 #define R_1(a68_fun, R_fun)\
172 void a68_fun (NODE_T * p)\
173 {\
174 A68_REAL a;\
175 POP_OBJECT (p, &a, A68_REAL);\
176 errno = 0;\
177 PUSH_VALUE (p, R_fun (VALUE (&a)), A68_REAL);\
178 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
179 }
180
181 #define R_2(a68_fun, R_fun)\
182 void a68_fun (NODE_T * p)\
183 {\
184 A68_REAL a, b;\
185 POP_OBJECT (p, &b, A68_REAL);\
186 POP_OBJECT (p, &a, A68_REAL);\
187 errno = 0;\
188 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b)), A68_REAL);\
189 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
190 }
191
192 #define R_3(a68_fun, R_fun)\
193 void a68_fun (NODE_T * p)\
194 {\
195 A68_REAL a, b, c;\
196 POP_OBJECT (p, &c, A68_REAL);\
197 POP_OBJECT (p, &b, A68_REAL);\
198 POP_OBJECT (p, &a, A68_REAL);\
199 errno = 0;\
200 PUSH_VALUE (p, R_fun (VALUE (&a), VALUE (&b), VALUE (&c)), A68_REAL);\
201 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);\
202 }
203
204 // Distribution functions
205
206 // Chi squared
207
208 //! @brief PROC dchisq = (REAL x, df, BOOL give log) REAL
209 //! @brief PROC pchisq = (REAL x, df, BOOL lower tail, give log) REAL
210 //! @brief PROC qchisq = (REAL p, df, BOOL lower tail, log p) REAL
211 //! @brief PROC rchisq = (REAL df) REAL
212
213 D_3 (genie_R_dchisq_real, dchisq);
214 PQ_4 (genie_R_pchisq_real, pchisq);
215 PQ_4 (genie_R_qchisq_real, qchisq);
216 R_1 (genie_R_rchisq_real, rchisq);
217
218 // Exponential
219
220 //! @brief PROC dexp = (REAL x, scale, BOOL give log) REAL
221 //! @brief PROC pexp = (REAL x, scale, BOOL lower tail, give log) REAL
222 //! @brief PROC qexp = (REAL p, scale, BOOL lower tail, log p) REAL
223 //! @brief PROC rexp = (REAL scale) REAL
224
225 D_3 (genie_R_dexp_real, dexp);
226 PQ_4 (genie_R_pexp_real, pexp);
227 PQ_4 (genie_R_qexp_real, qexp);
228 R_1 (genie_R_rexp_real, rexp);
229
230 // Geometric
231
232 //! @brief PROC dgeom = (REAL x, p, BOOL give log) REAL
233 //! @brief PROC pgeom = (REAL x, p, BOOL lower tail, give log) REAL
234 //! @brief PROC qgeom = (REAL p, p, BOOL lower tail, log p) REAL
235 //! @brief PROC rgeom = (REAL p) REAL
236
237 D_3 (genie_R_dgeom_real, dgeom);
238 PQ_4 (genie_R_pgeom_real, pgeom);
239 PQ_4 (genie_R_qgeom_real, qgeom);
240 R_1 (genie_R_rgeom_real, rgeom);
241
242 // Poisson
243
244 //! @brief PROC dpois = (REAL x, lambda, BOOL give log) REAL
245 //! @brief PROC ppois = (REAL x, lambda, BOOL lower tail, give log) REAL
246 //! @brief PROC qpois = (REAL p, lambda, BOOL lower tail, log p) REAL
247 //! @brief PROC rpois = (REAL lambda) REAL
248
249 D_3 (genie_R_dpois_real, dpois);
250 PQ_4 (genie_R_ppois_real, ppois);
251 PQ_4 (genie_R_qpois_real, qpois);
252 R_1 (genie_R_rpois_real, rpois);
253
254 // Student
255
256 //! @brief PROC dt = (REAL x, n, BOOL give log) REAL
257 //! @brief PROC pt = (REAL x, n, BOOL lower tail, give log) REAL
258 //! @brief PROC qt = (REAL p, n, BOOL lower tail, log p) REAL
259 //! @brief PROC rt = (REAL n) REAL
260
261 D_3 (genie_R_dt_real, dt);
262 PQ_4 (genie_R_pt_real, pt);
263 PQ_4 (genie_R_qt_real, qt);
264 R_1 (genie_R_rt_real, rt);
265
266 // Beta
267
268 //! @brief PROC dbeta = (REAL x, a, b, BOOL give log) REAL
269 //! @brief PROC pbeta = (REAL x, a, b, BOOL lower tail, give log) REAL
270 //! @brief PROC qbeta = (REAL p, a, b, BOOL lower tail, log p) REAL
271 //! @brief PROC rbeta = (REAL a, b) REAL
272
273 D_4 (genie_R_dbeta_real, dbeta);
274 PQ_5 (genie_R_pbeta_real, pbeta);
275 PQ_5 (genie_R_qbeta_real, qbeta);
276 R_2 (genie_R_rbeta_real, rbeta);
277
278 // Binomial
279
280 //! @brief PROC dbinom = (REAL x, n, p, BOOL give log) REAL
281 //! @brief PROC pbinom = (REAL x, n, p, BOOL lower tail, give log) REAL
282 //! @brief PROC qbinom = (REAL p, n, p, BOOL lower tail, log p) REAL
283 //! @brief PROC rbinom = (REAL n, p) REAL
284
285 D_4 (genie_R_dbinom_real, dbinom);
286 PQ_5 (genie_R_pbinom_real, pbinom);
287 PQ_5 (genie_R_qbinom_real, qbinom);
288 R_2 (genie_R_rbinom_real, rbinom);
289
290 // Chi squared, non central
291
292 //! @brief PROC dnchisq = (REAL x, df, ncp, BOOL give log) REAL
293 //! @brief PROC pnchisq = (REAL x, df, ncp, BOOL lower tail, give log) REAL
294 //! @brief PROC qnchisq = (REAL p, df, ncp, BOOL lower tail, log p) REAL
295 //! @brief PROC rnchisq = (REAL df, ncp) REAL
296
297 D_4 (genie_R_dnchisq_real, dnchisq);
298 PQ_5 (genie_R_pnchisq_real, pnchisq);
299 PQ_5 (genie_R_qnchisq_real, qnchisq);
300 R_2 (genie_R_rnchisq_real, rnchisq);
301
302 // Cauchy
303
304 //! @brief PROC dcauchy = (REAL x, location, scale, BOOL give log) REAL
305 //! @brief PROC pcauchy = (REAL x, location, scale, BOOL lower tail, give log) REAL
306 //! @brief PROC qcauchy = (REAL p, location, scale, BOOL lower tail, log p) REAL
307 //! @brief PROC rcauchy = (REAL location, scale) REAL
308
309 D_4 (genie_R_dcauchy_real, dcauchy);
310 PQ_5 (genie_R_pcauchy_real, pcauchy);
311 PQ_5 (genie_R_qcauchy_real, qcauchy);
312 R_2 (genie_R_rcauchy_real, rcauchy);
313
314 // F
315
316 //! @brief PROC df = (REAL x, n1, n2, BOOL give log) REAL
317 //! @brief PROC pf = (REAL x, n1, n2, BOOL lower tail, give log) REAL
318 //! @brief PROC qf = (REAL p, n1, n2, BOOL lower tail, log p) REAL
319 //! @brief PROC rf = (REAL n1, n2) REAL
320
321 D_4 (genie_R_df_real, df);
322 PQ_5 (genie_R_pf_real, pf);
323 PQ_5 (genie_R_qf_real, qf);
324 R_2 (genie_R_rf_real, rf);
325
326 // Logistic
327
328 //! @brief PROC dlogis = (REAL x, location, scale, BOOL give log) REAL
329 //! @brief PROC plogis = (REAL x, location, scale, BOOL lower tail, give log) REAL
330 //! @brief PROC qlogis = (REAL p, location, scale, BOOL lower tail, log p) REAL
331 //! @brief PROC rlogis = (REAL location, scale) REAL
332
333 D_4 (genie_R_dlogis_real, dlogis);
334 PQ_5 (genie_R_plogis_real, plogis);
335 PQ_5 (genie_R_qlogis_real, qlogis);
336 R_2 (genie_R_rlogis_real, rlogis);
337
338 // Log-normal
339
340 //! @brief PROC dlnorm = (REAL x, logmu, logsd, BOOL give log) REAL
341 //! @brief PROC plnorm = (REAL x, logmu, logsd, BOOL lower tail, give log) REAL
342 //! @brief PROC qlnorm = (REAL p, logmu, logsd, BOOL lower tail, log p) REAL
343 //! @brief PROC rlnorm = (REAL logmu, logsd) REAL
344
345 D_4 (genie_R_dlnorm_real, dlnorm);
346 PQ_5 (genie_R_plnorm_real, plnorm);
347 PQ_5 (genie_R_qlnorm_real, qlnorm);
348 R_2 (genie_R_rlnorm_real, rlnorm);
349
350 // Negative binomial
351
352 //! @brief PROC dnbinom = (REAL x, size, prob, BOOL give log) REAL
353 //! @brief PROC pnbinom = (REAL x, size, prob, BOOL lower tail, give log) REAL
354 //! @brief PROC qnbinom = (REAL p, size, prob, BOOL lower tail, log p) REAL
355 //! @brief PROC rnbinom = (REAL size, prob) REAL
356
357 D_4 (genie_R_dnbinom_real, dnbinom);
358 PQ_5 (genie_R_pnbinom_real, pnbinom);
359 PQ_5 (genie_R_qnbinom_real, qnbinom);
360 R_2 (genie_R_rnbinom_real, rnbinom);
361
362 // t, non-central
363
364 //! @brief PROC dnt = (REAL x, df, delta, BOOL give log) REAL
365 //! @brief PROC pnt = (REAL x, df, delta, BOOL lower tail, give log) REAL
366 //! @brief PROC qnt = (REAL p, df, delta, BOOL lower tail, log p) REAL
367
368 D_4 (genie_R_dnt_real, dnt);
369 PQ_5 (genie_R_pnt_real, pnt);
370 PQ_5 (genie_R_qnt_real, qnt);
371
372 // Normal
373
374 //! @brief PROC dnorm = (REAL x, mu, sigma, BOOL give log) REAL
375 //! @brief PROC pnorm = (REAL x, mu, sigma, BOOL lower tail, give log) REAL
376 //! @brief PROC qnorm = (REAL p, mu, sigma, BOOL lower tail, log p) REAL
377 //! @brief PROC rnorm = (REAL mu, sigma) REAL
378
379 D_4 (genie_R_dnorm_real, dnorm);
380 PQ_5 (genie_R_pnorm_real, pnorm);
381 PQ_5 (genie_R_qnorm_real, qnorm);
382 R_2 (genie_R_rnorm_real, rnorm);
383
384 // Uniform
385
386 //! @brief PROC dunif = (REAL x, a, b, BOOL give log) REAL
387 //! @brief PROC punif = (REAL x, a, b, BOOL lower tail, give log) REAL
388 //! @brief PROC qunif = (REAL p, a, b, BOOL lower tail, log p) REAL
389 //! @brief PROC runif = (REAL a, b) REAL
390
391 D_4 (genie_R_dunif_real, dunif);
392 PQ_5 (genie_R_punif_real, punif);
393 PQ_5 (genie_R_qunif_real, qunif);
394 R_2 (genie_R_runif_real, runif);
395
396 // Weibull
397
398 //! @brief PROC dweibull = (REAL x, shape, scale, BOOL give log) REAL
399 //! @brief PROC pweibull = (REAL x, shape, scale, BOOL lower tail, give log) REAL
400 //! @brief PROC qweibull = (REAL p, shape, scale, BOOL lower tail, log p) REAL
401 //! @brief PROC rweibull = (REAL shape, scale) REAL
402
403 D_4 (genie_R_dweibull_real, dweibull);
404 PQ_5 (genie_R_pweibull_real, pweibull);
405 PQ_5 (genie_R_qweibull_real, qweibull);
406 R_2 (genie_R_rweibull_real, rweibull);
407
408 // F, non central
409
410 //! @brief PROC dnf = (REAL x, n1, n2, ncp, BOOL give log) REAL
411 //! @brief PROC pnf = (REAL x, n1, n2, ncp, BOOL lower tail, give log) REAL
412 //! @brief PROC qnf = (REAL p, n1, n2, ncp, BOOL lower tail, log p) REAL
413
414 D_5 (genie_R_dnf_real, dnf);
415 PQ_6 (genie_R_pnf_real, pnf);
416 PQ_6 (genie_R_qnf_real, qnf);
417
418 // Hyper geometric
419
420 //! @brief PROC dhyper = (REAL x, nr, nb, n, BOOL give log) REAL
421 //! @brief PROC phyper = (REAL x, nr, nb, n, BOOL lower tail, give log) REAL
422 //! @brief PROC qhyper = (REAL p, nr, nb, n, BOOL lower tail, log p) REAL
423 //! @brief PROC rhyper = (REAL nr, nb, n) REAL
424
425 D_5 (genie_R_dhyper_real, dhyper);
426 PQ_6 (genie_R_phyper_real, phyper);
427 PQ_6 (genie_R_qhyper_real, qhyper);
428 R_3 (genie_R_rhyper_real, rhyper);
429
430 // Tukey
431
432 //! @brief PROC ptukey = (REAL x, groups, df, treatments, BOOL lower tail, give log) REAL
433 //! @brief PROC qtukey = (REAL p, groups, df, treatments, BOOL lower tail, log p) REAL
434
435 PQ_6 (genie_R_ptukey_real, ptukey);
436 PQ_6 (genie_R_qtukey_real, qtukey);
437
438 // Wilcoxon
439
440 //! @brief PROC dwilcox = (REAL x, m, n, BOOL give log) REAL
441 //! @brief PROC pwilcox = (REAL x, m, n, BOOL lower tail, give log) REAL
442 //! @brief PROC qwilcox = (REAL p, m, n, BOOL lower tail, log p) REAL
443 //! @brief PROC rwilcox = (REAL m, n) REAL
444
445 void genie_R_dwilcox_real (NODE_T * p)
446 {
447 A68_BOOL give_log;
448 A68_REAL a, b, c;
449 extern void wilcox_free (void);
450 POP_OBJECT (p, &give_log, A68_BOOL);
451 POP_OBJECT (p, &c, A68_REAL);
452 POP_OBJECT (p, &b, A68_REAL);
453 POP_OBJECT (p, &a, A68_REAL);
454 errno = 0;
455 PUSH_VALUE (p, dwilcox (VALUE (&a), VALUE (&b), VALUE (&c), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);
456 wilcox_free ();
457 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
458 }
459
460 void genie_R_pwilcox_real (NODE_T * p)
461 {
462 A68_BOOL lower_tail, log_p;
463 A68_REAL x, a, b;
464 extern void wilcox_free (void);
465 POP_OBJECT (p, &log_p, A68_BOOL);
466 POP_OBJECT (p, &lower_tail, A68_BOOL);
467 POP_OBJECT (p, &b, A68_REAL);
468 POP_OBJECT (p, &a, A68_REAL);
469 POP_OBJECT (p, &x, A68_REAL);
470 errno = 0;
471 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);
472 wilcox_free ();
473 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
474 }
475
476 void genie_R_qwilcox_real (NODE_T * p)
477 {
478 A68_BOOL lower_tail, log_p;
479 A68_REAL x, a, b;
480 extern void wilcox_free (void);
481 POP_OBJECT (p, &log_p, A68_BOOL);
482 POP_OBJECT (p, &lower_tail, A68_BOOL);
483 POP_OBJECT (p, &b, A68_REAL);
484 POP_OBJECT (p, &a, A68_REAL);
485 POP_OBJECT (p, &x, A68_REAL);
486 errno = 0;
487 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);
488 wilcox_free ();
489 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
490 }
491
492 R_2 (genie_R_rwilcox_real, rwilcox);
493
494 // Wilcoxon sign rank
495
496 //! @brief PROC dsignrank = (REAL x, n, BOOL give log) REAL
497 //! @brief PROC psignrank = (REAL x, n, BOOL lower tail, give log) REAL
498 //! @brief PROC qsignrank = (REAL p, n, BOOL lower tail, log p) REAL
499 //! @brief PROC rsignrank = (REAL n) REAL
500
501 void genie_R_dsignrank_real (NODE_T * p)
502 {
503 A68_BOOL give_log;
504 A68_REAL a, b;
505 extern void signrank_free (void);
506 POP_OBJECT (p, &give_log, A68_BOOL);
507 POP_OBJECT (p, &b, A68_REAL);
508 POP_OBJECT (p, &a, A68_REAL);
509 errno = 0;
510 PUSH_VALUE (p, dsignrank (VALUE (&a), VALUE (&b), (VALUE (&give_log) == A68_TRUE ? 1 : 0)), A68_REAL);
511 signrank_free ();
512 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
513 }
514
515 void genie_R_psignrank_real (NODE_T * p)
516 {
517 A68_BOOL lower_tail, log_p;
518 A68_REAL x, a;
519 extern void signrank_free (void);
520 POP_OBJECT (p, &log_p, A68_BOOL);
521 POP_OBJECT (p, &lower_tail, A68_BOOL);
522 POP_OBJECT (p, &a, A68_REAL);
523 POP_OBJECT (p, &x, A68_REAL);
524 errno = 0;
525 PUSH_VALUE (p, psignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
526 signrank_free ();
527 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
528 }
529
530 void genie_R_qsignrank_real (NODE_T * p)
531 {
532 A68_BOOL lower_tail, log_p;
533 A68_REAL x, a;
534 extern void signrank_free (void);
535 POP_OBJECT (p, &log_p, A68_BOOL);
536 POP_OBJECT (p, &lower_tail, A68_BOOL);
537 POP_OBJECT (p, &a, A68_REAL);
538 POP_OBJECT (p, &x, A68_REAL);
539 errno = 0;
540 PUSH_VALUE (p, qsignrank (VALUE (&x), VALUE (&a), (VALUE (&lower_tail) == A68_TRUE ? 1 : 0), (VALUE (&log_p) == A68_TRUE ? 1 : 0)), A68_REAL);
541 signrank_free ();
542 PRELUDE_ERROR (errno != 0, p, ERROR_MATH_EXCEPTION, NO_TEXT);
543 }
544
545 R_1 (genie_R_rsignrank_real, rsignrank);
546
547 #endif
|
© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)
|
