| /* |
| * Mathlib : A C Library of Special Functions |
| * Copyright (C) 1998-2016 The R Core Team |
| * |
| * This program is free software; you can redistribute it and/or modify |
| * it under the terms of the GNU General Public License as published by |
| * the Free Software Foundation; either version 2 of the License, or |
| * (at your option) any later version. |
| * |
| * This program is distributed in the hope that it will be useful, |
| * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| * GNU General Public License for more details. |
| * |
| * You should have received a copy of the GNU General Public License |
| * along with this program; if not, a copy is available at |
| * https://www.R-project.org/Licenses/ |
| */ |
| |
| /* Private header file for use during compilation of Mathlib */ |
| #ifndef MATHLIB_PRIVATE_H |
| #define MATHLIB_PRIVATE_H |
| |
| #ifdef HAVE_CONFIG_H |
| # include <config.h> |
| #endif |
| |
| /* Required by C99 but might be slow */ |
| #ifdef HAVE_LONG_DOUBLE |
| # define LDOUBLE long double |
| #else |
| # define LDOUBLE double |
| #endif |
| |
| /* To ensure atanpi, cospi, sinpi, tanpi are defined */ |
| # ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ |
| # define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1 |
| # endif |
| |
| #include <math.h> |
| #include <float.h> /* DBL_MIN etc */ |
| |
| #include <Rconfig.h> |
| #include <Rmath.h> |
| |
| /* Used internally only */ |
| double Rf_d1mach(int); |
| double Rf_gamma_cody(double); |
| |
| #include <R_ext/RS.h> |
| |
| /* possibly needed for debugging */ |
| #include <R_ext/Print.h> |
| |
| /* moved from dpq.h */ |
| #ifdef HAVE_NEARYINT |
| # define R_forceint(x) nearbyint() |
| #else |
| # define R_forceint(x) round(x) |
| #endif |
| //R >= 3.1.0: # define R_nonint(x) (fabs((x) - R_forceint(x)) > 1e-7) |
| # define R_nonint(x) (fabs((x) - R_forceint(x)) > 1e-7*fmax2(1., fabs(x))) |
| |
| #ifndef MATHLIB_STANDALONE |
| |
| #include <R_ext/Error.h> |
| # define MATHLIB_ERROR(fmt,x) error(fmt,x); |
| # define MATHLIB_WARNING(fmt,x) warning(fmt,x) |
| # define MATHLIB_WARNING2(fmt,x,x2) warning(fmt,x,x2) |
| # define MATHLIB_WARNING3(fmt,x,x2,x3) warning(fmt,x,x2,x3) |
| # define MATHLIB_WARNING4(fmt,x,x2,x3,x4) warning(fmt,x,x2,x3,x4) |
| # define MATHLIB_WARNING5(fmt,x,x2,x3,x4,x5) warning(fmt,x,x2,x3,x4,x5) |
| |
| #include <R_ext/Arith.h> |
| #define ML_POSINF R_PosInf |
| #define ML_NEGINF R_NegInf |
| #define ML_NAN R_NaN |
| |
| |
| void R_CheckUserInterrupt(void); |
| /* Ei-ji Nakama reported that AIX 5.2 has calloc as a macro and objected |
| to redefining it. Tests added for 2.2.1 */ |
| #ifdef calloc |
| # undef calloc |
| #endif |
| #define calloc R_chk_calloc |
| #ifdef free |
| # undef free |
| #endif |
| #define free R_chk_free |
| |
| #ifdef ENABLE_NLS |
| #include <libintl.h> |
| #define _(String) gettext (String) |
| #else |
| #define _(String) (String) |
| #endif |
| |
| #else |
| /* Mathlib standalone */ |
| |
| #include <stdio.h> |
| #include <stdlib.h> /* for exit */ |
| #define MATHLIB_ERROR(fmt,x) { printf(fmt,x); exit(1); } |
| #define MATHLIB_WARNING(fmt,x) printf(fmt,x) |
| #define MATHLIB_WARNING2(fmt,x,x2) printf(fmt,x,x2) |
| #define MATHLIB_WARNING3(fmt,x,x2,x3) printf(fmt,x,x2,x3) |
| #define MATHLIB_WARNING4(fmt,x,x2,x3,x4) printf(fmt,x,x2,x3,x4) |
| #define MATHLIB_WARNING5(fmt,x,x2,x3,x4,x5) printf(fmt,x,x2,x3,x4,x5) |
| |
| #define ISNAN(x) (isnan(x)!=0) |
| // Arith.h defines it |
| #ifndef R_FINITE |
| #ifdef HAVE_WORKING_ISFINITE |
| /* isfinite is defined in <math.h> according to C99 */ |
| # define R_FINITE(x) isfinite(x) |
| #else |
| # define R_FINITE(x) R_finite(x) |
| #endif |
| #endif |
| int R_finite(double); |
| |
| #define ML_POSINF (1.0 / 0.0) |
| #define ML_NEGINF ((-1.0) / 0.0) |
| #define ML_NAN (0.0 / 0.0) |
| |
| #define _(String) String |
| #endif /* standalone */ |
| |
| #define ML_VALID(x) (!ISNAN(x)) |
| |
| #define ME_NONE 0 |
| /* no error */ |
| #define ME_DOMAIN 1 |
| /* argument out of domain */ |
| #define ME_RANGE 2 |
| /* value out of range */ |
| #define ME_NOCONV 4 |
| /* process did not converge */ |
| #define ME_PRECISION 8 |
| /* does not have "full" precision */ |
| #define ME_UNDERFLOW 16 |
| /* and underflow occured (important for IEEE)*/ |
| |
| #define ML_ERR_return_NAN { ML_ERROR(ME_DOMAIN, ""); return ML_NAN; } |
| |
| /* For a long time prior to R 2.3.0 ML_ERROR did nothing. |
| We don't report ME_DOMAIN errors as the callers collect ML_NANs into |
| a single warning. |
| */ |
| #define ML_ERROR(x, s) { \ |
| if(x > ME_DOMAIN) { \ |
| char *msg = ""; \ |
| switch(x) { \ |
| case ME_DOMAIN: \ |
| msg = _("argument out of domain in '%s'\n"); \ |
| break; \ |
| case ME_RANGE: \ |
| msg = _("value out of range in '%s'\n"); \ |
| break; \ |
| case ME_NOCONV: \ |
| msg = _("convergence failed in '%s'\n"); \ |
| break; \ |
| case ME_PRECISION: \ |
| msg = _("full precision may not have been achieved in '%s'\n"); \ |
| break; \ |
| case ME_UNDERFLOW: \ |
| msg = _("underflow occurred in '%s'\n"); \ |
| break; \ |
| } \ |
| MATHLIB_WARNING(msg, s); \ |
| } \ |
| } |
| |
| /* Wilcoxon Rank Sum Distribution */ |
| |
| #define WILCOX_MAX 50 |
| |
| #ifdef HAVE_VISIBILITY_ATTRIBUTE |
| # define attribute_hidden __attribute__ ((visibility ("hidden"))) |
| #else |
| # define attribute_hidden |
| #endif |
| |
| /* Formerly private part of Mathlib.h */ |
| |
| /* always remap internal functions */ |
| #define bd0 Rf_bd0 |
| #define chebyshev_eval Rf_chebyshev_eval |
| #define chebyshev_init Rf_chebyshev_init |
| #define gammalims Rf_gammalims |
| #define lfastchoose Rf_lfastchoose |
| #define lgammacor Rf_lgammacor |
| #define stirlerr Rf_stirlerr |
| #define pnchisq_raw Rf_pnchisq_raw |
| #define pgamma_raw Rf_pgamma_raw |
| #define pnbeta_raw Rf_pnbeta_raw |
| #define pnbeta2 Rf_pnbeta2 |
| #define bratio Rf_bratio |
| |
| /* Chebyshev Series */ |
| |
| int attribute_hidden chebyshev_init(double*, int, double); |
| double attribute_hidden chebyshev_eval(double, const double *, const int); |
| |
| /* Gamma and Related Functions */ |
| |
| void attribute_hidden gammalims(double*, double*); |
| double attribute_hidden lgammacor(double); /* log(gamma) correction */ |
| double attribute_hidden stirlerr(double); /* Stirling expansion "error" */ |
| |
| double attribute_hidden lfastchoose(double, double); |
| |
| double attribute_hidden bd0(double, double); |
| |
| double attribute_hidden pnchisq_raw(double, double, double, double, double, |
| int, Rboolean, Rboolean); |
| double attribute_hidden pgamma_raw(double, double, int, int); |
| double attribute_hidden pbeta_raw(double, double, double, int, int); |
| double attribute_hidden qchisq_appr(double, double, double, int, int, double tol); |
| LDOUBLE attribute_hidden pnbeta_raw(double, double, double, double, double); |
| double attribute_hidden pnbeta2(double, double, double, double, double, int, int); |
| |
| int Rf_i1mach(int); |
| |
| /* From toms708.c */ |
| void attribute_hidden bratio(double a, double b, double x, double y, |
| double *w, double *w1, int *ierr, int log_p); |
| |
| |
| #endif /* MATHLIB_PRIVATE_H */ |