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