├── .github ├── dependabot.yml └── workflows │ └── CI.yml ├── .gitignore ├── COPYING ├── Makefile ├── README.md ├── RVERSION ├── include ├── R_ext │ ├── Arith.h │ ├── Boolean.h │ ├── Error.h │ ├── Print.h │ ├── RS.h │ ├── Random.h │ └── libextern.h ├── Rconfig.h ├── Rmath.h ├── callback.h └── config.h ├── patches └── thread-local.patch ├── src ├── .gitignore ├── Makefile ├── bd0.c ├── bessel.h ├── bessel_i.c ├── bessel_j.c ├── bessel_k.c ├── bessel_y.c ├── beta.c ├── callback.c ├── chebyshev.c ├── choose.c ├── cospi.c ├── d1mach.c ├── dbeta.c ├── dbinom.c ├── dcauchy.c ├── dchisq.c ├── dexp.c ├── df.c ├── dgamma.c ├── dgeom.c ├── dhyper.c ├── dlnorm.c ├── dlogis.c ├── dnbeta.c ├── dnbinom.c ├── dnchisq.c ├── dnf.c ├── dnorm.c ├── dnt.c ├── dpois.c ├── dpq.h ├── dt.c ├── dunif.c ├── dweibull.c ├── expm1.c ├── fmax2.c ├── fmin2.c ├── fprec.c ├── fround.c ├── fsign.c ├── ftrunc.c ├── gamma.c ├── gamma_cody.c ├── gammalims.c ├── i1mach.c ├── imax2.c ├── imin2.c ├── lbeta.c ├── lgamma.c ├── lgammacor.c ├── log1p.c ├── mlutils.c ├── nmath.h ├── nmath2.h ├── pbeta.c ├── pbinom.c ├── pcauchy.c ├── pchisq.c ├── pexp.c ├── pf.c ├── pgamma.c ├── pgeom.c ├── phyper.c ├── plnorm.c ├── plogis.c ├── pnbeta.c ├── pnbinom.c ├── pnchisq.c ├── pnf.c ├── pnorm.c ├── pnt.c ├── polygamma.c ├── ppois.c ├── pt.c ├── ptukey.c ├── punif.c ├── pweibull.c ├── qDiscrete_search.h ├── qbeta.c ├── qbinom.c ├── qcauchy.c ├── qchisq.c ├── qexp.c ├── qf.c ├── qgamma.c ├── qgeom.c ├── qhyper.c ├── qlnorm.c ├── qlogis.c ├── qnbeta.c ├── qnbinom.c ├── qnbinom_mu.c ├── qnchisq.c ├── qnf.c ├── qnorm.c ├── qnt.c ├── qpois.c ├── qt.c ├── qtukey.c ├── qunif.c ├── qweibull.c ├── rbeta.c ├── rbinom.c ├── rcauchy.c ├── rchisq.c ├── rexp.c ├── rf.c ├── rgamma.c ├── rgeom.c ├── rhyper.c ├── rlnorm.c ├── rlogis.c ├── rmultinom.c ├── rnbinom.c ├── rnchisq.c ├── rnorm.c ├── rpois.c ├── rt.c ├── runif.c ├── rweibull.c ├── sign.c ├── signrank.c ├── stirlerr.c ├── sunif.c ├── toms708.c └── wilcox.c └── test.jl /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | # https://docs.github.com/github/administering-a-repository/configuration-options-for-dependency-updates 2 | version: 2 3 | updates: 4 | - package-ecosystem: "github-actions" 5 | directory: "/" # Location of package manifests 6 | schedule: 7 | interval: "monthly" 8 | -------------------------------------------------------------------------------- /.github/workflows/CI.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | pull_request: 4 | branches: 5 | - master 6 | push: 7 | branches: 8 | - master 9 | tags: '*' 10 | jobs: 11 | test: 12 | name: Julia ${{ matrix.version }} - ${{ matrix.os }} - ${{ matrix.arch }} - ${{ github.event_name }} 13 | runs-on: ${{ matrix.os }} 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | version: 18 | - 'lts' 19 | - '1' 20 | os: 21 | - ubuntu-latest 22 | - windows-latest 23 | - macOS-13 24 | arch: 25 | - x64 26 | include: 27 | - os: macOS-latest 28 | arch: aarch64 29 | version: '1' 30 | steps: 31 | - uses: actions/checkout@v4 32 | - uses: julia-actions/setup-julia@latest 33 | with: 34 | version: ${{ matrix.version }} 35 | arch: ${{ matrix.arch }} 36 | - run: make -j 37 | env: 38 | CC: gcc 39 | - run: julia test.jl 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | 4 | # Libraries 5 | *.lib 6 | *.a 7 | 8 | # Shared objects (inc. Windows DLLs) 9 | *.dll 10 | *.so 11 | *.so.* 12 | *.dylib 13 | 14 | # Executables 15 | *.exe 16 | *.out 17 | *.app 18 | 19 | # R tarballs 20 | R-*.tar.gz 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | RVERSION := $(shell cat RVERSION) 2 | 3 | 4 | all: 5 | $(MAKE) -C src 6 | 7 | clean: 8 | $(MAKE) -C src clean 9 | rm -rf R-* 10 | 11 | R-$(RVERSION).tar.gz: 12 | curl -L -O https://cran.r-project.org/src/base/R-4/$@ 13 | 14 | update: R-$(RVERSION).tar.gz 15 | tar -xzvf $< --strip-components 3 -C src --include '*/src/nmath/*.[ch]' \ 16 | --exclude '*/sexp.c' --exclude '*/snorm.c' --exclude '*/standalone/*' 17 | find include/R_ext -name '*.h' | xargs -I {} tar -xzvf $< --strip-components 2 '*/src/{}' 18 | tar -xzvf $< --strip-components 2 '*/src/include/Rmath.h0.in' 19 | mv -f include/Rmath.h0.in include/Rmath.h 20 | patch -p1 < patches/thread-local.patch 21 | 22 | .PHONY: all clean update 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Rmath-julia 2 | =========== 3 | 4 | [![CI](https://github.com/JuliaStats/Rmath-julia/actions/workflows/CI.yml/badge.svg)](https://github.com/JuliaStats/Rmath-julia/actions/workflows/CI.yml) 5 | 6 | This is a slightly modified version of the [standalone Rmath library from R](https://cran.r-project.org/doc/manuals/r-release/R-admin.html#The-standalone-Rmath-library), built to be 7 | used with the [Rmath.jl](https://github.com/JuliaStats/Rmath.jl) Julia package. 8 | 9 | The main difference is that it is built to allow defining custom random number generating 10 | functions via C function pointers (see `include/callback.h`). When using the library, 11 | these should be defined before calling any of the random functions. 12 | 13 | Build instructions 14 | ------------------ 15 | 16 | Rmath-julia requires GNU Make (https://www.gnu.org/software/make). Just run 17 | `make` to compile the library. 18 | 19 | Updating 20 | -------- 21 | 22 | To update to the latest version of R, bump the `RVERSION` file, and run `make 23 | update`. Some additional manual changes to the headers may be necessary: these should go 24 | in `include/Rconfig.h` (this would typically be generated by autotools, but we try to 25 | simplify the build process). Please also check that declarations with `_Thread_local` are not dropped as part of the update, see https://github.com/JuliaStats/Rmath-julia/pull/50. 26 | -------------------------------------------------------------------------------- /RVERSION: -------------------------------------------------------------------------------- 1 | 4.4.1 2 | -------------------------------------------------------------------------------- /include/R_ext/Arith.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 1998--2016 The R Core Team. 5 | * 6 | * This header file is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU Lesser General Public License as published by 8 | * the Free Software Foundation; either version 2.1 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This file is part of R. R is distributed under the terms of the 12 | * GNU General Public License, either Version 2, June 1991 or Version 3, 13 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 14 | * 15 | * This program is distributed in the hope that it will be useful, 16 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | * GNU Lesser General Public License for more details. 19 | * 20 | * You should have received a copy of the GNU Lesser General Public License 21 | * along with this program; if not, a copy is available at 22 | * https://www.R-project.org/Licenses/ 23 | */ 24 | 25 | /* Included by R.h: API */ 26 | 27 | #ifndef R_ARITH_H_ 28 | #define R_ARITH_H_ 29 | 30 | /* 31 | This used to define _BSD_SOURCE to make declarations of isfinite 32 | and isnan visible in glibc. But that was deprecated in glibc 2.20, 33 | and --std=c99 suffices nowadays. 34 | */ 35 | 36 | #include 37 | #ifdef __cplusplus 38 | extern "C" { 39 | #else 40 | /* needed for isnan and isfinite, neither of which are used under C++ */ 41 | # include 42 | #endif 43 | 44 | /* implementation of these : ../../main/arithmetic.c */ 45 | LibExtern double R_NaN; /* IEEE NaN */ 46 | LibExtern double R_PosInf; /* IEEE Inf */ 47 | LibExtern double R_NegInf; /* IEEE -Inf */ 48 | LibExtern double R_NaReal; /* NA_REAL: IEEE */ 49 | LibExtern int R_NaInt; /* NA_INTEGER:= INT_MIN currently */ 50 | #ifdef __MAIN__ 51 | #undef extern 52 | #undef LibExtern 53 | #endif 54 | 55 | #define NA_LOGICAL R_NaInt 56 | #define NA_INTEGER R_NaInt 57 | /* #define NA_FACTOR R_NaInt unused */ 58 | #define NA_REAL R_NaReal 59 | /* NA_STRING is a SEXP, so defined in Rinternals.h */ 60 | 61 | int R_IsNA(double); /* True for R's NA only */ 62 | int R_IsNaN(double); /* True for special NaN, *not* for NA */ 63 | int R_finite(double); /* True if none of NA, NaN, +/-Inf */ 64 | #define ISNA(x) R_IsNA(x) 65 | 66 | /* ISNAN(): True for *both* NA and NaN. 67 | NOTE: some systems do not return 1 for TRUE. 68 | Also note that C++ math headers specifically undefine 69 | isnan if it is a macro (it is on macOS and in C99), 70 | hence the workaround. This code also appears in Rmath.h 71 | */ 72 | #ifdef __cplusplus 73 | int R_isnancpp(double); /* in arithmetic.c */ 74 | # define ISNAN(x) R_isnancpp(x) 75 | #else 76 | # define ISNAN(x) (isnan(x)!=0) 77 | #endif 78 | 79 | /* The following is only defined inside R */ 80 | #ifdef HAVE_WORKING_ISFINITE 81 | /* isfinite is defined in according to C99 */ 82 | # define R_FINITE(x) isfinite(x) 83 | #else 84 | # define R_FINITE(x) R_finite(x) 85 | #endif 86 | 87 | #ifdef __cplusplus 88 | } 89 | #endif 90 | 91 | #endif /* R_ARITH_H_ */ 92 | -------------------------------------------------------------------------------- /include/R_ext/Boolean.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2000, 2001 The R Core Team. 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: API */ 25 | 26 | #ifndef R_EXT_BOOLEAN_H_ 27 | #define R_EXT_BOOLEAN_H_ 28 | 29 | #undef FALSE 30 | #undef TRUE 31 | 32 | #ifdef __cplusplus 33 | extern "C" { 34 | #endif 35 | typedef enum { FALSE = 0, TRUE /*, MAYBE */ } Rboolean; 36 | 37 | #ifdef __cplusplus 38 | } 39 | #endif 40 | 41 | #endif /* R_EXT_BOOLEAN_H_ */ 42 | -------------------------------------------------------------------------------- /include/R_ext/Error.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1998-2023 The R Core Team 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: API */ 25 | 26 | #ifndef R_ERROR_H_ 27 | #define R_ERROR_H_ 28 | 29 | #include 30 | 31 | #ifdef __cplusplus 32 | extern "C" { 33 | #endif 34 | 35 | /* C23 has a [[noreturn]] attribute supported in GCC 13 and LLVM clang 36 | * 15 with -std=c2x but not Apple clang 14. All have version 202000L. 37 | * In C11 there is _Noreturn * (or noreturn in header ). 38 | */ 39 | #if defined NORET 40 | #elif (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 202301L) 41 | # define NORET [[noreturn]] 42 | #elif defined(__STDC_VERSION__) && __STDC_VERSION__ >= 201102L 43 | # define NORET _Noreturn 44 | #elif defined(__GNUC__) && __GNUC__ >= 3 45 | // LLVM and Apple clang identify themselves as 4. 46 | // But Mandriva (or OpenMandriva) is said to patch clang to 11. 47 | // Boost also uses this for __SUNPRO_CC >= 0x590 48 | # define NORET __attribute__((noreturn)) 49 | #else 50 | # define NORET 51 | #endif 52 | 53 | NORET void Rf_error(const char *, ...) R_PRINTF_FORMAT(1, 2); 54 | 55 | NORET void UNIMPLEMENTED(const char *); 56 | NORET void WrongArgCount(const char *); 57 | 58 | void Rf_warning(const char *, ...) R_PRINTF_FORMAT(1,2); 59 | 60 | void R_ShowMessage(const char *s); 61 | 62 | 63 | #ifdef __cplusplus 64 | } 65 | #endif 66 | 67 | #ifndef R_NO_REMAP 68 | #define error Rf_error 69 | #define warning Rf_warning 70 | #endif 71 | 72 | 73 | #endif /* R_ERROR_H_ */ 74 | -------------------------------------------------------------------------------- /include/R_ext/Print.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1998-2024 The R Core Team 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: API */ 25 | 26 | #ifndef R_EXT_PRINT_H_ 27 | #define R_EXT_PRINT_H_ 28 | 29 | #ifdef __cplusplus 30 | /* If the vprintf interface is defined at all in C++ it may only be 31 | defined in namespace std. It is part of the C++11 standard. */ 32 | # if __cplusplus >= 201103L && !defined(R_USE_C99_IN_CXX) 33 | # define R_USE_C99_IN_CXX 34 | # endif 35 | # ifdef R_USE_C99_IN_CXX 36 | # include 37 | # define R_VA_LIST std::va_list 38 | # endif 39 | extern "C" { 40 | #else 41 | # include 42 | # define R_VA_LIST va_list 43 | #endif 44 | 45 | #ifdef __GNUC__ 46 | # ifdef _WIN32 47 | # if defined(_UCRT) || ((__MSVCRT_VERSION__ >= 0x1400) || \ 48 | (__MSVCRT_VERSION__ >= 0xE00 && __MSVCRT_VERSION__ < 0x1000)) 49 | # if defined(__clang__) 50 | # define R_PRINTF_FORMAT(M,N) __attribute__ ((format (printf, M, N))) 51 | # else 52 | # define R_PRINTF_FORMAT(M,N) __attribute__ ((format (gnu_printf, M, N))) 53 | # endif 54 | # else 55 | # define R_PRINTF_FORMAT(M,N) 56 | # endif 57 | # else 58 | # define R_PRINTF_FORMAT(M,N) __attribute__ ((format (printf, M, N))) 59 | # endif 60 | #else 61 | # define R_PRINTF_FORMAT(M,N) 62 | #endif 63 | 64 | void Rprintf(const char *, ...) R_PRINTF_FORMAT(1, 2); 65 | void REprintf(const char *, ...) R_PRINTF_FORMAT(1, 2); 66 | 67 | #if !defined(__cplusplus) || defined R_USE_C99_IN_CXX 68 | 69 | void Rvprintf(const char *, R_VA_LIST) R_PRINTF_FORMAT(1, 0); 70 | void REvprintf(const char *, R_VA_LIST) R_PRINTF_FORMAT(1, 0); 71 | 72 | #endif 73 | 74 | #ifdef __cplusplus 75 | } 76 | #endif 77 | 78 | #endif /* R_EXT_PRINT_H_ */ 79 | -------------------------------------------------------------------------------- /include/R_ext/RS.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1999-2022 The R Core Team. 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: mainly API */ 25 | 26 | #ifndef R_RS_H 27 | #define R_RS_H 28 | 29 | #if defined(__cplusplus) && !defined(DO_NOT_USE_CXX_HEADERS) 30 | # include 31 | # include 32 | # define R_SIZE_T std::size_t 33 | #else 34 | # include /* for memcpy, memset */ 35 | # include /* for size_t */ 36 | # define R_SIZE_T size_t 37 | #endif 38 | 39 | #include /* for F77_APPEND_UNDERSCORE */ 40 | 41 | #ifdef __cplusplus 42 | extern "C" { 43 | #endif 44 | 45 | /* S Like Memory Management */ 46 | 47 | extern void *R_chk_calloc(R_SIZE_T, R_SIZE_T); 48 | extern void *R_chk_realloc(void *, R_SIZE_T); 49 | extern void R_chk_free(void *); 50 | 51 | #ifndef STRICT_R_HEADERS 52 | /* S-PLUS 3.x but not 5.x NULLed the pointer in Free */ 53 | #define Calloc(n, t) (t *) R_chk_calloc( (R_SIZE_T) (n), sizeof(t) ) 54 | #define Realloc(p,n,t) (t *) R_chk_realloc( (void *)(p), (R_SIZE_T)((n) * sizeof(t)) ) 55 | #define Free(p) (R_chk_free( (void *)(p) ), (p) = NULL) 56 | #endif 57 | 58 | #define R_Calloc(n, t) (t *) R_chk_calloc( (R_SIZE_T) (n), sizeof(t) ) 59 | #define R_Realloc(p,n,t) (t *) R_chk_realloc( (void *)(p), (R_SIZE_T)((n) * sizeof(t)) ) 60 | #define R_Free(p) (R_chk_free( (void *)(p) ), (p) = NULL) 61 | 62 | /* undocumented until 4.1.2: widely used. */ 63 | #define Memcpy(p,q,n) memcpy( p, q, (R_SIZE_T)(n) * sizeof(*p) ) 64 | 65 | /* added for 3.0.0 but undocumented until 4.1.2. 66 | Used by a couple of packages. */ 67 | #define Memzero(p,n) memset(p, 0, (R_SIZE_T)(n) * sizeof(*p)) 68 | 69 | /* Added in R 2.6.0 */ 70 | #define CallocCharBuf(n) (char *) R_chk_calloc(((R_SIZE_T)(n))+1, sizeof(char)) 71 | 72 | /* S Like Fortran Interface */ 73 | /* These may not be adequate everywhere. Convex had _ prepending common 74 | blocks, and some compilers may need to specify Fortran linkage */ 75 | 76 | #ifdef HAVE_F77_UNDERSCORE 77 | # define F77_CALL(x) x ## _ 78 | #else 79 | # define F77_CALL(x) x 80 | #endif 81 | #define F77_NAME(x) F77_CALL(x) 82 | #define F77_SUB(x) F77_CALL(x) 83 | #define F77_COM(x) F77_CALL(x) 84 | #define F77_COMDECL(x) F77_CALL(x) 85 | 86 | /* Deprecated in R 2.15.0, non-API 87 | #if !defined(NO_CALL_R) && defined(DECLARE_LEGACY_CALL_R) 88 | void call_R(char*, long, void**, char**, long*, char**, long, char**); 89 | #endif 90 | */ 91 | 92 | #ifdef __cplusplus 93 | } 94 | #endif 95 | 96 | #endif /* R_RS_H */ 97 | -------------------------------------------------------------------------------- /include/R_ext/Random.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1998-2022 The R Core Team 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: API */ 25 | 26 | #ifndef R_RANDOM_H 27 | #define R_RANDOM_H 28 | 29 | #include 30 | 31 | #ifdef __cplusplus 32 | extern "C" { 33 | #endif 34 | 35 | typedef enum { 36 | WICHMANN_HILL, 37 | MARSAGLIA_MULTICARRY, 38 | SUPER_DUPER, 39 | MERSENNE_TWISTER, 40 | KNUTH_TAOCP, 41 | USER_UNIF, 42 | KNUTH_TAOCP2, 43 | LECUYER_CMRG 44 | } RNGtype; 45 | 46 | /* Different kinds of "N(0,1)" generators :*/ 47 | typedef enum { 48 | BUGGY_KINDERMAN_RAMAGE, 49 | AHRENS_DIETER, 50 | BOX_MULLER, 51 | USER_NORM, 52 | INVERSION, 53 | KINDERMAN_RAMAGE 54 | } N01type; 55 | 56 | /* Different ways to generate discrete uniform samples */ 57 | typedef enum { 58 | ROUNDING, 59 | REJECTION 60 | } Sampletype; 61 | Sampletype R_sample_kind(void); 62 | 63 | void GetRNGstate(void); 64 | void PutRNGstate(void); 65 | 66 | double unif_rand(void); 67 | double R_unif_index(double); 68 | /* These are also defined in Rmath.h */ 69 | double norm_rand(void); 70 | double exp_rand(void); 71 | 72 | typedef unsigned int Int32; 73 | double * user_unif_rand(void); 74 | void user_unif_init(Int32); 75 | int * user_unif_nseed(void); 76 | int * user_unif_seedloc(void); 77 | 78 | double * user_norm_rand(void); 79 | 80 | #ifdef __cplusplus 81 | } 82 | #endif 83 | 84 | #endif /* R_RANDOM_H */ 85 | -------------------------------------------------------------------------------- /include/R_ext/libextern.h: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2001, 2022 The R Core Team. 4 | * 5 | * This header file is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU Lesser General Public License as published by 7 | * the Free Software Foundation; either version 2.1 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This file is part of R. R is distributed under the terms of the 11 | * GNU General Public License, either Version 2, June 1991 or Version 3, 12 | * June 2007. See doc/COPYRIGHTS for details of the copyright status of R. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU Lesser General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU Lesser General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | */ 23 | 24 | /* Included by R.h: API on Windows */ 25 | 26 | /* don't disallow including this one more than once */ 27 | 28 | /* This is intended to be called from other header files, so not callable 29 | from C++ */ 30 | 31 | #undef LibExtern 32 | #undef LibImport 33 | #undef LibExport 34 | 35 | #ifdef _WIN32 /* _WIN32 as does not depend on config.h */ 36 | #define LibImport __declspec(dllimport) 37 | /* exporting is now done via .def file in R */ 38 | #define LibExport /* __declspec(dllexport) */ 39 | #else 40 | #define LibImport 41 | #define LibExport 42 | #endif 43 | 44 | #ifdef __MAIN__ 45 | #define LibExtern LibExport 46 | #define extern 47 | #elif defined(R_DLL_BUILD) 48 | #define LibExtern extern 49 | #else 50 | #define LibExtern extern LibImport 51 | #endif 52 | -------------------------------------------------------------------------------- /include/Rconfig.h: -------------------------------------------------------------------------------- 1 | /* Rconfig.h. 2 | * 3 | * Originally generated automatically, but modified by Simon Byrne to avoid the 4 | * need for autotools. 5 | */ 6 | 7 | 8 | #ifndef R_RCONFIG_H 9 | #define R_RCONFIG_H 10 | 11 | #ifndef R_CONFIG_H 12 | 13 | #define HAVE_F77_UNDERSCORE 1 14 | #define IEEE_754 1 15 | /* #undef HAVE_VISIBILITY_ATTRIBUTE */ 16 | #define ENABLE_NLS 1 17 | 18 | /* All of the following assume a correct C99 implementation. */ 19 | #define HAVE_NEARBYINT 1 20 | #define HAVE_RINT 1 21 | #define HAVE_WORKING_ISFINITE 1 22 | #define HAVE_HYPOT 1 23 | #define HAVE_EXPM1 1 24 | #define HAVE_LOG1P 1 25 | #define HAVE_WORKING_LOG1P 1 26 | 27 | #endif /* not R_CONFIG_H */ 28 | 29 | #endif /* not R_RCONFIG_H */ 30 | -------------------------------------------------------------------------------- /include/callback.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Function pointers for callbacks for random number generators. 3 | */ 4 | extern double (*norm_rand_ptr)(void); 5 | extern double (*unif_rand_ptr)(void); 6 | extern double (*exp_rand_ptr)(void); 7 | -------------------------------------------------------------------------------- /include/config.h: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/JuliaStats/Rmath-julia/6f2d37ff112914d65559bc3e0035b325c11cf361/include/config.h -------------------------------------------------------------------------------- /src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.dylib 3 | *.so 4 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | # -*- mode: makefile -*- 2 | 3 | # Default value, can be overriden on the command line 4 | # or with an environment variable. 5 | CC ?= gcc 6 | 7 | OS = $(shell uname) 8 | 9 | ifneq (,$(findstring MINGW,$(OS))) 10 | override OS := Windows_NT 11 | endif 12 | ifneq (,$(findstring MSYS,$(OS))) 13 | override OS := Windows_NT 14 | endif 15 | ifneq (,$(findstring CYGWIN,$(OS))) 16 | override OS := Windows_NT 17 | endif 18 | 19 | ifeq ($(OS), Darwin) 20 | SHLIB_EXT = dylib 21 | else ifeq ($(OS), Windows_NT) 22 | SHLIB_EXT = dll 23 | else 24 | SHLIB_EXT = so 25 | endif 26 | 27 | SRCS = $(wildcard *.c) 28 | OBJS = $(SRCS:%.c=%.o) 29 | DOBJS = $(SRCS:%.c=%.do) 30 | 31 | ifneq ($(MAKECMDGOALS),debug) 32 | XOBJS = $(OBJS) 33 | else 34 | XOBJS = $(DOBJS) 35 | endif 36 | 37 | CFLAGS += -DMATHLIB_STANDALONE -fPIC -O3 -std=c99 -I../include 38 | 39 | default: release 40 | 41 | %.o: %.c 42 | $(CC) $(CPPFLAGS) $(CFLAGS) -DNDEBUG -c $< -o $@ 43 | %.do: %.c 44 | $(CC) $(CPPFLAGS) $(CFLAGS) -g -c $< -o $@ 45 | 46 | release debug: libRmath-julia.$(SHLIB_EXT) 47 | 48 | libRmath-julia.$(SHLIB_EXT): $(XOBJS) 49 | -rm -f $@ 50 | $(CC) $(LDFLAGS) -shared -o $@ $^ 51 | 52 | clean: 53 | -rm -f *.o *.do *.a *.$(SHLIB_EXT) core* *~ *# 54 | -------------------------------------------------------------------------------- /src/beta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2014 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double beta(double a, double b); 24 | * 25 | * DESCRIPTION 26 | * 27 | * This function returns the value of the beta function 28 | * evaluated with arguments a and b. 29 | * 30 | * NOTES 31 | * 32 | * This routine is a translation into C of a Fortran subroutine 33 | * by W. Fullerton of Los Alamos Scientific Laboratory. 34 | * Some modifications have been made so that the routines 35 | * conform to the IEEE 754 standard. 36 | */ 37 | 38 | #include "nmath.h" 39 | 40 | double beta(double a, double b) 41 | { 42 | #ifdef NOMORE_FOR_THREADS 43 | static double xmin, xmax = 0;/*-> typically = 171.61447887 for IEEE */ 44 | static double lnsml = 0;/*-> typically = -708.3964185 */ 45 | 46 | if (xmax == 0) { 47 | gammalims(&xmin, &xmax); 48 | lnsml = log(d1mach(1)); 49 | } 50 | #else 51 | /* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 : 52 | * xmin, xmax : see ./gammalims.c 53 | * lnsml = log(DBL_MIN) = log(2 ^ -1022) = -1022 * log(2) 54 | */ 55 | # define xmin -170.5674972726612 56 | # define xmax 171.61447887182298 57 | # define lnsml -708.39641853226412 58 | #endif 59 | 60 | 61 | #ifdef IEEE_754 62 | /* NaNs propagated correctly */ 63 | if(ISNAN(a) || ISNAN(b)) return a + b; 64 | #endif 65 | 66 | if (a < 0 || b < 0) 67 | ML_WARN_return_NAN 68 | else if (a == 0 || b == 0) 69 | return ML_POSINF; 70 | else if (!R_FINITE(a) || !R_FINITE(b)) 71 | return 0; 72 | 73 | if (a + b < xmax) {/* ~= 171.61 for IEEE */ 74 | // return gammafn(a) * gammafn(b) / gammafn(a+b); 75 | /* All the terms are positive, and all can be large for large 76 | or small arguments. They are never much less than one. 77 | gammafn(x) can still overflow for x ~ 1e-308, 78 | but the result would too. 79 | */ 80 | return (1 / gammafn(a+b)) * gammafn(a) * gammafn(b); 81 | } else { 82 | double val = lbeta(a, b); 83 | // underflow to 0 is not harmful per se; exp(-999) also gives no warning 84 | #ifndef IEEE_754 85 | if (val < lnsml) { 86 | /* a and/or b so big that beta underflows */ 87 | ML_WARNING(ME_UNDERFLOW, "beta"); 88 | /* return ML_UNDERFLOW; pointless giving incorrect value */ 89 | } 90 | #endif 91 | return exp(val); 92 | } 93 | } 94 | -------------------------------------------------------------------------------- /src/callback.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Function pointers for callbacks for random number generators. 3 | */ 4 | double (*unif_rand_ptr)(void) = 0; 5 | double (*norm_rand_ptr)(void) = 0; 6 | double (*exp_rand_ptr)(void) = 0; 7 | 8 | double unif_rand(void) 9 | { 10 | return (*unif_rand_ptr)(); 11 | } 12 | double norm_rand(void) 13 | { 14 | return (*norm_rand_ptr)(); 15 | } 16 | double exp_rand(void) 17 | { 18 | return (*exp_rand_ptr)(); 19 | } 20 | -------------------------------------------------------------------------------- /src/chebyshev.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * int chebyshev_init(double *dos, int nos, double eta) 22 | * double chebyshev_eval(double x, double *a, int n) 23 | * 24 | * DESCRIPTION 25 | * 26 | * "chebyshev_init" determines the number of terms for the 27 | * double precision orthogonal series "dos" needed to insure 28 | * the error is no larger than "eta". Ordinarily eta will be 29 | * chosen to be one-tenth machine precision. 30 | * 31 | * "chebyshev_eval" evaluates the n-term Chebyshev series 32 | * "a" at "x". 33 | * 34 | * NOTES 35 | * 36 | * These routines are translations into C of Fortran routines 37 | * by W. Fullerton of Los Alamos Scientific Laboratory. 38 | * 39 | * Based on the Fortran routine dcsevl by W. Fullerton. 40 | * Adapted from R. Broucke, Algorithm 446, CACM., 16, 254 (1973). 41 | */ 42 | 43 | #include "nmath.h" 44 | 45 | /* NaNs propagated correctly */ 46 | 47 | 48 | int attribute_hidden chebyshev_init(double *dos, int nos, double eta) 49 | { 50 | int i, ii; 51 | double err; 52 | 53 | if (nos < 1) 54 | return 0; 55 | 56 | err = 0.0; 57 | i = 0; /* just to avoid compiler warnings */ 58 | for (ii=1; ii<=nos; ii++) { 59 | i = nos - ii; 60 | err += fabs(dos[i]); 61 | if (err > eta) { 62 | return i; 63 | } 64 | } 65 | return i; 66 | } 67 | 68 | 69 | double attribute_hidden chebyshev_eval(double x, const double *a, const int n) 70 | { 71 | double b0, b1, b2, twox; 72 | int i; 73 | 74 | if (n < 1 || n > 1000) ML_WARN_return_NAN; 75 | 76 | if (x < -1.1 || x > 1.1) ML_WARN_return_NAN; 77 | 78 | twox = x * 2; 79 | b2 = b1 = 0; 80 | b0 = 0; 81 | for (i = 1; i <= n; i++) { 82 | b2 = b1; 83 | b1 = b0; 84 | b0 = twox * b1 - b2 + a[n - i]; 85 | } 86 | return (b0 - b2) * 0.5; 87 | } 88 | -------------------------------------------------------------------------------- /src/cospi.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2013-2022 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | */ 15 | 16 | #include "nmath.h" 17 | 18 | /* HAVE_COSPI etc will not be defined in standalone-use: the 19 | intention is to make the versions here available in that case. 20 | 21 | The __cospi etc variants are from macOS (and perhaps other BSD-based systems). 22 | */ 23 | 24 | #ifdef HAVE_COSPI 25 | #elif defined HAVE___COSPI 26 | double cospi(double x) { 27 | return __cospi(x); 28 | } 29 | #else 30 | // cos(pi * x) -- exact when x = k/2 for all integer k 31 | double cospi(double x) { 32 | #ifdef IEEE_754 33 | /* NaNs propagated correctly */ 34 | if (ISNAN(x)) return x; 35 | #endif 36 | if(!R_FINITE(x)) ML_WARN_return_NAN; 37 | 38 | x = fmod(fabs(x), 2.);// cos() symmetric; cos(pi(x + 2k)) == cos(pi x) for all integer k 39 | if(fmod(x, 1.) == 0.5) return 0.; 40 | if( x == 1.) return -1.; 41 | if( x == 0.) return 1.; 42 | // otherwise 43 | return cos(M_PI * x); 44 | } 45 | #endif 46 | 47 | #ifdef HAVE_SINPI 48 | #elif defined HAVE___SINPI 49 | double sinpi(double x) { 50 | return __sinpi(x); 51 | } 52 | #else 53 | // sin(pi * x) -- exact when x = k/2 for all integer k 54 | double sinpi(double x) { 55 | #ifdef IEEE_754 56 | if (ISNAN(x)) return x; 57 | #endif 58 | if(!R_FINITE(x)) ML_WARN_return_NAN; 59 | 60 | x = fmod(x, 2.); // sin(pi(x + 2k)) == sin(pi x) for all integer k 61 | // map (-2,2) --> (-1,1] : 62 | if(x <= -1) x += 2.; else if (x > 1.) x -= 2.; 63 | if(x == 0. || x == 1.) return 0.; 64 | if(x == 0.5) return 1.; 65 | if(x == -0.5) return -1.; 66 | // otherwise 67 | return sin(M_PI * x); 68 | } 69 | #endif 70 | 71 | // tan(pi * x) -- exact when x = k/4 for all integer k and half-values give NaN 72 | // ----------- e.g. used in ../main/arithmetic.c : 73 | double Rtanpi(double x) 74 | { 75 | #ifdef IEEE_754 76 | if (ISNAN(x)) return x; 77 | #endif 78 | if(!R_FINITE(x)) ML_WARN_return_NAN; 79 | 80 | x = fmod(x, 1.); // tan(pi(x + k)) == tan(pi x) for all integer k 81 | // map (-1,1] --> (-1/2, 1/2] : 82 | if(x <= -0.5) x++; else if(x > 0.5) x--; 83 | return (x == 0.) ? 0. : 84 | ((x == 0.5 ) ? ML_NAN : 85 | ((x == 0.25) ? 1. : 86 | ((x == -0.25) ? -1. : 87 | tan(M_PI * x) 88 | ))); 89 | } 90 | 91 | #if defined(HAVE_TANPI) || defined(HAVE___TANPI) 92 | #else 93 | double tanpi(double x) { 94 | return Rtanpi(x); 95 | } 96 | #endif 97 | 98 | #if !defined(HAVE_TANPI) && defined(HAVE___TANPI) 99 | double tanpi(double x) { 100 | return __tanpi(x); 101 | } 102 | /* #else tanpi() defined from C standard math lib */ 103 | #endif 104 | -------------------------------------------------------------------------------- /src/d1mach.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib - A Mathematical Function Library 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2014 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | 21 | /* NaNs propagated correctly */ 22 | 23 | 24 | /*-- FIXME: Eliminate calls to these 25 | * ===== o from C code when 26 | * o it is only used to initialize "static" variables (threading) 27 | * and use the DBL_... constants instead 28 | */ 29 | 30 | #include "nmath.h" 31 | 32 | attribute_hidden double Rf_d1mach(int i) 33 | { 34 | switch(i) { 35 | case 1: return DBL_MIN; 36 | case 2: return DBL_MAX; 37 | 38 | case 3: /* = FLT_RADIX ^ - DBL_MANT_DIG 39 | for IEEE: = 2^-53 = 1.110223e-16 = .5*DBL_EPSILON */ 40 | return 0.5*DBL_EPSILON; 41 | 42 | case 4: /* = FLT_RADIX ^ (1- DBL_MANT_DIG) = 43 | for IEEE: = 2^-52 = DBL_EPSILON */ 44 | return DBL_EPSILON; 45 | 46 | case 5: return M_LOG10_2; 47 | 48 | default: return 0.0; 49 | } 50 | } 51 | 52 | #ifdef __cplusplus 53 | extern "C" 54 | #endif 55 | 56 | double F77_NAME(d1mach)(int *i) 57 | { 58 | return Rf_d1mach(*i); 59 | } 60 | -------------------------------------------------------------------------------- /src/dbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000, The R Core Team 8 | * Changes to case a, b < 2, use logs to avoid underflow 9 | * Copyright (C) 2006-2014 The R Core Team 10 | * 11 | * This program is free software; you can redistribute it and/or modify 12 | * it under the terms of the GNU General Public License as published by 13 | * the Free Software Foundation; either version 2 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, 17 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | * GNU General Public License for more details. 20 | * 21 | * You should have received a copy of the GNU General Public License 22 | * along with this program; if not, a copy is available at 23 | * https://www.R-project.org/Licenses/ 24 | * 25 | * 26 | * DESCRIPTION 27 | * Beta density, 28 | * (a+b-1)! a-1 b-1 29 | * p(x;a,b) = ------------ x (1-x) 30 | * (a-1)!(b-1)! 31 | * 32 | * = (a+b-1) dbinom(a-1; a+b-2,x) 33 | * 34 | * The basic formula for the log density is thus 35 | * (a-1) log x + (b-1) log (1-x) - lbeta(a, b) 36 | * If either a or b <= 2 then 0 < lbeta(a, b) < 710 and so no 37 | * term is large. We use Loader's code only if both a and b > 2. 38 | */ 39 | 40 | #include "nmath.h" 41 | #include "dpq.h" 42 | 43 | double dbeta(double x, double a, double b, int give_log) 44 | { 45 | #ifdef IEEE_754 46 | /* NaNs propagated correctly */ 47 | if (ISNAN(x) || ISNAN(a) || ISNAN(b)) return x + a + b; 48 | #endif 49 | 50 | if (a < 0 || b < 0) ML_WARN_return_NAN; 51 | if (x < 0 || x > 1) return(R_D__0); 52 | 53 | // limit cases for (a,b), leading to point masses 54 | if(a == 0 || b == 0 || !R_FINITE(a) || !R_FINITE(b)) { 55 | if(a == 0 && b == 0) { // point mass 1/2 at each of {0,1} : 56 | if (x == 0 || x == 1) return(ML_POSINF); else return(R_D__0); 57 | } 58 | if (a == 0 || a/b == 0) { // point mass 1 at 0 59 | if (x == 0) return(ML_POSINF); else return(R_D__0); 60 | } 61 | if (b == 0 || b/a == 0) { // point mass 1 at 1 62 | if (x == 1) return(ML_POSINF); else return(R_D__0); 63 | } 64 | // else, remaining case: a = b = Inf : point mass 1 at 1/2 65 | if (x == 0.5) return(ML_POSINF); else return(R_D__0); 66 | } 67 | 68 | if (x == 0) { 69 | if(a > 1) return(R_D__0); 70 | if(a < 1) return(ML_POSINF); 71 | /* a == 1 : */ return(R_D_val(b)); 72 | } 73 | if (x == 1) { 74 | if(b > 1) return(R_D__0); 75 | if(b < 1) return(ML_POSINF); 76 | /* b == 1 : */ return(R_D_val(a)); 77 | } 78 | 79 | double lval; 80 | if (a <= 2 || b <= 2) 81 | lval = (a-1)*log(x) + (b-1)*log1p(-x) - lbeta(a, b); 82 | else 83 | lval = log(a+b-1) + dbinom_raw(a-1, a+b-2, x, 1-x, TRUE); 84 | 85 | return R_D_exp(lval); 86 | } 87 | -------------------------------------------------------------------------------- /src/dcauchy.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density of the Cauchy distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dcauchy(double x, double location, double scale, int give_log) 29 | { 30 | double y; 31 | #ifdef IEEE_754 32 | /* NaNs propagated correctly */ 33 | if (ISNAN(x) || ISNAN(location) || ISNAN(scale)) 34 | return x + location + scale; 35 | #endif 36 | if (scale <= 0) ML_WARN_return_NAN; 37 | 38 | y = (x - location) / scale; 39 | return give_log ? 40 | - log(M_PI * scale * (1. + y * y)) : 41 | 1. / (M_PI * scale * (1. + y * y)); 42 | } 43 | -------------------------------------------------------------------------------- /src/dchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, but 12 | * WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density of the chi-squared distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dchisq(double x, double df, int give_log) 29 | { 30 | return dgamma(x, df / 2., 2., give_log); 31 | } 32 | -------------------------------------------------------------------------------- /src/dexp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density of the exponential distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dexp(double x, double scale, int give_log) 29 | { 30 | #ifdef IEEE_754 31 | /* NaNs propagated correctly */ 32 | if (ISNAN(x) || ISNAN(scale)) return x + scale; 33 | #endif 34 | if (scale <= 0.0) ML_WARN_return_NAN; 35 | 36 | if (x < 0.) 37 | return R_D__0; 38 | return (give_log ? 39 | (-x / scale) - log(scale) : 40 | exp(-x / scale) / scale); 41 | } 42 | -------------------------------------------------------------------------------- /src/df.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000, 2005 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * The density function of the F distribution. 27 | * To evaluate it, write it as a Binomial probability with p = x*m/(n+x*m). 28 | * For m >= 2, we use the simplest conversion. 29 | * For m < 2, (m-2)/2 < 0 so the conversion will not work, and we must use 30 | * a second conversion. 31 | * Note the division by p; this seems unavoidable 32 | * for m < 2, since the F density has a singularity as x (or p) -> 0. 33 | */ 34 | 35 | #include "nmath.h" 36 | #include "dpq.h" 37 | 38 | double df(double x, double m, double n, int give_log) 39 | { 40 | double p, q, f, dens; 41 | 42 | #ifdef IEEE_754 43 | if (ISNAN(x) || ISNAN(m) || ISNAN(n)) 44 | return x + m + n; 45 | #endif 46 | if (m <= 0 || n <= 0) ML_WARN_return_NAN; 47 | if (x < 0.) return(R_D__0); 48 | if (x == 0.) return(m > 2 ? R_D__0 : (m == 2 ? R_D__1 : ML_POSINF)); 49 | if (!R_FINITE(m) && !R_FINITE(n)) { /* both +Inf */ 50 | if(x == 1.) return ML_POSINF; else return R_D__0; 51 | } 52 | if (!R_FINITE(n)) /* must be +Inf by now */ 53 | return(dgamma(x, m/2, 2./m, give_log)); 54 | if (m > 1e14) {/* includes +Inf: code below is inaccurate there */ 55 | dens = dgamma(1./x, n/2, 2./n, give_log); 56 | return give_log ? dens - 2*log(x): dens/(x*x); 57 | } 58 | 59 | f = 1./(n+x*m); 60 | q = n*f; 61 | p = x*m*f; 62 | 63 | if (m >= 2) { 64 | f = m*q/2; 65 | dens = dbinom_raw((m-2)/2, (m+n-2)/2, p, q, give_log); 66 | } 67 | else { 68 | f = m*m*q / (2*p*(m+n)); 69 | dens = dbinom_raw(m/2, (m+n)/2, p, q, give_log); 70 | } 71 | return(give_log ? log(f)+dens : f*dens); 72 | } 73 | -------------------------------------------------------------------------------- /src/dgamma.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000-2019 The R Core Team 8 | * Copyright (C) 2004-2019 The R Foundation 9 | * 10 | * This program is free software; you can redistribute it and/or modify 11 | * it under the terms of the GNU General Public License as published by 12 | * the Free Software Foundation; either version 2 of the License, or 13 | * (at your option) any later version. 14 | * 15 | * This program is distributed in the hope that it will be useful, 16 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 | * GNU General Public License for more details. 19 | * 20 | * You should have received a copy of the GNU General Public License 21 | * along with this program; if not, a copy is available at 22 | * https://www.R-project.org/Licenses/ 23 | * 24 | * 25 | * DESCRIPTION 26 | * 27 | * Computes the density of the gamma distribution, 28 | * 29 | * 1/s (x/s)^{a-1} exp(-x/s) 30 | * p(x;a,s) = ----------------------- 31 | * (a-1)! 32 | * 33 | * where 's' is the scale (= 1/lambda in other parametrizations) 34 | * and 'a' is the shape parameter ( = alpha in other contexts). 35 | * 36 | * The old (R 1.1.1) version of the code is available via '#define D_non_pois' 37 | */ 38 | 39 | #include "nmath.h" 40 | #include "dpq.h" 41 | 42 | double dgamma(double x, double shape, double scale, int give_log) 43 | { 44 | double pr; 45 | #ifdef IEEE_754 46 | if (ISNAN(x) || ISNAN(shape) || ISNAN(scale)) 47 | return x + shape + scale; 48 | #endif 49 | if (shape < 0 || scale <= 0) ML_WARN_return_NAN; 50 | if (x < 0) 51 | return R_D__0; 52 | if (shape == 0) /* point mass at 0 */ 53 | return (x == 0)? ML_POSINF : R_D__0; 54 | if (x == 0) { 55 | if (shape < 1) return ML_POSINF; 56 | if (shape > 1) return R_D__0; 57 | /* else */ 58 | return give_log ? -log(scale) : 1 / scale; 59 | } 60 | 61 | if (shape < 1) { 62 | pr = dpois_raw(shape, x/scale, give_log); 63 | return ( 64 | give_log/* NB: currently *always* shape/x > 0 if shape < 1: 65 | * -- overflow to Inf happens, but underflow to 0 does NOT : */ 66 | ? pr + (R_FINITE(shape/x) 67 | ? log(shape/x) 68 | : /* shape/x overflows to +Inf */ log(shape) - log(x)) 69 | : pr*shape / x); 70 | } 71 | /* else shape >= 1 */ 72 | pr = dpois_raw(shape-1, x/scale, give_log); 73 | return give_log ? pr - log(scale) : pr/scale; 74 | } 75 | -------------------------------------------------------------------------------- /src/dgeom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000-2014 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * Computes the geometric probabilities, Pr(X=x) = p(1-p)^x. 27 | */ 28 | 29 | #include "nmath.h" 30 | #include "dpq.h" 31 | 32 | double dgeom(double x, double p, int give_log) 33 | { 34 | double prob; 35 | 36 | #ifdef IEEE_754 37 | if (ISNAN(x) || ISNAN(p)) return x + p; 38 | #endif 39 | 40 | if (p <= 0 || p > 1) ML_WARN_return_NAN; 41 | 42 | R_D_nonint_check(x); 43 | if (x < 0 || !R_FINITE(x) || p == 0) return R_D__0; 44 | x = R_forceint(x); 45 | 46 | /* prob = (1-p)^x, stable for small p */ 47 | prob = dbinom_raw(0.,x, p,1-p, give_log); 48 | 49 | return((give_log) ? log(p) + prob : p*prob); 50 | } 51 | -------------------------------------------------------------------------------- /src/dhyper.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000-2014 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * Given a sequence of r successes and b failures, we sample n (\le b+r) 27 | * items without replacement. The hypergeometric probability is the 28 | * probability of x successes: 29 | * 30 | * choose(r, x) * choose(b, n-x) 31 | * p(x; r,b,n) = ----------------------------- = 32 | * choose(r+b, n) 33 | * 34 | * dbinom(x,r,p) * dbinom(n-x,b,p) 35 | * = -------------------------------- 36 | * dbinom(n,r+b,p) 37 | * 38 | * for any p. For numerical stability, we take p=n/(r+b); with this choice, 39 | * the denominator is not exponentially small. 40 | */ 41 | 42 | #include "nmath.h" 43 | #include "dpq.h" 44 | 45 | double dhyper(double x, double r, double b, double n, int give_log) 46 | { 47 | double p, q, p1, p2, p3; 48 | 49 | #ifdef IEEE_754 50 | if (ISNAN(x) || ISNAN(r) || ISNAN(b) || ISNAN(n)) 51 | return x + r + b + n; 52 | #endif 53 | 54 | if (R_D_negInonint(r) || R_D_negInonint(b) || R_D_negInonint(n) || n > r+b) 55 | ML_WARN_return_NAN; 56 | if(x < 0) return(R_D__0); 57 | R_D_nonint_check(x);// incl warning 58 | 59 | x = R_forceint(x); 60 | r = R_forceint(r); 61 | b = R_forceint(b); 62 | n = R_forceint(n); 63 | 64 | if (n < x || r < x || n - x > b) return(R_D__0); 65 | if (n == 0) return((x == 0) ? R_D__1 : R_D__0); 66 | 67 | p = ((double)n)/((double)(r+b)); 68 | q = ((double)(r+b-n))/((double)(r+b)); 69 | 70 | p1 = dbinom_raw(x, r, p,q,give_log); 71 | p2 = dbinom_raw(n-x,b, p,q,give_log); 72 | p3 = dbinom_raw(n,r+b, p,q,give_log); 73 | 74 | return( (give_log) ? p1 + p2 - p3 : p1*p2/p3 ); 75 | } 76 | -------------------------------------------------------------------------------- /src/dlnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2019 The R Core Team 4 | * Copyright (C) 1998 Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density of the lognormal distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dlnorm(double x, double meanlog, double sdlog, int give_log) 29 | { 30 | double y; 31 | 32 | #ifdef IEEE_754 33 | if (ISNAN(x) || ISNAN(meanlog) || ISNAN(sdlog)) 34 | return x + meanlog + sdlog; 35 | #endif 36 | if(sdlog < 0) ML_WARN_return_NAN; 37 | if(!R_FINITE(x) && log(x) == meanlog) return ML_NAN;/* log(x) - meanlog is NaN */ 38 | if(sdlog == 0) 39 | return (log(x) == meanlog) ? ML_POSINF : R_D__0; 40 | if(x <= 0) return R_D__0; 41 | 42 | y = (log(x) - meanlog) / sdlog; 43 | return (give_log ? 44 | -(M_LN_SQRT_2PI + 0.5 * y * y + log(x * sdlog)) : 45 | M_1_SQRT_2PI * exp(-0.5 * y * y) / (x * sdlog)); 46 | /* M_1_SQRT_2PI = 1 / sqrt(2 * pi) */ 47 | } 48 | -------------------------------------------------------------------------------- /src/dlogis.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | 21 | #include "nmath.h" 22 | #include "dpq.h" 23 | 24 | double dlogis(double x, double location, double scale, int give_log) 25 | { 26 | double e, f; 27 | #ifdef IEEE_754 28 | if (ISNAN(x) || ISNAN(location) || ISNAN(scale)) 29 | return x + location + scale; 30 | #endif 31 | if (scale <= 0.0) 32 | ML_WARN_return_NAN; 33 | 34 | x = fabs((x - location) / scale); 35 | e = exp(-x); 36 | f = 1.0 + e; 37 | return give_log ? -(x + log(scale * f * f)) : e / (scale * f * f); 38 | } 39 | -------------------------------------------------------------------------------- /src/dnbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-12 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double dnbeta(double x, double a, double b, double ncp, int give_log); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Computes the density of the noncentral beta distribution with 28 | * noncentrality parameter ncp. The noncentral beta distribution 29 | * has density: 30 | * 31 | * Inf 32 | * f(x|a,b,ncp) = SUM p(i) * x^(a+i-1) * (1-x)^(b-1) / B(a+i,b) 33 | * i=0 34 | * 35 | * where: 36 | * 37 | * p(k) = exp(-ncp/2) (ncp/2)^k / k! 38 | * 39 | * B(a,b) = Gamma(a) * Gamma(b) / Gamma(a+b) 40 | * 41 | * 42 | * This can be computed efficiently by using the recursions: 43 | * 44 | * p(k+1) = ncp/2 / (k+1) * p(k) 45 | * 46 | * B(a+k+1,b) = (a+k)/(a+b+k) * B(a+k,b) 47 | * 48 | * The new algorithm first determines for which k the k-th term is maximal, 49 | * and then sums outwards to both sides from the 'mid'. 50 | */ 51 | 52 | #include "nmath.h" 53 | #include "dpq.h" 54 | 55 | double dnbeta(double x, double a, double b, double ncp, int give_log) 56 | { 57 | const static double eps = 1.e-15; 58 | 59 | int kMax; 60 | double k, ncp2, dx2, d, D; 61 | LDOUBLE sum, term, p_k, q; 62 | 63 | #ifdef IEEE_754 64 | if (ISNAN(x) || ISNAN(a) || ISNAN(b) || ISNAN(ncp)) 65 | return x + a + b + ncp; 66 | #endif 67 | if (ncp < 0 || a <= 0 || b <= 0) 68 | ML_WARN_return_NAN; 69 | 70 | if (!R_FINITE(a) || !R_FINITE(b) || !R_FINITE(ncp)) 71 | ML_WARN_return_NAN; 72 | 73 | if (x < 0 || x > 1) return(R_D__0); 74 | if(ncp == 0) 75 | return dbeta(x, a, b, give_log); 76 | 77 | /* New algorithm, starting with *largest* term : */ 78 | ncp2 = 0.5 * ncp; 79 | dx2 = ncp2*x; 80 | d = (dx2 - a - 1)/2; 81 | D = d*d + dx2 * (a + b) - a; 82 | if(D <= 0) { 83 | kMax = 0; 84 | } else { 85 | D = ceil(d + sqrt(D)); 86 | kMax = (D > 0) ? (int)D : 0; 87 | } 88 | 89 | /* The starting "middle term" --- first look at it's log scale: */ 90 | term = dbeta(x, a + kMax, b, /* log = */ TRUE); 91 | p_k = dpois_raw(kMax, ncp2, TRUE); 92 | if(x == 0. || !R_FINITE(term) || !R_FINITE((double)p_k)) /* if term = +Inf */ 93 | return R_D_exp((double)(p_k + term)); 94 | 95 | /* Now if s_k := p_k * t_k {here = exp(p_k + term)} would underflow, 96 | * we should rather scale everything and re-scale at the end:*/ 97 | 98 | p_k += term; /* = log(p_k) + log(t_k) == log(s_k) -- used at end to rescale */ 99 | /* mid = 1 = the rescaled value, instead of mid = exp(p_k); */ 100 | 101 | /* Now sum from the inside out */ 102 | sum = term = 1. /* = mid term */; 103 | /* middle to the left */ 104 | k = kMax; 105 | while(k > 0 && term > sum * eps) { 106 | k--; 107 | q = /* 1 / r_k = */ (k+1)*(k+a) / (k+a+b) / dx2; 108 | term *= q; 109 | sum += term; 110 | } 111 | /* middle to the right */ 112 | term = 1.; 113 | k = kMax; 114 | do { 115 | q = /* r_{old k} = */ dx2 * (k+a+b) / (k+a) / (k+1); 116 | k++; 117 | term *= q; 118 | sum += term; 119 | } while (term > sum * eps); 120 | 121 | #ifdef HAVE_LONG_DOUBLE 122 | return R_D_exp((double)(p_k + logl(sum))); 123 | #else 124 | return R_D_exp((double)(p_k + log(sum))); 125 | #endif 126 | } 127 | -------------------------------------------------------------------------------- /src/dnchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-15 The R Core Team 5 | * Copyright (C) 2004-15 The R Foundation 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, but 13 | * WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The density of the noncentral chi-squared distribution with "df" 24 | * degrees of freedom and noncentrality parameter "ncp". 25 | */ 26 | 27 | #include "nmath.h" 28 | #include "dpq.h" 29 | 30 | double dnchisq(double x, double df, double ncp, int give_log) 31 | { 32 | const static double eps = 5e-15; 33 | 34 | double i, ncp2, q, mid, dfmid, imax; 35 | LDOUBLE sum, term; 36 | 37 | #ifdef IEEE_754 38 | if (ISNAN(x) || ISNAN(df) || ISNAN(ncp)) 39 | return x + df + ncp; 40 | #endif 41 | 42 | if (!R_FINITE(df) || !R_FINITE(ncp) || ncp < 0 || df < 0) 43 | ML_WARN_return_NAN; 44 | 45 | if(x < 0) return R_D__0; 46 | if(x == 0 && df < 2.) 47 | return ML_POSINF; 48 | if(ncp == 0) 49 | return (df > 0) ? dchisq(x, df, give_log) : R_D__0; 50 | if(x == ML_POSINF) return R_D__0; 51 | 52 | ncp2 = 0.5 * ncp; 53 | 54 | /* find max element of sum */ 55 | imax = ceil((-(2+df) +sqrt((2-df) * (2-df) + 4 * ncp * x))/4); 56 | if (imax < 0) imax = 0; 57 | if(R_FINITE(imax)) { 58 | dfmid = df + 2 * imax; 59 | mid = dpois_raw(imax, ncp2, FALSE) * dchisq(x, dfmid, FALSE); 60 | } else /* imax = Inf */ 61 | mid = 0; 62 | 63 | if(mid == 0) { 64 | /* underflow to 0 -- maybe numerically correct; maybe can be more accurate, 65 | * particularly when give_log = TRUE */ 66 | /* Use central-chisq approximation formula when appropriate; 67 | * ((FIXME: the optimal cutoff also depends on (x,df); use always here? )) */ 68 | if(give_log || ncp > 1000.) { 69 | double nl = df + ncp, ic = nl/(nl + ncp);/* = "1/(1+b)" Abramowitz & St.*/ 70 | return dchisq(x*ic, nl*ic, give_log); 71 | } else 72 | return R_D__0; 73 | } 74 | 75 | sum = mid; 76 | 77 | /* errorbound := term * q / (1-q) now subsumed in while() / if() below: */ 78 | 79 | /* upper tail */ 80 | term = mid; df = dfmid; i = imax; 81 | double x2 = x * ncp2; 82 | do { 83 | i++; 84 | q = x2 / i / df; 85 | df += 2; 86 | term *= q; 87 | sum += term; 88 | } while (q >= 1 || term * q > (1-q)*eps || term > 1e-10*sum); 89 | /* lower tail */ 90 | term = mid; df = dfmid; i = imax; 91 | while (i != 0) { 92 | df -= 2; 93 | q = i * df / x2; 94 | i--; 95 | term *= q; 96 | sum += term; 97 | if (q < 1 && term * q <= (1-q)*eps) break; 98 | } 99 | return R_D_val((double) sum); 100 | } 101 | -------------------------------------------------------------------------------- /src/dnf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Peter Ruckdeschel, peter.ruckdeschel@uni-bayreuth.de. 4 | * April 13, 2006. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2006 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * The density function of the non-central F distribution --- 27 | * obtained by differentiating the corresp. cumulative distribution function 28 | * using dnbeta. 29 | * For df1 < 2, since the F density has a singularity as x -> Inf. 30 | */ 31 | 32 | #include "nmath.h" 33 | #include "dpq.h" 34 | 35 | double dnf(double x, double df1, double df2, double ncp, int give_log) 36 | { 37 | double y, z, f; 38 | 39 | #ifdef IEEE_754 40 | if (ISNAN(x) || ISNAN(df1) || ISNAN(df2) || ISNAN(ncp)) 41 | return x + df2 + df1 + ncp; 42 | #endif 43 | 44 | /* want to compare dnf(ncp=0) behavior with df() one, hence *NOT* : 45 | * if (ncp == 0) 46 | * return df(x, df1, df2, give_log); */ 47 | 48 | if (df1 <= 0. || df2 <= 0. || ncp < 0) ML_WARN_return_NAN; 49 | if (x < 0.) return(R_D__0); 50 | if (!R_FINITE(ncp)) /* ncp = +Inf -- FIXME?: in some cases, limit exists */ 51 | ML_WARN_return_NAN; 52 | 53 | /* This is not correct for df1 == 2, ncp > 0 - and seems unneeded: 54 | * if (x == 0.) return(df1 > 2 ? R_D__0 : (df1 == 2 ? R_D__1 : ML_POSINF)); 55 | */ 56 | if (!R_FINITE(df1) && !R_FINITE(df2)) { /* both +Inf */ 57 | /* PR: not sure about this (taken from ncp==0) -- FIXME ? */ 58 | if(x == 1.) return ML_POSINF; else return R_D__0; 59 | } 60 | if (!R_FINITE(df2)) /* i.e. = +Inf */ 61 | return df1* dnchisq(x*df1, df1, ncp, give_log); 62 | /* == dngamma(x, df1/2, 2./df1, ncp, give_log) -- but that does not exist */ 63 | if (df1 > 1e14 && ncp < 1e7) { 64 | /* includes df1 == +Inf: code below is inaccurate there */ 65 | f = 1 + ncp/df1; /* assumes ncp << df1 [ignores 2*ncp^(1/2)/df1*x term] */ 66 | z = dgamma(1./x/f, df2/2, 2./df2, give_log); 67 | return give_log ? z - 2*log(x) - log(f) : z / (x*x) / f; 68 | } 69 | 70 | y = (df1 / df2) * x; 71 | z = dnbeta(y/(1 + y), df1 / 2., df2 / 2., ncp, give_log); 72 | return give_log ? 73 | z + log(df1) - log(df2) - 2 * log1p(y) : 74 | z * (df1 / df2) /(1 + y) / (1 + y); 75 | } 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /src/dnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2014 The R Core Team 5 | * Copyright (C) 2003 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * SYNOPSIS 22 | * 23 | * double dnorm4(double x, double mu, double sigma, int give_log) 24 | * {dnorm (..) is synonymous and preferred inside R} 25 | * 26 | * DESCRIPTION 27 | * 28 | * Compute the density of the normal distribution. 29 | */ 30 | 31 | #include "nmath.h" 32 | #include "dpq.h" 33 | 34 | double dnorm4(double x, double mu, double sigma, int give_log) 35 | { 36 | #ifdef IEEE_754 37 | if (ISNAN(x) || ISNAN(mu) || ISNAN(sigma)) 38 | return x + mu + sigma; 39 | #endif 40 | if (sigma < 0) ML_WARN_return_NAN; 41 | if(!R_FINITE(sigma)) return R_D__0; 42 | if(!R_FINITE(x) && mu == x) return ML_NAN;/* x-mu is NaN */ 43 | if (sigma == 0) 44 | return (x == mu) ? ML_POSINF : R_D__0; 45 | x = (x - mu) / sigma; 46 | 47 | if(!R_FINITE(x)) return R_D__0; 48 | 49 | x = fabs (x); 50 | if (x >= 2 * sqrt(DBL_MAX)) return R_D__0; 51 | if (give_log) 52 | return -(M_LN_SQRT_2PI + 0.5 * x * x + log(sigma)); 53 | // M_1_SQRT_2PI = 1 / sqrt(2 * pi) 54 | #ifdef MATHLIB_FAST_dnorm 55 | // and for R <= 3.0.x and R-devel upto 2014-01-01: 56 | return M_1_SQRT_2PI * exp(-0.5 * x * x) / sigma; 57 | #else 58 | // more accurate, less fast : 59 | if (x < 5) return M_1_SQRT_2PI * exp(-0.5 * x * x) / sigma; 60 | 61 | /* ELSE: 62 | 63 | * x*x may lose upto about two digits accuracy for "large" x 64 | * Morten Welinder's proposal for PR#15620 65 | * https://bugs.r-project.org/show_bug.cgi?id=15620 66 | 67 | * -- 1 -- No hoop jumping when we underflow to zero anyway: 68 | 69 | * -x^2/2 < log(2)*.Machine$double.min.exp <==> 70 | * x > sqrt(-2*log(2)*.Machine$double.min.exp) =IEEE= 37.64031 71 | * but "thanks" to denormalized numbers, underflow happens a bit later, 72 | * effective.D.MIN.EXP <- with(.Machine, double.min.exp + double.ulp.digits) 73 | * for IEEE, DBL_MIN_EXP is -1022 but "effective" is -1074 74 | * ==> boundary = sqrt(-2*log(2)*(.Machine$double.min.exp + .Machine$double.ulp.digits)) 75 | * =IEEE= 38.58601 76 | * [on one x86_64 platform, effective boundary a bit lower: 38.56804] 77 | */ 78 | if (x > sqrt(-2*M_LN2*(DBL_MIN_EXP + 1-DBL_MANT_DIG))) return 0.; 79 | 80 | /* Now, to get full accuracy, split x into two parts, 81 | * x = x1+x2, such that |x2| <= 2^-16. 82 | * Assuming that we are using IEEE doubles, that means that 83 | * x1*x1 is error free for x<1024 (but we have x < 38.6 anyway). 84 | 85 | * If we do not have IEEE this is still an improvement over the naive formula. 86 | */ 87 | double x1 = // R_forceint(x * 65536) / 65536 = 88 | ldexp( R_forceint(ldexp(x, 16)), -16); 89 | double x2 = x - x1; 90 | return M_1_SQRT_2PI / sigma * 91 | (exp(-0.5 * x1 * x1) * exp( (-0.5 * x2 - x1) * x2 ) ); 92 | #endif 93 | } 94 | -------------------------------------------------------------------------------- /src/dnt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Claus Ekstrøm, ekstrom@dina.kvl.dk 4 | * July 15, 2003. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2003-2015 The R Foundation 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * NOTE 25 | * 26 | * Requires the following auxiliary routines: 27 | * 28 | * lgammafn(x) - log gamma function 29 | * pnt(x, df, ncp) - the distribution function for 30 | * the non-central t distribution 31 | * 32 | * 33 | * DESCRIPTION 34 | * 35 | * From Johnson, Kotz and Balakrishnan (1995) [2nd ed.; formula (31.15), p.516], 36 | * the non-central t density is 37 | * 38 | * f(x, df, ncp) = 39 | * 40 | * exp(-.5*ncp^2) * gamma((df+1)/2) / (sqrt(pi*df)* gamma(df/2)) * (df/(df+x^2))^((df+1)/2) * 41 | * sum_{j=0}^Inf gamma((df+j+1)/2)/(factorial(j)* gamma((df+1)/2)) * (x*ncp*sqrt(2)/sqrt(df+x^2))^ j 42 | * 43 | * 44 | * The functional relationship 45 | * 46 | * f(x, df, ncp) = df/x * 47 | * (F(sqrt((df+2)/df)*x, df+2, ncp) - F(x, df, ncp)) 48 | * 49 | * is used to evaluate the density at x != 0 and 50 | * 51 | * f(0, df, ncp) = exp(-.5*ncp^2) / 52 | * (sqrt(pi)*sqrt(df)*gamma(df/2))*gamma((df+1)/2) 53 | * 54 | * is used for x=0. 55 | * 56 | * All calculations are done on log-scale to increase stability. 57 | * 58 | * FIXME: pnt() is known to be inaccurate in the (very) left tail and for ncp > 38 59 | * ==> use a direct log-space summation formula in that case 60 | */ 61 | 62 | #include "nmath.h" 63 | #include "dpq.h" 64 | 65 | double dnt(double x, double df, double ncp, int give_log) 66 | { 67 | double u; 68 | #ifdef IEEE_754 69 | if (ISNAN(x) || ISNAN(df)) 70 | return x + df; 71 | #endif 72 | 73 | /* If non-positive df then error */ 74 | if (df <= 0.0) ML_WARN_return_NAN; 75 | 76 | if(ncp == 0.0) return dt(x, df, give_log); 77 | 78 | /* If x is infinite then return 0 */ 79 | if(!R_FINITE(x)) 80 | return R_D__0; 81 | 82 | /* If infinite df then the density is identical to a 83 | normal distribution with mean = ncp. However, the formula 84 | loses a lot of accuracy around df=1e9 85 | */ 86 | if(!R_FINITE(df) || df > 1e8) 87 | return dnorm(x, ncp, 1., give_log); 88 | 89 | /* Do calculations on log scale to stabilize */ 90 | 91 | /* Consider two cases: x ~= 0 or not */ 92 | if (fabs(x) > sqrt(df * DBL_EPSILON)) { 93 | u = log(df) - log(fabs(x)) + 94 | log(fabs(pnt(x*sqrt((df+2)/df), df+2, ncp, 1, 0) - 95 | pnt(x, df, ncp, 1, 0))); 96 | /* FIXME: the above still suffers from cancellation (but not horribly) */ 97 | } 98 | else { /* x ~= 0 : -> same value as for x = 0 */ 99 | u = lgammafn((df+1)/2) - lgammafn(df/2) 100 | - (M_LN_SQRT_PI + .5*(log(df) + ncp*ncp)); 101 | } 102 | 103 | return (give_log ? u : exp(u)); 104 | } 105 | -------------------------------------------------------------------------------- /src/dpois.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000-2021 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * dpois() checks argument validity and calls dpois_raw(). 27 | * 28 | * dpois_raw() computes the Poisson probability lb^x exp(-lb) / x!. 29 | * This does not check that x is an integer, since dgamma() may 30 | * call this with a fractional x argument. Any necessary argument 31 | * checks should be done in the calling function. 32 | * 33 | */ 34 | 35 | #include "nmath.h" 36 | #include "dpq.h" 37 | 38 | #define M_SQRT_2PI 2.50662827463100050241576528481104525301 /* sqrt(2*pi) */ 39 | // sqrt(2 * Rmpfr::Const("pi", 128)) 40 | #define x_LRG 2.86111748575702815380240589208115399625e+307 /* = 2^1023 / pi */ 41 | 42 | // called also from dgamma.c, pgamma.c, dnbeta.c, dnbinom.c, dnchisq.c : 43 | double dpois_raw(double x, double lambda, int give_log) 44 | { 45 | /* x >= 0 ; integer for dpois(), but not e.g. for pgamma()! 46 | lambda >= 0 47 | */ 48 | if (lambda == 0) return( (x == 0) ? R_D__1 : R_D__0 ); 49 | if (!R_FINITE(lambda)) return R_D__0; // including for the case where x = lambda = +Inf 50 | if (x < 0) return( R_D__0 ); 51 | if (x <= lambda * DBL_MIN) return(R_D_exp(-lambda) ); 52 | if (lambda < x * DBL_MIN) { 53 | if (!R_FINITE(x)) // lambda < x = +Inf 54 | return R_D__0; 55 | // else 56 | return(R_D_exp(-lambda + x*log(lambda) -lgammafn(x+1))); 57 | } 58 | // R <= 4.0.x had return(R_D_fexp( M_2PI*x, -stirlerr(x)-bd0(x,lambda) )); 59 | double yh, yl; 60 | ebd0 (x, lambda, &yh, &yl); 61 | yl += stirlerr(x); 62 | Rboolean Lrg_x = (x >= x_LRG); //really large x <==> 2*pi*x overflows 63 | double r = Lrg_x 64 | ? M_SQRT_2PI * sqrt(x) // sqrt(.): avoid overflow for very large x 65 | : M_2PI * x; 66 | return give_log 67 | ? -yl - yh - (Lrg_x ? log(r) : 0.5 * log(r)) 68 | : exp(-yl) * exp(-yh) / (Lrg_x ? r : sqrt(r)); 69 | } 70 | 71 | double dpois(double x, double lambda, int give_log) 72 | { 73 | #ifdef IEEE_754 74 | if(ISNAN(x) || ISNAN(lambda)) 75 | return x + lambda; 76 | #endif 77 | 78 | if (lambda < 0) ML_WARN_return_NAN; 79 | R_D_nonint_check(x); 80 | if (x < 0 || !R_FINITE(x)) 81 | return R_D__0; 82 | 83 | x = R_forceint(x); 84 | 85 | return( dpois_raw(x,lambda,give_log) ); 86 | } 87 | -------------------------------------------------------------------------------- /src/dt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * AUTHOR 3 | * Catherine Loader, catherine@research.bell-labs.com. 4 | * October 23, 2000. 5 | * 6 | * Merge in to R: 7 | * Copyright (C) 2000-2015 The R Core Team 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * 24 | * DESCRIPTION 25 | * 26 | * The t density is evaluated as 27 | * sqrt(n/2) / ((n+1)/2) * Gamma((n+3)/2) / Gamma((n+2)/2). 28 | * * (1+x^2/n)^(-n/2) 29 | * / sqrt( 2 pi (1+x^2/n) ) 30 | * 31 | * This form leads to a stable computation for all 32 | * values of n, including n -> 0 and n -> infinity. 33 | */ 34 | 35 | #include "nmath.h" 36 | #include "dpq.h" 37 | 38 | double dt(double x, double n, int give_log) 39 | { 40 | #ifdef IEEE_754 41 | if (ISNAN(x) || ISNAN(n)) 42 | return x + n; 43 | #endif 44 | if (n <= 0) ML_WARN_return_NAN; 45 | if(!R_FINITE(x)) 46 | return R_D__0; 47 | if(!R_FINITE(n)) 48 | return dnorm(x, 0., 1., give_log); 49 | 50 | double u, t = -bd0(n/2.,(n+1)/2.) + stirlerr((n+1)/2.) - stirlerr(n/2.), 51 | x2n = x*x/n, // in [0, Inf] 52 | ax = 0., // <- -Wpedantic 53 | l_x2n; // := log(sqrt(1 + x2n)) = log(1 + x2n)/2 54 | Rboolean lrg_x2n = (x2n > 1./DBL_EPSILON); 55 | if (lrg_x2n) { // large x^2/n : 56 | ax = fabs(x); 57 | l_x2n = log(ax) - log(n)/2.; // = log(x2n)/2 = 1/2 * log(x^2 / n) 58 | u = // log(1 + x2n) * n/2 = n * log(1 + x2n)/2 = 59 | n * l_x2n; 60 | } 61 | else if (x2n > 0.2) { 62 | l_x2n = log(1 + x2n)/2.; 63 | u = n * l_x2n; 64 | } else { 65 | l_x2n = log1p(x2n)/2.; 66 | u = -bd0(n/2.,(n+x*x)/2.) + x*x/2.; 67 | } 68 | 69 | //old: return R_D_fexp(M_2PI*(1+x2n), t-u); 70 | 71 | // R_D_fexp(f,x) := (give_log ? -0.5*log(f)+(x) : exp(x)/sqrt(f)) 72 | // f = 2pi*(1+x2n) 73 | // ==> 0.5*log(f) = log(2pi)/2 + log(1+x2n)/2 = log(2pi)/2 + l_x2n 74 | // 1/sqrt(f) = 1/sqrt(2pi * (1+ x^2 / n)) 75 | // = 1/sqrt(2pi)/(|x|/sqrt(n)*sqrt(1+1/x2n)) 76 | // = M_1_SQRT_2PI * sqrt(n)/ (|x|*sqrt(1+1/x2n)) 77 | if(give_log) 78 | return t-u - (M_LN_SQRT_2PI + l_x2n); 79 | 80 | // else : if(lrg_x2n) : sqrt(1 + 1/x2n) ='= sqrt(1) = 1 81 | double I_sqrt_ = (lrg_x2n ? sqrt(n)/ax : exp(-l_x2n)); 82 | return exp(t-u) * M_1_SQRT_2PI * I_sqrt_; 83 | } 84 | -------------------------------------------------------------------------------- /src/dunif.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density of the uniform distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dunif(double x, double a, double b, int give_log) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(a) || ISNAN(b)) 32 | return x + a + b; 33 | #endif 34 | if (b <= a) ML_WARN_return_NAN; 35 | 36 | if (a <= x && x <= b) 37 | return give_log ? -log(b - a) : 1. / (b - a); 38 | return R_D__0; 39 | } 40 | -------------------------------------------------------------------------------- /src/dweibull.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-6 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The density function of the Weibull distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double dweibull(double x, double shape, double scale, int give_log) 29 | { 30 | double tmp1, tmp2; 31 | #ifdef IEEE_754 32 | if (ISNAN(x) || ISNAN(shape) || ISNAN(scale)) 33 | return x + shape + scale; 34 | #endif 35 | if (shape <= 0 || scale <= 0) ML_WARN_return_NAN; 36 | 37 | if (x < 0) return R_D__0; 38 | if (!R_FINITE(x)) return R_D__0; 39 | /* need to handle x == 0 separately */ 40 | if(x == 0 && shape < 1) return ML_POSINF; 41 | tmp1 = pow(x / scale, shape - 1); 42 | tmp2 = tmp1 * (x / scale); 43 | /* These are incorrect if tmp1 == 0 */ 44 | return give_log ? 45 | -tmp2 + log(shape * tmp1 / scale) : 46 | shape * tmp1 * exp(-tmp2) / scale; 47 | } 48 | -------------------------------------------------------------------------------- /src/expm1.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2002 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * double expm1(double x); 23 | * 24 | * DESCRIPTION 25 | * 26 | * Compute the Exponential minus 1 27 | * 28 | * exp(x) - 1 29 | * 30 | * accurately also when x is close to zero, i.e. |x| << 1 31 | * 32 | * NOTES 33 | * 34 | * As log1p(), this is a C99 standard function 35 | * particularly GNU and BSD (but is neither ISO/ANSI C nor POSIX). 36 | * 37 | * We supply a substitute for the case when there is no system one 38 | * (which should not be the case any more). 39 | */ 40 | 41 | #ifdef HAVE_CONFIG_H 42 | # include 43 | #endif 44 | #include "nmath.h" 45 | 46 | 47 | #ifndef HAVE_EXPM1 48 | double expm1(double x) 49 | { 50 | double y, a = fabs(x); 51 | 52 | if (a < DBL_EPSILON) return x; 53 | if (a > 0.697) return exp(x) - 1; /* negligible cancellation */ 54 | 55 | if (a > 1e-8) 56 | y = exp(x) - 1; 57 | else /* Taylor expansion, more accurate in this range */ 58 | y = (x / 2 + 1) * x; 59 | 60 | /* Newton step for solving log(1 + y) = x for y : */ 61 | /* WARNING: does not work for y ~ -1: bug in 1.5.0 */ 62 | y -= (1 + y) * (log1p (y) - x); 63 | return y; 64 | } 65 | #endif 66 | -------------------------------------------------------------------------------- /src/fmax2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #include "nmath.h" 21 | 22 | double fmax2(double x, double y) 23 | { 24 | #ifdef IEEE_754 25 | if (ISNAN(x) || ISNAN(y)) 26 | return x + y; 27 | #endif 28 | return (x < y) ? y : x; 29 | } 30 | -------------------------------------------------------------------------------- /src/fmin2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #include "nmath.h" 21 | 22 | double fmin2(double x, double y) 23 | { 24 | #ifdef IEEE_754 25 | if (ISNAN(x) || ISNAN(y)) 26 | return x + y; 27 | #endif 28 | return (x < y) ? x : y; 29 | } 30 | -------------------------------------------------------------------------------- /src/fprec.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2019 The R Core Team 4 | * Copyright (C) 1998 Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double fprec(double x, double digits); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Returns the value of x rounded to "digits" significant 28 | * decimal digits. 29 | * 30 | * NOTES 31 | * 32 | * This routine is a translation into C of a Fortran subroutine 33 | * by W. Fullerton of Los Alamos Scientific Laboratory. 34 | * Some modifications have been made so that the routines 35 | * conform to the IEEE 754 standard. 36 | */ 37 | 38 | #include 39 | #include "nmath.h" 40 | 41 | /* Improvements by Martin Maechler, May 1997; 42 | further ones, Feb.2000: 43 | Replace pow(x, (double)i) by R_pow_di(x, i) {and use int dig} */ 44 | 45 | #define MAX_DIGITS 22 46 | /* was till R 0.99: DBL_DIG := digits of precision of a double, usually 15 */ 47 | /* FIXME: Hmm, have quite a host of these: 48 | 49 | 1) ./fround.c uses much more (sensibly!) ``instead'' 50 | 2) ../main/coerce.c & ../main/deparse.c have DBL_DIG directly 51 | 3) ../main/options.c has #define MAX_DIGITS 22 for options(digits) 52 | 53 | Really should decide on a (config.h dependent?) global MAX_DIGITS. 54 | --MM-- 55 | */ 56 | 57 | // R's signif(x, digits) via Math2(args, fprec) in ../main/arithmetic.c : 58 | double fprec(double x, double digits) 59 | { 60 | double l10, pow10, sgn, p10, P10; 61 | int e10, e2, do_round, dig; 62 | // Max.expon. of 10 (w/o denormalizing or overflow; = R's trunc( log10(.Machine$double.xmax) ) 63 | const static int max10e = (int) DBL_MAX_10_EXP; // == 308 ("IEEE") 64 | 65 | if (ISNAN(x) || ISNAN(digits)) 66 | return x + digits; 67 | if (!R_FINITE(x)) return x; 68 | if (!R_FINITE(digits)) { 69 | if(digits > 0.0) return x; 70 | else digits = 1.0; 71 | } 72 | if(x == 0) return x; 73 | dig = (int)round(digits); 74 | if (dig > MAX_DIGITS) { 75 | return x; 76 | } else if (dig < 1) 77 | dig = 1; 78 | 79 | sgn = 1.0; 80 | if(x < 0.0) { 81 | sgn = -sgn; 82 | x = -x; 83 | } 84 | l10 = log10(x); 85 | e10 = (int)(dig-1-floor(l10)); 86 | if(fabs(l10) < max10e - 2) { 87 | p10 = 1.0; 88 | if(e10 > max10e) { /* numbers less than 10^(dig-1) * 1e-308 */ 89 | p10 = R_pow_di(10., e10-max10e); 90 | e10 = max10e; 91 | } 92 | if(e10 > 0) { /* Try always to have pow >= 1 93 | and so exactly representable */ 94 | pow10 = R_pow_di(10., e10); 95 | return(sgn*(nearbyint((x*pow10)*p10)/pow10)/p10); 96 | } else { 97 | pow10 = R_pow_di(10., -e10); 98 | return(sgn*(nearbyint((x/pow10))*pow10)); 99 | } 100 | } else { /* -- LARGE or small -- */ 101 | do_round = max10e - l10 >= R_pow_di(10., -dig); 102 | e2 = dig + ((e10>0)? 1 : -1) * MAX_DIGITS; 103 | p10 = R_pow_di(10., e2); x *= p10; 104 | P10 = R_pow_di(10., e10-e2); x *= P10; 105 | /*-- p10 * P10 = 10 ^ e10 */ 106 | if(do_round) x += 0.5; 107 | x = floor(x) / p10; 108 | return(sgn*x/P10); 109 | } 110 | } 111 | -------------------------------------------------------------------------------- /src/fround.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2020 The R Core Team 4 | * Copyright (C) 1998 Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double fround(double x, double digits); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Rounds "x" to "digits" decimal digits. 28 | * 29 | */ 30 | 31 | #include /* needed for HAVE_* */ 32 | #include "nmath.h" 33 | 34 | double fround(double x, double digits) { 35 | #define MAX_DIGITS (DBL_MAX_10_EXP + DBL_DIG) /* typically = 308+15 = 323 36 | * was DBL_MAX_10_EXP (= 308, IEEE) till R 3.6.x; before, 37 | * was (DBL_DIG - 1) till R 0.99 */ 38 | const static int max10e = (int) DBL_MAX_10_EXP; // == 308 ("IEEE") 39 | 40 | /* Note that large digits make sense for very small numbers */ 41 | if (ISNAN(x) || ISNAN(digits)) 42 | return x + digits; 43 | if(!R_FINITE(x)) return x; 44 | 45 | if (digits > MAX_DIGITS || x == 0.) 46 | return x; 47 | else if(digits < -max10e) // includes -Inf {aka ML_NEGINF} 48 | return 0.; 49 | else if (digits == 0.) // common 50 | return nearbyint(x); 51 | 52 | int dig = (int)floor(digits + 0.5); 53 | double sgn = +1.; 54 | if(x < 0.) { 55 | sgn = -1.; 56 | x = -x; 57 | } // now x > 0 58 | double l10x = M_LOG10_2*(0.5 + logb(x)); // ~= log10(x), but cheaper (presumably) 59 | if(l10x + dig > DBL_DIG) // rounding to so many digits that no rounding is needed 60 | return sgn * x; 61 | else { 62 | double pow10, x10, i10, 63 | xd, xu; // x, rounded _d_own or _u_p 64 | if (dig <= max10e) { // both pow10 := 10^d and x10 := x * pow10 do *not* overflow 65 | pow10 = R_pow_di(10., dig); 66 | x10 = x * pow10; 67 | i10 = floor(x10); 68 | xd = i10 / pow10; 69 | xu = ceil (x10) / pow10; 70 | } else { // DBL_MAX_10_EXP =: max10e < dig <= DBL_DIG - l10x: case of |x| << 1; ~ 10^-305 71 | int e10 = dig - max10e; // > 0 72 | double 73 | p10 = R_pow_di(10., e10); 74 | pow10 = R_pow_di(10., max10e); 75 | x10 = (x * pow10) * p10; 76 | i10 = floor(x10); 77 | xd = i10 / pow10 / p10; 78 | xu = ceil (x10) / pow10 / p10; 79 | } 80 | double 81 | du = xu - x, 82 | dd = x - xd; 83 | // D = du - dd 84 | // return sgn * ((D < 0 || (is_odd_i10 && D == 0)) ? xu : xd); 85 | return sgn * ((du < dd || (fmod(i10, 2.) == 1 && du == dd)) ? xu : xd); 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /src/fsign.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * double fsign(double x, double y); 23 | * 24 | * DESCRIPTION 25 | * 26 | * This function performs transfer of sign. The result is: 27 | * 28 | * |x| * signum(y) 29 | */ 30 | 31 | #include "nmath.h" 32 | 33 | double fsign(double x, double y) 34 | { 35 | #ifdef IEEE_754 36 | if (ISNAN(x) || ISNAN(y)) 37 | return x + y; 38 | #endif 39 | return ((y >= 0) ? fabs(x) : -fabs(x)); 40 | } 41 | -------------------------------------------------------------------------------- /src/ftrunc.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2013 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double ftrunc(double x); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Truncation toward zero. 28 | */ 29 | 30 | #include "nmath.h" 31 | 32 | #ifdef OLD 33 | double ftrunc(double x) 34 | { 35 | if(x >= 0) return floor(x); 36 | else return ceil(x); 37 | } 38 | #else 39 | // use C99 function 40 | double ftrunc(double x) 41 | { 42 | return trunc(x); 43 | } 44 | #endif 45 | -------------------------------------------------------------------------------- /src/gammalims.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 1999-2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * void gammalims(double *xmin, double *xmax); 24 | * 25 | * DESCRIPTION 26 | * 27 | * This function calculates the minimum and maximum legal bounds 28 | * for x in gammafn(x). These are not the only bounds, but they 29 | * are the only non-trivial ones to calculate. 30 | * 31 | * NOTES 32 | * 33 | * This routine is a translation into C of a Fortran subroutine 34 | * by W. Fullerton of Los Alamos Scientific Laboratory. 35 | */ 36 | 37 | #include "nmath.h" 38 | 39 | void attribute_hidden gammalims(double *xmin, double *xmax) 40 | { 41 | /* FIXME: Even better: If IEEE, #define these in nmath.h 42 | and don't call gammalims() at all 43 | */ 44 | #ifdef IEEE_754 45 | *xmin = -170.5674972726612; 46 | *xmax = 171.61447887182298;/*(3 Intel/Sparc architectures)*/ 47 | #else 48 | double alnbig, alnsml, xln, xold; 49 | int i; 50 | 51 | alnsml = log(d1mach(1)); 52 | *xmin = -alnsml; 53 | for (i=1; i<=10; ++i) { 54 | xold = *xmin; 55 | xln = log(*xmin); 56 | *xmin -= *xmin * ((*xmin + .5) * xln - *xmin - .2258 + alnsml) / 57 | (*xmin * xln + .5); 58 | if (fabs(*xmin - xold) < .005) { 59 | *xmin = -(*xmin) + .01; 60 | goto find_xmax; 61 | } 62 | } 63 | 64 | /* unable to find xmin */ 65 | 66 | ML_WARNING(ME_NOCONV, "gammalims"); 67 | *xmin = *xmax = ML_NAN; 68 | 69 | find_xmax: 70 | 71 | alnbig = log(d1mach(2)); 72 | *xmax = alnbig; 73 | for (i=1; i<=10; ++i) { 74 | xold = *xmax; 75 | xln = log(*xmax); 76 | *xmax -= *xmax * ((*xmax - .5) * xln - *xmax + .9189 - alnbig) / 77 | (*xmax * xln - .5); 78 | if (fabs(*xmax - xold) < .005) { 79 | *xmax += -.01; 80 | goto done; 81 | } 82 | } 83 | 84 | /* unable to find xmax */ 85 | 86 | ML_WARNING(ME_NOCONV, "gammalims"); 87 | *xmin = *xmax = ML_NAN; 88 | 89 | done: 90 | *xmin = fmax2(*xmin, -(*xmax) + 1); 91 | #endif 92 | } 93 | 94 | -------------------------------------------------------------------------------- /src/i1mach.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib - A Mathematical Function Library 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-7 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | 21 | #include "nmath.h" 22 | #include 23 | 24 | attribute_hidden int Rf_i1mach(int i) 25 | { 26 | switch(i) { 27 | 28 | case 1: return 5; 29 | case 2: return 6; 30 | case 3: return 0; 31 | case 4: return 0; 32 | 33 | case 5: return CHAR_BIT * sizeof(int); 34 | case 6: return sizeof(int)/sizeof(char); 35 | 36 | case 7: return 2; 37 | case 8: return CHAR_BIT * sizeof(int) - 1; 38 | case 9: return INT_MAX; 39 | 40 | case 10: return FLT_RADIX; 41 | 42 | case 11: return FLT_MANT_DIG; 43 | case 12: return FLT_MIN_EXP; 44 | case 13: return FLT_MAX_EXP; 45 | 46 | case 14: return DBL_MANT_DIG; // 53 47 | case 15: return DBL_MIN_EXP; 48 | case 16: return DBL_MAX_EXP; 49 | 50 | default: return 0; 51 | } 52 | } 53 | 54 | int F77_NAME(i1mach)(int *i) 55 | { 56 | return Rf_i1mach(*i); 57 | } 58 | -------------------------------------------------------------------------------- /src/imax2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * int imax2(int x, int y); 23 | * 24 | * DESCRIPTION 25 | * 26 | * Compute maximum of two integers. 27 | */ 28 | 29 | #include "nmath.h" 30 | 31 | int imax2(int x, int y) 32 | { 33 | return (x < y) ? y : x; 34 | } 35 | -------------------------------------------------------------------------------- /src/imin2.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * int imin2(int x, int y); 23 | * 24 | * DESCRIPTION 25 | * 26 | * Compute minimum of two integers. 27 | */ 28 | 29 | #include "nmath.h" 30 | 31 | int imin2(int x, int y) 32 | { 33 | return (x < y) ? x : y; 34 | } 35 | -------------------------------------------------------------------------------- /src/lbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-12 The R Core Team 5 | * Copyright (C) 2003 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * SYNOPSIS 22 | * 23 | * #include 24 | * double lbeta(double a, double b); 25 | * 26 | * DESCRIPTION 27 | * 28 | * This function returns the value of the log beta function 29 | * 30 | * log B(a,b) = log G(a) + log G(b) - log G(a+b) 31 | * 32 | * NOTES 33 | * 34 | * This routine is a translation into C of a Fortran subroutine 35 | * by W. Fullerton of Los Alamos Scientific Laboratory. 36 | */ 37 | 38 | #include "nmath.h" 39 | 40 | double lbeta(double a, double b) 41 | { 42 | double corr, p, q; 43 | 44 | #ifdef IEEE_754 45 | if(ISNAN(a) || ISNAN(b)) 46 | return a + b; 47 | #endif 48 | p = q = a; 49 | if(b < p) p = b;/* := min(a,b) */ 50 | if(b > q) q = b;/* := max(a,b) */ 51 | 52 | /* both arguments must be >= 0 */ 53 | if (p < 0) 54 | ML_WARN_return_NAN 55 | else if (p == 0) { 56 | return ML_POSINF; 57 | } 58 | else if (!R_FINITE(q)) { /* q == +Inf */ 59 | return ML_NEGINF; 60 | } 61 | 62 | if (p >= 10) { 63 | /* p and q are big. */ 64 | corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q); 65 | return log(q) * -0.5 + M_LN_SQRT_2PI + corr 66 | + (p - 0.5) * log(p / (p + q)) + q * log1p(-p / (p + q)); 67 | } 68 | else if (q >= 10) { 69 | /* p is small, but q is big. */ 70 | corr = lgammacor(q) - lgammacor(p + q); 71 | return lgammafn(p) + corr + p - p * log(p + q) 72 | + (q - 0.5) * log1p(-p / (p + q)); 73 | } 74 | else { 75 | /* p and q are small: p <= q < 10. */ 76 | /* R change for very small args */ 77 | if (p < 1e-306) return lgamma(p) + (lgamma(q) - lgamma(p+q)); 78 | else return log(gammafn(p) * (gammafn(q) / gammafn(p + q))); 79 | } 80 | } 81 | -------------------------------------------------------------------------------- /src/lgammacor.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2021 The R Core Team 4 | * Copyright (C) 1998 Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double lgammacor(double x); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Compute the log gamma correction factor for x >= 10 so that 28 | * 29 | * log(gamma(x)) = .5*log(2*pi) + (x-.5)*log(x) -x + lgammacor(x) 30 | * 31 | * [ lgammacor(x) is called Del(x) in other contexts (e.g. dcdflib)] 32 | * 33 | * NOTES 34 | * 35 | * This routine is a translation into C of a Fortran subroutine 36 | * written by W. Fullerton of Los Alamos Scientific Laboratory. 37 | * 38 | * SEE ALSO 39 | * 40 | * Loader(1999)'s stirlerr() {in ./stirlerr.c} is *very* similar in spirit, 41 | * is faster and cleaner, but is only defined "fast" for half integers. 42 | */ 43 | 44 | #include "nmath.h" 45 | 46 | double attribute_hidden lgammacor(double x) 47 | { 48 | const static double algmcs[15] = { // below, nalgm = 5 ==> only the first 5 are used! 49 | +.1666389480451863247205729650822e+0, 50 | -.1384948176067563840732986059135e-4, 51 | +.9810825646924729426157171547487e-8, 52 | -.1809129475572494194263306266719e-10, 53 | +.6221098041892605227126015543416e-13, 54 | -.3399615005417721944303330599666e-15, 55 | +.2683181998482698748957538846666e-17, 56 | -.2868042435334643284144622399999e-19, 57 | +.3962837061046434803679306666666e-21, 58 | -.6831888753985766870111999999999e-23, 59 | +.1429227355942498147573333333333e-24, 60 | -.3547598158101070547199999999999e-26, 61 | +.1025680058010470912000000000000e-27, 62 | -.3401102254316748799999999999999e-29, 63 | +.1276642195630062933333333333333e-30 64 | }; 65 | 66 | /* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 : 67 | * xbig = 2 ^ 26.5 68 | * xmax = DBL_MAX / 48 = 2^1020 / 3 */ 69 | #define nalgm 5 70 | #define xbig 94906265.62425156 71 | #define xmax 3.745194030963158e306 72 | 73 | if (x < 10) // possibly consider stirlerr() 74 | ML_WARN_return_NAN 75 | else if (x >= xmax) { 76 | ML_WARNING(ME_UNDERFLOW, "lgammacor"); 77 | /* allow to underflow below */ 78 | } 79 | else if (x < xbig) { 80 | double tmp = 10 / x; 81 | return chebyshev_eval(tmp * tmp * 2 - 1, algmcs, nalgm) / x; 82 | } 83 | // else, xbig <= x < xmax : 84 | return 1 / (x * 12); 85 | } 86 | -------------------------------------------------------------------------------- /src/mlutils.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998-2024 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #ifdef HAVE_CONFIG_H 21 | # include 22 | # undef fprintf 23 | #endif 24 | #include "nmath.h" 25 | 26 | #ifdef MATHLIB_STANDALONE 27 | /* 28 | * based on code in ../main/arithmetic.c 29 | * used only in standalone Rmath lib. 30 | */ 31 | 32 | int R_finite(double x) 33 | { 34 | #ifdef HAVE_WORKING_ISFINITE 35 | return isfinite(x); 36 | # else 37 | return (!isnan(x) & (x != ML_POSINF) & (x != ML_NEGINF)); 38 | #endif 39 | } 40 | 41 | /* C++ math header undefines any isnan macro. This file 42 | doesn't get C++ headers and so is safe. */ 43 | int R_isnancpp(double x) 44 | { 45 | return (isnan(x) != 0); 46 | } 47 | 48 | static double myfmod(double x1, double x2) 49 | { 50 | double q = x1 / x2; 51 | return x1 - floor(q) * x2; 52 | } 53 | 54 | double R_pow(double x, double y) /* = x ^ y */ 55 | { 56 | if(x == 1. || y == 0.) 57 | return(1.); 58 | if(x == 0.) { 59 | if(y > 0.) return(0.); 60 | else if(y < 0) return(ML_POSINF); 61 | else return(y); /* y is NA or NaN, we assert */ 62 | } 63 | if (R_FINITE(x) && R_FINITE(y)) 64 | return(pow(x,y)); 65 | if (ISNAN(x) || ISNAN(y)) { 66 | #ifdef IEEE_754 67 | return(x + y); 68 | #else 69 | return(ML_NAN); 70 | #endif 71 | } 72 | if(!R_FINITE(x)) { 73 | if(x > 0) /* Inf ^ y */ 74 | return((y < 0.)? 0. : ML_POSINF); 75 | else { /* (-Inf) ^ y */ 76 | if(R_FINITE(y) && y == floor(y)) /* (-Inf) ^ n */ 77 | return (y < 0.) ? 0. : (myfmod(y,2.) != 0 ? x : -x); 78 | } 79 | } 80 | if(!R_FINITE(y)) { 81 | if(x >= 0) { 82 | if(y > 0) /* y == +Inf */ 83 | return((x >= 1)? ML_POSINF : 0.); 84 | else /* y == -Inf */ 85 | return((x < 1) ? ML_POSINF : 0.); 86 | } 87 | } 88 | return(ML_NAN); /* all other cases: (-Inf)^{+-Inf, 89 | non-int}; (neg)^{+-Inf} */ 90 | } 91 | 92 | double R_pow_di(double x, int n) 93 | { 94 | double pow = 1.0; 95 | 96 | if (ISNAN(x)) return x; 97 | if (n != 0) { 98 | if (!R_FINITE(x)) return R_pow(x, (double)n); 99 | if (n < 0) { n = -n; x = 1/x; } 100 | for(;;) { 101 | if(n & 01) pow *= x; 102 | if(n >>= 1) x *= x; else break; 103 | } 104 | } 105 | return pow; 106 | } 107 | 108 | double NA_REAL = ML_NAN; 109 | double R_PosInf = ML_POSINF, R_NegInf = ML_NEGINF; 110 | 111 | #include 112 | #include 113 | void attribute_hidden REprintf(const char *format, ...) 114 | { 115 | va_list(ap); 116 | va_start(ap, format); 117 | fprintf(stderr, format, ap); 118 | va_end(ap); 119 | } 120 | 121 | #endif /* MATHLIB_STANDALONE */ 122 | -------------------------------------------------------------------------------- /src/nmath2.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998-2014 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | /* Private header file for use during compilation of R */ 21 | #ifndef MATHLIB_PRIVATE2_H 22 | #define MATHLIB_PRIVATE2_H 23 | 24 | 25 | extern N01type N01_kind; 26 | extern double BM_norm_keep; 27 | 28 | 29 | #endif /* MATHLIB_PRIVATE2_H */ 30 | -------------------------------------------------------------------------------- /src/pbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2024 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * 23 | * double pbeta_raw(double x, double a, double b, int lower_tail, int log_p) 24 | * double pbeta (double x, double a, double b, int lower_tail, int log_p) 25 | * 26 | * DESCRIPTION 27 | * 28 | * Returns distribution function of the beta distribution. 29 | * ( = The incomplete beta ratio I_x(p,q) ). 30 | * 31 | * NOTES 32 | * 33 | * As from R 2.3.0, a wrapper for TOMS708 34 | * as from R 2.6.0, 'log_p' partially improved over log(p..) 35 | */ 36 | 37 | #include "nmath.h" 38 | #include "dpq.h" 39 | 40 | attribute_hidden 41 | double pbeta_raw(double x, double a, double b, int lower_tail, int log_p) 42 | { 43 | if (x >= 1) // may happen when called from qbeta() 44 | return R_DT_1; 45 | // treat limit cases correctly here: 46 | if(a == 0 || b == 0 || !R_FINITE(a) || !R_FINITE(b)) { 47 | // NB: 0 <= x < 1 : 48 | if(a == 0 && b == 0) // point mass 1/2 at each of {0,1} : 49 | return (log_p ? -M_LN2 : 0.5); 50 | if (a == 0 || a/b == 0) // point mass 1 at 0 ==> P(X <= x) = 1, all x >= 0 51 | return R_DT_1; 52 | if (b == 0 || b/a == 0) // point mass 1 at 1 ==> P(X <= x) = 0, all x < 1 53 | return R_DT_0; 54 | // else, remaining case: a = b = Inf : point mass 1 at 1/2 55 | if (x < 0.5) return R_DT_0; else return R_DT_1; 56 | } 57 | if (x <= 0) 58 | return R_DT_0; 59 | 60 | // Now: 0 < a < Inf; 0 < b < Inf and 0 < x < 1 61 | 62 | double x1 = 0.5 - x + 0.5, w, wc; 63 | int ierr; 64 | //==== 65 | bratio(a, b, x, x1, &w, &wc, &ierr, log_p); /* -> ./toms708.c */ 66 | //==== 67 | // ierr in {10,14} <==> bgrat() error code ierr-10 in 1:4; for 1 and 4, warned *there* 68 | if(ierr && ierr != 11 && ierr != 14) 69 | MATHLIB_WARNING6(_("pbeta_raw(%g, a=%g, b=%g, lower=%d, log=%d) -> bratio() gave error code %d"), 70 | x, a,b, lower_tail, log_p, ierr); 71 | return lower_tail ? w : wc; 72 | } /* pbeta_raw() */ 73 | 74 | double pbeta(double x, double a, double b, int lower_tail, int log_p) 75 | { 76 | #ifdef IEEE_754 77 | if (ISNAN(x) || ISNAN(a) || ISNAN(b)) return x + a + b; 78 | #endif 79 | 80 | if (a < 0 || b < 0) ML_WARN_return_NAN; 81 | // allowing a==0 and b==0 <==> treat as one- or two-point mass 82 | 83 | return pbeta_raw(x, a, b, lower_tail, log_p); 84 | } 85 | -------------------------------------------------------------------------------- /src/pbinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2015 The R Core Team 5 | * Copyright (C) 2004-2015 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The distribution function of the binomial distribution. 24 | */ 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double pbinom(double x, double n, double p, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(n) || ISNAN(p)) 32 | return x + n + p; 33 | if (!R_FINITE(n) || !R_FINITE(p)) ML_WARN_return_NAN; 34 | 35 | #endif 36 | if(R_nonint(n)) { 37 | MATHLIB_WARNING(_("non-integer n = %f"), n); 38 | ML_WARN_return_NAN; 39 | } 40 | n = R_forceint(n); 41 | /* PR#8560: n=0 is a valid value */ 42 | if(n < 0 || p < 0 || p > 1) ML_WARN_return_NAN; 43 | 44 | if (x < 0) return R_DT_0; 45 | x = floor(x + 1e-7); 46 | if (n <= x) return R_DT_1; 47 | return pbeta(p, x + 1, n - x, !lower_tail, log_p); 48 | } 49 | -------------------------------------------------------------------------------- /src/pcauchy.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2014 The R Core Team 5 | * Copyright (C) 2004 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The distribution function of the Cauchy distribution. 24 | */ 25 | 26 | #include 27 | 28 | #ifdef HAVE_ATANPI 29 | double atanpi(double); 30 | #endif 31 | 32 | #include "nmath.h" 33 | #include "dpq.h" 34 | 35 | double pcauchy(double x, double location, double scale, 36 | int lower_tail, int log_p) 37 | { 38 | #ifdef IEEE_754 39 | if (ISNAN(x) || ISNAN(location) || ISNAN(scale)) 40 | return x + location + scale; 41 | #endif 42 | if (scale <= 0) ML_WARN_return_NAN; 43 | 44 | x = (x - location) / scale; 45 | if (ISNAN(x)) ML_WARN_return_NAN; 46 | #ifdef IEEE_754 47 | if(!R_FINITE(x)) { 48 | if(x < 0) return R_DT_0; 49 | else return R_DT_1; 50 | } 51 | #endif 52 | if (!lower_tail) 53 | x = -x; 54 | /* for large x, the standard formula suffers from cancellation. 55 | * This is from Morten Welinder thanks to Ian Smith's atan(1/x) : */ 56 | #ifdef HAVE_ATANPI 57 | if (fabs(x) > 1) { 58 | double y = atanpi(1/x); 59 | return (x > 0) ? R_D_Clog(y) : R_D_val(-y); 60 | } else 61 | return R_D_val(0.5 + atanpi(x)); 62 | #else 63 | if (fabs(x) > 1) { 64 | double y = atan(1/x) / M_PI; 65 | return (x > 0) ? R_D_Clog(y) : R_D_val(-y); 66 | } else 67 | return R_D_val(0.5 + atan(x) / M_PI); 68 | #endif 69 | } 70 | -------------------------------------------------------------------------------- /src/pchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, but 12 | * WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the chi-squared distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double pchisq(double x, double df, int lower_tail, int log_p) 29 | { 30 | return pgamma(x, df/2., 2., lower_tail, log_p); 31 | } 32 | -------------------------------------------------------------------------------- /src/pexp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2015 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the exponential distribution. 23 | */ 24 | #include "nmath.h" 25 | #include "dpq.h" 26 | 27 | double pexp(double x, double scale, int lower_tail, int log_p) 28 | { 29 | #ifdef IEEE_754 30 | if (ISNAN(x) || ISNAN(scale)) 31 | return x + scale; 32 | if (scale < 0) ML_WARN_return_NAN; 33 | #else 34 | if (scale <= 0) ML_WARN_return_NAN; 35 | #endif 36 | 37 | if (x <= 0.) 38 | return R_DT_0; 39 | /* same as weibull( shape = 1): */ 40 | x = -(x / scale); 41 | return lower_tail 42 | ? (log_p ? R_Log1_Exp(x) : -expm1(x)) 43 | : R_D_exp(x); 44 | } 45 | -------------------------------------------------------------------------------- /src/pf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-8 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the F distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double pf(double x, double df1, double df2, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(df1) || ISNAN(df2)) 32 | return x + df2 + df1; 33 | #endif 34 | if (df1 <= 0. || df2 <= 0.) ML_WARN_return_NAN; 35 | 36 | R_P_bounds_01(x, 0., ML_POSINF); 37 | 38 | /* move to pchisq for very large values - was 'df1 > 4e5' in 2.0.x, 39 | now only needed for df1 = Inf or df2 = Inf {since pbeta(0,*)=0} : */ 40 | if (df2 == ML_POSINF) { 41 | if (df1 == ML_POSINF) { 42 | if(x < 1.) return R_DT_0; 43 | if(x == 1.) return (log_p ? -M_LN2 : 0.5); 44 | if(x > 1.) return R_DT_1; 45 | } 46 | 47 | return pchisq(x * df1, df1, lower_tail, log_p); 48 | } 49 | 50 | if (df1 == ML_POSINF)/* was "fudge" 'df1 > 4e5' in 2.0.x */ 51 | return pchisq(df2 / x , df2, !lower_tail, log_p); 52 | 53 | /* Avoid squeezing pbeta's first parameter against 1 : */ 54 | if (df1 * x > df2) 55 | x = pbeta(df2 / (df2 + df1 * x), df2 / 2., df1 / 2., 56 | !lower_tail, log_p); 57 | else 58 | x = pbeta(df1 * x / (df2 + df1 * x), df1 / 2., df2 / 2., 59 | lower_tail, log_p); 60 | 61 | return ML_VALID(x) ? x : ML_NAN; 62 | } 63 | -------------------------------------------------------------------------------- /src/pgeom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2006 The R Core Team 5 | * Copyright (C) 2004 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The distribution function of the geometric distribution. 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double pgeom(double x, double p, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(x) || ISNAN(p)) 33 | return x + p; 34 | #endif 35 | if(p <= 0 || p > 1) ML_WARN_return_NAN; 36 | 37 | if (x < 0.) return R_DT_0; 38 | if (!R_FINITE(x)) return R_DT_1; 39 | x = floor(x +1e-7); 40 | 41 | if(p == 1.) { /* we cannot assume IEEE */ 42 | x = lower_tail ? 1: 0; 43 | return log_p ? log(x) : x; 44 | } 45 | x = log1p(-p) * (x + 1); 46 | if (log_p) 47 | return R_DT_Clog(x); 48 | else 49 | return lower_tail ? -expm1(x) : exp(x); 50 | } 51 | -------------------------------------------------------------------------------- /src/plnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-8 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The lognormal distribution function. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double plnorm(double x, double meanlog, double sdlog, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(meanlog) || ISNAN(sdlog)) 32 | return x + meanlog + sdlog; 33 | #endif 34 | if (sdlog < 0) ML_WARN_return_NAN; 35 | 36 | if (x > 0) 37 | return pnorm(log(x), meanlog, sdlog, lower_tail, log_p); 38 | return R_DT_0; 39 | } 40 | -------------------------------------------------------------------------------- /src/plogis.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2000--2020 The R Core Team 4 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | #include "nmath.h" 21 | #include "dpq.h" 22 | 23 | /* Compute log(1 + exp(x)) without overflow (and fast for x > 18) 24 | For the two cutoffs, consider in R 25 | curve(log1p(exp(x)) - x, 33.1, 33.5, n=2^10) 26 | curve(x+exp(-x) - log1p(exp(x)), 15, 25, n=2^11) 27 | */ 28 | double log1pexp(double x) { 29 | if(x <= 18.) return log1p(exp(x)); 30 | if(x > 33.3) return x; 31 | // else: 18.0 < x <= 33.3 : 32 | return x + exp(-x); 33 | } 34 | 35 | // API. For now, continue using macro R_Log1_Exp() in our own code. 36 | double log1mexp(double x) { return R_Log1_Exp(-x); } 37 | 38 | double plogis(double x, double location, double scale, 39 | int lower_tail, int log_p) 40 | { 41 | #ifdef IEEE_754 42 | if (ISNAN(x) || ISNAN(location) || ISNAN(scale)) 43 | return x + location + scale; 44 | #endif 45 | if (scale <= 0.0) ML_WARN_return_NAN; 46 | 47 | x = (x - location) / scale; 48 | if (ISNAN(x)) ML_WARN_return_NAN; 49 | R_P_bounds_Inf_01(x); 50 | 51 | if(log_p) { 52 | // log(1 / (1 + exp( +- x ))) = -log(1 + exp( +- x)) 53 | return -log1pexp(lower_tail ? -x : x); 54 | } else { 55 | return 1 / (1 + exp(lower_tail ? -x : x)); 56 | } 57 | } 58 | 59 | -------------------------------------------------------------------------------- /src/pnbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (C) 2000-2015 The R Core Team 3 | * 4 | * Algorithm AS 226 Appl. Statist. (1987) Vol. 36, No. 2 5 | * by Russell V. Lenth 6 | * Incorporates modification AS R84 from AS Vol. 39, pp311-2, 1990 7 | * and AS R95 from AS Vol. 44, pp551-2, 1995 8 | * by H. Frick and Min Long Lam. 9 | * original (C) Royal Statistical Society 1987, 1990, 1995 10 | * 11 | * Returns the cumulative probability of x for the non-central 12 | * beta distribution with parameters a, b and non-centrality ncp. 13 | * 14 | * Auxiliary routines required: 15 | * lgamma - log-gamma function 16 | * pbeta - incomplete-beta function {nowadays: pbeta_raw() -> bratio()} 17 | */ 18 | 19 | #include "nmath.h" 20 | #include "dpq.h" 21 | 22 | LDOUBLE attribute_hidden 23 | pnbeta_raw(double x, double o_x, double a, double b, double ncp) 24 | { 25 | /* o_x == 1 - x but maybe more accurate */ 26 | 27 | /* change errmax and itrmax if desired; 28 | * original (AS 226, R84) had (errmax; itrmax) = (1e-6; 100) */ 29 | const static double errmax = 1.0e-9; 30 | const int itrmax = 10000; /* 100 is not enough for pf(ncp=200) 31 | see PR#11277 */ 32 | 33 | double a0, lBeta, c, errbd, x0, temp, tmp_c; 34 | int ierr; 35 | 36 | LDOUBLE ans, ax, gx, q, sumq; 37 | 38 | if (ncp < 0. || a <= 0. || b <= 0.) ML_WARN_return_NAN; 39 | 40 | if(x < 0. || o_x > 1. || (x == 0. && o_x == 1.)) return 0.; 41 | if(x > 1. || o_x < 0. || (x == 1. && o_x == 0.)) return 1.; 42 | 43 | c = ncp / 2.; 44 | 45 | /* initialize the series */ 46 | 47 | x0 = floor(fmax2(c - 7. * sqrt(c), 0.)); 48 | a0 = a + x0; 49 | lBeta = lbeta(a0, b); // = lgammafn(a0) + lgammafn(b) - lgammafn(a0 + b); 50 | /* temp = pbeta_raw(x, a0, b, TRUE, FALSE), but using (x, o_x): */ 51 | bratio(a0, b, x, o_x, &temp, &tmp_c, &ierr, FALSE); 52 | 53 | gx = exp(a0 * log(x) + b * (x < .5 ? log1p(-x) : log(o_x)) 54 | - lBeta - log(a0)); 55 | if (a0 > a) // x0 >= 1 (and *not* x0 << a) 56 | q = exp(-c + x0 * log(c) - lgammafn(x0 + 1.)); 57 | else // a0 = a <== x0 << a 58 | q = exp(-c); 59 | 60 | sumq = 1. - q; 61 | ans = ax = q * temp; 62 | 63 | /* recurse over subsequent terms until convergence is achieved */ 64 | double j = floor(x0); // x0 could be billions, and is in package EnvStats 65 | do { 66 | j++; 67 | temp -= (double) gx; 68 | gx *= x * (a + b + j - 1.) / (a + j); 69 | q *= c / j; 70 | sumq -= q; 71 | ax = temp * q; 72 | ans += ax; 73 | errbd = (double)((temp - gx) * sumq); 74 | } 75 | while (errbd > errmax && j < itrmax + x0); 76 | 77 | if (errbd > errmax) 78 | ML_WARNING(ME_PRECISION, "pnbeta"); 79 | if (j >= itrmax + x0) 80 | ML_WARNING(ME_NOCONV, "pnbeta"); 81 | 82 | return ans; 83 | } 84 | 85 | double attribute_hidden 86 | pnbeta2(double x, double o_x, double a, double b, double ncp, 87 | /* o_x == 1 - x but maybe more accurate */ 88 | int lower_tail, int log_p) 89 | { 90 | LDOUBLE ans = pnbeta_raw(x, o_x, a,b, ncp); 91 | 92 | /* return R_DT_val(ans), but we want to warn about cancellation here */ 93 | if (lower_tail) 94 | #ifdef HAVE_LONG_DOUBLE 95 | return (double) (log_p ? logl(ans) : ans); 96 | #else 97 | return log_p ? log(ans) : ans; 98 | #endif 99 | else { 100 | if (ans > 1. - 1e-10) ML_WARNING(ME_PRECISION, "pnbeta"); 101 | if (ans > 1.0) ans = 1.0; /* Precaution */ 102 | #if defined(HAVE_LONG_DOUBLE) && defined(HAVE_LOG1PL) 103 | return (double) (log_p ? log1pl(-ans) : (1. - ans)); 104 | #else 105 | /* include standalone case */ 106 | return (double) (log_p ? log1p((double)-ans) : (1. - ans)); 107 | #endif 108 | } 109 | } 110 | 111 | double pnbeta(double x, double a, double b, double ncp, 112 | int lower_tail, int log_p) 113 | { 114 | #ifdef IEEE_754 115 | if (ISNAN(x) || ISNAN(a) || ISNAN(b) || ISNAN(ncp)) 116 | return x + a + b + ncp; 117 | #endif 118 | 119 | R_P_bounds_01(x, 0., 1.); 120 | return pnbeta2(x, 1-x, a, b, ncp, lower_tail, log_p); 121 | } 122 | -------------------------------------------------------------------------------- /src/pnbinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2016 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the negative binomial distribution. 23 | * 24 | * NOTES 25 | * 26 | * x = the number of failures before the n-th success 27 | */ 28 | 29 | #include "nmath.h" 30 | #include "dpq.h" 31 | 32 | double pnbinom(double x, double size, double prob, int lower_tail, int log_p) 33 | { 34 | #ifdef IEEE_754 35 | if (ISNAN(x) || ISNAN(size) || ISNAN(prob)) 36 | return x + size + prob; 37 | if(!R_FINITE(size) || !R_FINITE(prob)) ML_WARN_return_NAN; 38 | #endif 39 | if (size < 0 || prob <= 0 || prob > 1) ML_WARN_return_NAN; 40 | 41 | /* limiting case: point mass at zero */ 42 | if (size == 0) 43 | return (x >= 0) ? R_DT_1 : R_DT_0; 44 | 45 | if (x < 0) return R_DT_0; 46 | if (!R_FINITE(x)) return R_DT_1; 47 | x = floor(x + 1e-7); 48 | return pbeta(prob, size, x + 1, lower_tail, log_p); 49 | } 50 | 51 | double pnbinom_mu(double x, double size, double mu, int lower_tail, int log_p) 52 | { 53 | #ifdef IEEE_754 54 | if (ISNAN(x) || ISNAN(size) || ISNAN(mu)) 55 | return x + size + mu; 56 | if(!R_FINITE(mu)) ML_WARN_return_NAN; 57 | #endif 58 | if (size < 0 || mu < 0) ML_WARN_return_NAN; 59 | 60 | /* limiting case: point mass at zero */ 61 | if (size == 0) 62 | return (x >= 0) ? R_DT_1 : R_DT_0; 63 | 64 | if (x < 0) return R_DT_0; 65 | if (!R_FINITE(x)) return R_DT_1; 66 | if (!R_FINITE(size)) // limit case: Poisson 67 | return(ppois(x, mu, lower_tail, log_p)); 68 | 69 | x = floor(x + 1e-7); 70 | /* return 71 | * pbeta(pr, size, x + 1, lower_tail, log_p); pr = size/(size + mu), 1-pr = mu/(size+mu) 72 | * 73 | *= pbeta_raw(pr, size, x + 1, lower_tail, log_p) 74 | * x. pin qin 75 | *= bratio (pin, qin, x., 1-x., &w, &wc, &ierr, log_p), and return w or wc .. 76 | *= bratio (size, x+1, pr, 1-pr, &w, &wc, &ierr, log_p) */ 77 | { 78 | int ierr; 79 | double w, wc; 80 | bratio(size, x+1, size/(size+mu), mu/(size+mu), &w, &wc, &ierr, log_p); 81 | if(ierr) 82 | MATHLIB_WARNING(_("pnbinom_mu() -> bratio() gave error code %d"), ierr); 83 | return lower_tail ? w : wc; 84 | } 85 | } 86 | -------------------------------------------------------------------------------- /src/pnf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-8 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the non-central F distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double pnf(double x, double df1, double df2, double ncp, 29 | int lower_tail, int log_p) 30 | { 31 | double y; 32 | #ifdef IEEE_754 33 | if (ISNAN(x) || ISNAN(df1) || ISNAN(df2) || ISNAN(ncp)) 34 | return x + df2 + df1 + ncp; 35 | #endif 36 | if (df1 <= 0. || df2 <= 0. || ncp < 0) ML_WARN_return_NAN; 37 | if (!R_FINITE(ncp)) ML_WARN_return_NAN; 38 | if (!R_FINITE(df1) && !R_FINITE(df2)) /* both +Inf */ 39 | ML_WARN_return_NAN; 40 | 41 | R_P_bounds_01(x, 0., ML_POSINF); 42 | 43 | if (df2 > 1e8) /* avoid problems with +Inf and loss of accuracy */ 44 | return pnchisq(x * df1, df1, ncp, lower_tail, log_p); 45 | 46 | y = (df1 / df2) * x; 47 | return pnbeta2(y/(1. + y), 1./(1. + y), df1 / 2., df2 / 2., 48 | ncp, lower_tail, log_p); 49 | } 50 | -------------------------------------------------------------------------------- /src/ppois.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the Poisson distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double ppois(double x, double lambda, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(lambda)) 32 | return x + lambda; 33 | #endif 34 | if(lambda < 0.) ML_WARN_return_NAN; 35 | if (x < 0) return R_DT_0; 36 | if (lambda == 0.) return R_DT_1; 37 | if (!R_FINITE(x)) return R_DT_1; 38 | x = floor(x + 1e-7); 39 | 40 | return pgamma(lambda, x + 1, 1., !lower_tail, log_p); 41 | } 42 | -------------------------------------------------------------------------------- /src/pt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 2000-2007 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | 21 | #include "nmath.h" 22 | #include "dpq.h" 23 | 24 | double pt(double x, double n, int lower_tail, int log_p) 25 | { 26 | /* return P[ T <= x ] where 27 | * T ~ t_{n} (t distrib. with n degrees of freedom). 28 | 29 | * --> ./pnt.c for NON-central 30 | */ 31 | double val, nx; 32 | #ifdef IEEE_754 33 | if (ISNAN(x) || ISNAN(n)) 34 | return x + n; 35 | #endif 36 | if (n <= 0.0) ML_WARN_return_NAN; 37 | 38 | if(!R_FINITE(x)) 39 | return (x < 0) ? R_DT_0 : R_DT_1; 40 | if(!R_FINITE(n)) 41 | return pnorm(x, 0.0, 1.0, lower_tail, log_p); 42 | 43 | #ifdef R_version_le_260 44 | if (n > 4e5) { /*-- Fixme(?): test should depend on `n' AND `x' ! */ 45 | /* Approx. from Abramowitz & Stegun 26.7.8 (p.949) */ 46 | val = 1./(4.*n); 47 | return pnorm(x*(1. - val)/sqrt(1. + x*x*2.*val), 0.0, 1.0, 48 | lower_tail, log_p); 49 | } 50 | #endif 51 | 52 | nx = 1 + (x/n)*x; 53 | /* FIXME: This test is probably losing rather than gaining precision, 54 | * now that pbeta(*, log_p = TRUE) is much better. 55 | * Note however that a version of this test *is* needed for x*x > D_MAX */ 56 | if(nx > 1e100) { /* <==> x*x > 1e100 * n */ 57 | /* Danger of underflow. So use Abramowitz & Stegun 26.5.4 58 | pbeta(z, a, b) ~ z^a(1-z)^b / aB(a,b) ~ z^a / aB(a,b), 59 | with z = 1/nx, a = n/2, b= 1/2 : 60 | */ 61 | double lval; 62 | lval = -0.5*n*(2*log(fabs(x)) - log(n)) 63 | - lbeta(0.5*n, 0.5) - log(0.5*n); 64 | val = log_p ? lval : exp(lval); 65 | } else { 66 | val = (n > x * x) 67 | ? pbeta (x * x / (n + x * x), 0.5, n / 2., /*lower_tail*/0, log_p) 68 | : pbeta (1. / nx, n / 2., 0.5, /*lower_tail*/1, log_p); 69 | } 70 | 71 | /* Use "1 - v" if lower_tail and x > 0 (but not both):*/ 72 | if(x <= 0.) 73 | lower_tail = !lower_tail; 74 | 75 | if(log_p) { 76 | if(lower_tail) return log1p(-0.5*exp(val)); 77 | else return val - M_LN2; /* = log(.5* pbeta(....)) */ 78 | } 79 | else { 80 | val /= 2.; 81 | return R_D_Cval(val); 82 | } 83 | } 84 | -------------------------------------------------------------------------------- /src/punif.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2006 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the uniform distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double punif(double x, double a, double b, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(a) || ISNAN(b)) 32 | return x + a + b; 33 | #endif 34 | if (b < a) ML_WARN_return_NAN; 35 | if (!R_FINITE(a) || !R_FINITE(b)) ML_WARN_return_NAN; 36 | 37 | if (x >= b) 38 | return R_DT_1; 39 | if (x <= a) 40 | return R_DT_0; 41 | if (lower_tail) return R_D_val((x - a) / (b - a)); 42 | else return R_D_val((b - x) / (b - a)); 43 | } 44 | -------------------------------------------------------------------------------- /src/pweibull.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2015 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The distribution function of the Weibull distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double pweibull(double x, double shape, double scale, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(x) || ISNAN(shape) || ISNAN(scale)) 32 | return x + shape + scale; 33 | #endif 34 | if(shape <= 0 || scale <= 0) ML_WARN_return_NAN; 35 | 36 | if (x <= 0) 37 | return R_DT_0; 38 | x = -pow(x / scale, shape); 39 | return lower_tail 40 | ? (log_p ? R_Log1_Exp(x) : -expm1(x)) 41 | : R_D_exp(x); 42 | } 43 | -------------------------------------------------------------------------------- /src/qbinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1999-2021 The R Core Team 4 | * Copyright (C) 2003-2021 The R Foundation 5 | * Copyright (C) 1998 Ross Ihaka 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The quantile function of the binomial distribution. 24 | * 25 | * METHOD 26 | * 27 | * Uses the Cornish-Fisher Expansion to include a skewness 28 | * correction to a normal approximation. This gives an 29 | * initial value which never seems to be off by more than 30 | * 1 or 2. A search is then conducted of values close to 31 | * this initial start point. 32 | */ 33 | #include "nmath.h" 34 | #include "dpq.h" 35 | 36 | #ifdef DEBUG_qbinom 37 | # define R_DBG_printf(...) REprintf(__VA_ARGS__) 38 | #else 39 | # define R_DBG_printf(...) 40 | #endif 41 | 42 | 43 | #define _thisDIST_ binom 44 | #define _dist_PARS_DECL_ double n, double pr 45 | #define _dist_PARS_ n, pr 46 | #define _dist_MAX_y n 47 | // === Binomial Y <= n 48 | 49 | #include "qDiscrete_search.h" 50 | // ------------------> do_search() and all called by q_DISCRETE_*() below 51 | 52 | double qbinom(double p, double n, double pr, int lower_tail, int log_p) 53 | { 54 | #ifdef IEEE_754 55 | if (ISNAN(p) || ISNAN(n) || ISNAN(pr)) 56 | return p + n + pr; 57 | #endif 58 | if(!R_FINITE(n) || !R_FINITE(pr)) 59 | ML_WARN_return_NAN; 60 | /* if log_p is true, p = -Inf is a legitimate value */ 61 | if(!R_FINITE(p) && !log_p) 62 | ML_WARN_return_NAN; 63 | 64 | n = R_forceint(n); 65 | 66 | if (pr < 0 || pr > 1 || n < 0) 67 | ML_WARN_return_NAN; 68 | 69 | R_Q_P01_boundaries(p, 0, n); 70 | 71 | if (pr == 0. || n == 0) return 0.; 72 | if (pr == 1.) return n; /* covers the full range of the distribution */ 73 | 74 | // (NB: unavoidable cancellation for pr ~= 1) 75 | double 76 | q = 1 - pr, 77 | mu = n * pr, 78 | sigma = sqrt(n * pr * q), 79 | gamma = (q - pr) / sigma; 80 | 81 | R_DBG_printf("qbinom(p=%.12g, n=%.15g, pr=%.7g, l.t.=%d, log=%d): sigma=%g, gamma=%g;\n", 82 | p, n,pr, lower_tail, log_p, sigma, gamma); 83 | 84 | q_DISCRETE_01_CHECKS(); 85 | q_DISCRETE_BODY(); 86 | } 87 | -------------------------------------------------------------------------------- /src/qcauchy.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2013 The R Core Team 5 | * Copyright (C) 2005-6 The R Foundation 6 | * 7 | * This version is based on a suggestion by Morten Welinder. 8 | * 9 | * This program is free software; you can redistribute it and/or modify 10 | * it under the terms of the GNU General Public License as published by 11 | * the Free Software Foundation; either version 2 of the License, or 12 | * (at your option) any later version. 13 | * 14 | * This program is distributed in the hope that it will be useful, 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | * GNU General Public License for more details. 18 | * 19 | * You should have received a copy of the GNU General Public License 20 | * along with this program; if not, a copy is available at 21 | * https://www.R-project.org/Licenses/ 22 | * 23 | * DESCRIPTION 24 | * 25 | * The quantile function of the Cauchy distribution. 26 | */ 27 | 28 | #include "nmath.h" 29 | #include "dpq.h" 30 | 31 | double qcauchy(double p, double location, double scale, 32 | int lower_tail, int log_p) 33 | { 34 | #ifdef IEEE_754 35 | if (ISNAN(p) || ISNAN(location) || ISNAN(scale)) 36 | return p + location + scale; 37 | #endif 38 | R_Q_P01_check(p); 39 | if (scale <= 0 || !R_FINITE(scale)) { 40 | if (scale == 0) return location; 41 | /* else */ ML_WARN_return_NAN; 42 | } 43 | 44 | #define my_INF location + (lower_tail ? scale : -scale) * ML_POSINF 45 | if (log_p) { 46 | if (p > -1) { 47 | /* when ep := exp(p), 48 | * tan(pi*ep)= -tan(pi*(-ep))= -tan(pi*(-ep)+pi) = -tan(pi*(1-ep)) = 49 | * = -tan(pi*(-expm1(p)) 50 | * for p ~ 0, exp(p) ~ 1, tan(~0) may be better than tan(~pi). 51 | */ 52 | if (p == 0.) /* needed, since 1/tan(-0) = -Inf for some arch. */ 53 | return my_INF; 54 | lower_tail = !lower_tail; 55 | p = -expm1(p); 56 | } else 57 | p = exp(p); 58 | } else { 59 | if (p > 0.5) { 60 | if (p == 1.) 61 | return my_INF; 62 | p = 1 - p; 63 | lower_tail = !lower_tail; 64 | } 65 | } 66 | 67 | if (p == 0.5) return location; // avoid 1/Inf below 68 | if (p == 0.) return location + (lower_tail ? scale : -scale) * ML_NEGINF; // p = 1. is handled above 69 | return location + (lower_tail ? -scale : scale) / tanpi(p); 70 | /* -1/tan(pi * p) = -cot(pi * p) = tan(pi * (p - 1/2)) */ 71 | } 72 | -------------------------------------------------------------------------------- /src/qchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The quantile function of the chi-squared distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double qchisq(double p, double df, int lower_tail, int log_p) 29 | { 30 | return qgamma(p, 0.5 * df, 2.0, lower_tail, log_p); 31 | } 32 | -------------------------------------------------------------------------------- /src/qexp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The quantile function of the exponential distribution. 23 | * 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double qexp(double p, double scale, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(scale)) 33 | return p + scale; 34 | #endif 35 | if (scale < 0) ML_WARN_return_NAN; 36 | 37 | R_Q_P01_check(p); 38 | if (p == R_DT_0) 39 | return 0; 40 | 41 | return - scale * R_DT_Clog(p); 42 | } 43 | -------------------------------------------------------------------------------- /src/qf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2015 The R Core Team 4 | * Copyright (C) 2005 The R Foundation 5 | * Copyright (C) 1998 Ross Ihaka 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The quantile function of the F distribution. 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double qf(double p, double df1, double df2, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(df1) || ISNAN(df2)) 33 | return p + df1 + df2; 34 | #endif 35 | if (df1 <= 0. || df2 <= 0.) ML_WARN_return_NAN; 36 | 37 | R_Q_P01_boundaries(p, 0, ML_POSINF); 38 | 39 | /* fudge the extreme DF cases -- qbeta doesn't do this well. 40 | But we still need to fudge the infinite ones. 41 | */ 42 | 43 | if (df1 <= df2 && df2 > 4e5) { 44 | if(!R_FINITE(df1)) /* df1 == df2 == Inf : */ 45 | return 1.; 46 | /* else value for df2 == Inf : */ 47 | return qchisq(p, df1, lower_tail, log_p) / df1; 48 | } 49 | else if (df1 > 4e5) { /* and so df2 < df1 -- return value for df1 == Inf */ 50 | return df2 / qchisq(p, df2, !lower_tail, log_p); 51 | } 52 | 53 | // FIXME: (1/qb - 1) = (1 - qb)/qb; if we know qb ~= 1, should use other tail 54 | p = (1. / qbeta(p, df2/2, df1/2, !lower_tail, log_p) - 1.) * (df2 / df1); 55 | return ML_VALID(p) ? p : ML_NAN; 56 | } 57 | -------------------------------------------------------------------------------- /src/qgeom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000--2016 The R Core Team 5 | * Copyright (C) 2004--2016 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The quantile function of the geometric distribution. 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double qgeom(double p, double prob, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(prob)) 33 | return p + prob; 34 | #endif 35 | if (prob <= 0 || prob > 1) ML_WARN_return_NAN; 36 | 37 | R_Q_P01_check(p); 38 | if (prob == 1) return(0); 39 | R_Q_P01_boundaries(p, 0, ML_POSINF); 40 | 41 | /* add a fuzz to ensure left continuity, but value must be >= 0 */ 42 | return fmax2(0, ceil(R_DT_Clog(p) / log1p(- prob) - 1 - 1e-12)); 43 | } 44 | -------------------------------------------------------------------------------- /src/qhyper.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2014 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The quantile function of the hypergeometric distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double qhyper(double p, double NR, double NB, double n, 29 | int lower_tail, int log_p) 30 | { 31 | /* This is basically the same code as ./phyper.c *used* to be --> FIXME! */ 32 | double N, xstart, xend, xr, xb, sum, term; 33 | int small_N; 34 | #ifdef IEEE_754 35 | if (ISNAN(p) || ISNAN(NR) || ISNAN(NB) || ISNAN(n)) 36 | return p + NR + NB + n; 37 | #endif 38 | if(!R_FINITE(p) || !R_FINITE(NR) || !R_FINITE(NB) || !R_FINITE(n)) 39 | ML_WARN_return_NAN; 40 | 41 | NR = R_forceint(NR); 42 | NB = R_forceint(NB); 43 | N = NR + NB; 44 | n = R_forceint(n); 45 | if (NR < 0 || NB < 0 || n < 0 || n > N) 46 | ML_WARN_return_NAN; 47 | 48 | /* Goal: Find xr (= #{red balls in sample}) such that 49 | * phyper(xr, NR,NB, n) >= p > phyper(xr - 1, NR,NB, n) 50 | */ 51 | 52 | xstart = fmax2(0, n - NB); 53 | xend = fmin2(n, NR); 54 | 55 | R_Q_P01_boundaries(p, xstart, xend); 56 | 57 | xr = xstart; 58 | xb = n - xr;/* always ( = #{black balls in sample} ) */ 59 | 60 | small_N = (N < 1000); /* won't have underflow in product below */ 61 | /* if N is small, term := product.ratio( bin.coef ); 62 | otherwise work with its logarithm to protect against underflow */ 63 | term = lfastchoose(NR, xr) + lfastchoose(NB, xb) - lfastchoose(N, n); 64 | if(small_N) term = exp(term); 65 | NR -= xr; 66 | NB -= xb; 67 | 68 | if(!lower_tail || log_p) { 69 | p = R_DT_qIv(p); 70 | } 71 | p *= 1 - 1000*DBL_EPSILON; /* was 64, but failed on FreeBSD sometimes */ 72 | sum = small_N ? term : exp(term); 73 | 74 | while(sum < p && xr < xend) { 75 | xr++; 76 | NB++; 77 | if (small_N) term *= (NR / xr) * (xb / NB); 78 | else term += log((NR / xr) * (xb / NB)); 79 | sum += small_N ? term : exp(term); 80 | xb--; 81 | NR--; 82 | } 83 | return xr; 84 | } 85 | -------------------------------------------------------------------------------- /src/qlnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-8 The R Core Team 5 | * Copyright (C) 2005 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * This the lognormal quantile function. 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double qlnorm(double p, double meanlog, double sdlog, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(meanlog) || ISNAN(sdlog)) 33 | return p + meanlog + sdlog; 34 | #endif 35 | R_Q_P01_boundaries(p, 0, ML_POSINF); 36 | 37 | return exp(qnorm(p, meanlog, sdlog, lower_tail, log_p)); 38 | } 39 | -------------------------------------------------------------------------------- /src/qlogis.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * Copyright (C) 2005 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | */ 21 | 22 | #include "nmath.h" 23 | #include "dpq.h" 24 | 25 | double qlogis(double p, double location, double scale, int lower_tail, int log_p) 26 | { 27 | #ifdef IEEE_754 28 | if (ISNAN(p) || ISNAN(location) || ISNAN(scale)) 29 | return p + location + scale; 30 | #endif 31 | R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF); 32 | 33 | if (scale < 0.) ML_WARN_return_NAN; 34 | if (scale == 0.) return location; 35 | 36 | /* p := logit(p) = log( p / (1-p) ) : */ 37 | if(log_p) { 38 | if(lower_tail) 39 | p = p - R_Log1_Exp(p); 40 | else 41 | p = R_Log1_Exp(p) - p; 42 | } 43 | else 44 | p = log(lower_tail ? (p / (1. - p)) : ((1. - p) / p)); 45 | 46 | return location + scale * p; 47 | } 48 | -------------------------------------------------------------------------------- /src/qnbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2006 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #include "nmath.h" 21 | #include "dpq.h" 22 | 23 | double qnbeta(double p, double a, double b, double ncp, 24 | int lower_tail, int log_p) 25 | { 26 | const static double accu = 1e-15; 27 | const static double Eps = 1e-14; /* must be > accu */ 28 | 29 | double ux, lx, nx, pp; 30 | 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(a) || ISNAN(b) || ISNAN(ncp)) 33 | return p + a + b + ncp; 34 | #endif 35 | if (!R_FINITE(a)) ML_WARN_return_NAN; 36 | 37 | if (ncp < 0. || a <= 0. || b <= 0.) ML_WARN_return_NAN; 38 | 39 | R_Q_P01_boundaries(p, 0, 1); 40 | 41 | p = R_DT_qIv(p); 42 | 43 | /* Invert pnbeta(.) : 44 | * 1. finding an upper and lower bound */ 45 | if(p > 1 - DBL_EPSILON) return 1.0; 46 | pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps)); 47 | for(ux = 0.5; 48 | ux < 1 - DBL_EPSILON && pnbeta(ux, a, b, ncp, TRUE, FALSE) < pp; 49 | ux = 0.5*(1+ux)); 50 | pp = p * (1 - Eps); 51 | for(lx = 0.5; 52 | lx > DBL_MIN && pnbeta(lx, a, b, ncp, TRUE, FALSE) > pp; 53 | lx *= 0.5); 54 | 55 | /* 2. interval (lx,ux) halving : */ 56 | do { 57 | nx = 0.5 * (lx + ux); 58 | if (pnbeta(nx, a, b, ncp, TRUE, FALSE) > p) ux = nx; else lx = nx; 59 | } 60 | while ((ux - lx) / nx > accu); 61 | 62 | return 0.5 * (ux + lx); 63 | } 64 | -------------------------------------------------------------------------------- /src/qnbinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2021 The R Core Team 4 | * Copyright (C) 2005-2021 The R Foundation 5 | * Copyright (C) 1998 Ross Ihaka 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * SYNOPSIS 22 | * 23 | * #include 24 | * double qnbinom(double p, double size, double prob, 25 | * int lower_tail, int log_p) 26 | * 27 | * DESCRIPTION 28 | * 29 | * The quantile function of the negative binomial distribution, 30 | * for the (size, prob) parametrizations 31 | * 32 | * NOTES 33 | * 34 | * x = the number of failures before the n-th success 35 | * 36 | * METHOD 37 | * 38 | * Uses the Cornish-Fisher Expansion to include a skewness 39 | * correction to a normal approximation. This gives an 40 | * initial value which never seems to be off by more than 41 | * 1 or 2. A search is then conducted of values close to 42 | * this initial start point. 43 | */ 44 | 45 | #include "nmath.h" 46 | #include "dpq.h" 47 | 48 | /*-------- DEBUGGING ------------- make CFLAGS='-DDEBUG_qnbinom ...' 49 | */ 50 | #ifdef DEBUG_qnbinom 51 | # define R_DBG_printf(...) REprintf(__VA_ARGS__) 52 | #else 53 | # define R_DBG_printf(...) 54 | #endif 55 | 56 | #define _thisDIST_ nbinom 57 | #define _dist_PARS_DECL_ double size, double prob 58 | #define _dist_PARS_ size, prob 59 | 60 | #include "qDiscrete_search.h" 61 | // ------------------> do_search() and all called by q_DISCRETE_*() below 62 | 63 | double qnbinom(double p, double size, double prob, int lower_tail, int log_p) 64 | { 65 | #ifdef IEEE_754 66 | if (ISNAN(p) || ISNAN(size) || ISNAN(prob)) 67 | return p + size + prob; 68 | #endif 69 | 70 | /* this happens if specified via mu, size, since 71 | prob == size/(size+mu) 72 | */ 73 | if (prob == 0 && size == 0) return 0; 74 | if (prob <= 0 || prob > 1 || size < 0) ML_WARN_return_NAN; 75 | if (prob == 1 || size == 0) return 0; 76 | 77 | R_Q_P01_boundaries(p, 0, ML_POSINF); 78 | 79 | double 80 | Q = 1.0 / prob, 81 | P = (1.0 - prob) * Q, // = (1 - prob) / prob = Q - 1 82 | mu = size * P, 83 | sigma = sqrt(size * P * Q), 84 | gamma = (Q + P)/sigma; 85 | 86 | R_DBG_printf("qnbinom(p=%.12g, size=%.15g, prob=%g, l.t.=%d, log=%d):" 87 | " mu=%g, sigma=%g, gamma=%g;\n", 88 | p, size, prob, lower_tail, log_p, mu, sigma, gamma); 89 | 90 | q_DISCRETE_01_CHECKS(); 91 | q_DISCRETE_BODY(); 92 | } 93 | -------------------------------------------------------------------------------- /src/qnbinom_mu.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000-2021 The R Core Team 4 | * Copyright (C) 2005-2021 The R Foundation 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double qnbinom_mu(double p, double size, double mu, 24 | * int lower_tail, int log_p) 25 | * 26 | * DESCRIPTION 27 | * 28 | * The quantile function of the negative binomial distribution, 29 | * for the (size, mu) parametrizations 30 | * 31 | * METHOD 32 | * 33 | * Uses the Cornish-Fisher Expansion to include a skewness 34 | * correction to a normal approximation. This gives an 35 | * initial value which never seems to be off by more than 36 | * 1 or 2. A search is then conducted of values close to 37 | * this initial start point. 38 | */ 39 | 40 | #include "nmath.h" 41 | #include "dpq.h" 42 | 43 | #ifdef DEBUG_qnbinom 44 | # define R_DBG_printf(...) REprintf(__VA_ARGS__) 45 | #else 46 | # define R_DBG_printf(...) 47 | #endif 48 | 49 | #define _thisDIST_ nbinom_mu 50 | #define _dist_PARS_DECL_ double size, double mu 51 | #define _dist_PARS_ size, mu 52 | 53 | #include "qDiscrete_search.h" 54 | // ------------------> do_search() and all called by q_DISCRETE_*() below 55 | 56 | double qnbinom_mu(double p, double size, double mu, int lower_tail, int log_p) 57 | { 58 | if (size == ML_POSINF) // limit case: Poisson 59 | return(qpois(p, mu, lower_tail, log_p)); 60 | 61 | #ifdef IEEE_754 62 | if (ISNAN(p) || ISNAN(size) || ISNAN(mu)) 63 | return p + size + mu; 64 | #endif 65 | 66 | if (mu == 0 || size == 0) return 0; 67 | if (mu < 0 || size < 0) ML_WARN_return_NAN; 68 | 69 | R_Q_P01_boundaries(p, 0, ML_POSINF); 70 | 71 | double 72 | Q = 1 + mu/size, // (size+mu)/size = 1 / prob 73 | P = mu/size, // = (1 - prob) * Q = (1 - prob) / prob = Q - 1 74 | sigma = sqrt(size * P * Q), 75 | gamma = (Q + P)/sigma; 76 | 77 | R_DBG_printf("qnbinom_mu(p=%.12g, size=%.15g, mu=%g, l.t.=%d, log=%d):" 78 | " mu=%g, sigma=%g, gamma=%g;\n", 79 | p, size, mu, lower_tail, log_p, mu, sigma, gamma); 80 | 81 | q_DISCRETE_01_CHECKS(); 82 | q_DISCRETE_BODY(); 83 | } 84 | -------------------------------------------------------------------------------- /src/qnchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2000--2020 The R Core Team 4 | * Copyright (C) 2004 The R Foundation 5 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | */ 21 | 22 | #include "nmath.h" 23 | #include "dpq.h" 24 | 25 | double qnchisq(double p, double df, double ncp, int lower_tail, int log_p) 26 | { 27 | const static double accu = 1e-13; 28 | const static double racc = 4*DBL_EPSILON; 29 | /* these two are for the "search" loops, can have less accuracy: */ 30 | const static double Eps = 1e-11; /* must be > accu */ 31 | const static double rEps= 1e-10; /* relative tolerance ... */ 32 | 33 | double ux, lx, ux0, nx, pp; 34 | 35 | #ifdef IEEE_754 36 | if (ISNAN(p) || ISNAN(df) || ISNAN(ncp)) 37 | return p + df + ncp; 38 | #endif 39 | if (!R_FINITE(df)) ML_WARN_return_NAN; 40 | 41 | /* Was 42 | * df = floor(df + 0.5); 43 | * if (df < 1 || ncp < 0) ML_WARN_return_NAN; 44 | */ 45 | if (df < 0 || ncp < 0) ML_WARN_return_NAN; 46 | 47 | R_Q_P01_boundaries(p, 0, ML_POSINF); 48 | 49 | pp = R_D_qIv(p); // exp(p) iff log_p 50 | if(pp > 1 - DBL_EPSILON) 51 | return lower_tail ? ML_POSINF : 0.0; // early under/over flow iff log_p (FIXME) 52 | 53 | /* Invert pnchisq(.) : 54 | * 1. finding an upper and lower bound */ 55 | { 56 | /* This is Pearson's (1959) approximation, 57 | which is usually good to 4 figs or so. */ 58 | double b, c, ff; 59 | b = (ncp*ncp)/(df + 3*ncp); 60 | c = (df + 3*ncp)/(df + 2*ncp); 61 | ff = (df + 2 * ncp)/(c*c); 62 | ux = b + c * qchisq(p, ff, lower_tail, log_p); 63 | if(ux <= 0.) ux = 1; 64 | ux0 = ux; 65 | } 66 | 67 | if(!lower_tail && ncp >= 80) { 68 | /* in this case, pnchisq() works via lower_tail = TRUE */ 69 | if(pp < 1e-10) ML_WARNING(ME_PRECISION, "qnchisq"); 70 | p = /* R_DT_qIv(p)*/ log_p ? -expm1(p) : (0.5 - (p) + 0.5); 71 | lower_tail = TRUE; 72 | } else { 73 | p = pp; 74 | } 75 | 76 | pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps)); 77 | if(lower_tail) { 78 | for(; ux < DBL_MAX && 79 | pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, TRUE, FALSE) < pp; 80 | ux *= 2); 81 | pp = p * (1 - Eps); 82 | for(lx = fmin2(ux0, DBL_MAX); 83 | lx > DBL_MIN && 84 | pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, TRUE, FALSE) > pp; 85 | lx *= 0.5); 86 | } 87 | else { 88 | for(; ux < DBL_MAX && 89 | pnchisq_raw(ux, df, ncp, Eps, rEps, 10000, FALSE, FALSE) > pp; 90 | ux *= 2); 91 | pp = p * (1 - Eps); 92 | for(lx = fmin2(ux0, DBL_MAX); 93 | lx > DBL_MIN && 94 | pnchisq_raw(lx, df, ncp, Eps, rEps, 10000, FALSE, FALSE) < pp; 95 | lx *= 0.5); 96 | } 97 | 98 | /* 2. interval (lx,ux) halving : */ 99 | if(lower_tail) { 100 | do { 101 | nx = 0.5 * (lx + ux); 102 | if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, TRUE, FALSE) > p) 103 | ux = nx; 104 | else 105 | lx = nx; 106 | } 107 | while ((ux - lx) / nx > accu); 108 | } else { 109 | do { 110 | nx = 0.5 * (lx + ux); 111 | if (pnchisq_raw(nx, df, ncp, accu, racc, 100000, FALSE, FALSE) < p) 112 | ux = nx; 113 | else 114 | lx = nx; 115 | } 116 | while ((ux - lx) / nx > accu); 117 | } 118 | return 0.5 * (ux + lx); 119 | } 120 | -------------------------------------------------------------------------------- /src/qnf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2006-8 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #include "nmath.h" 21 | #include "dpq.h" 22 | 23 | double qnf(double p, double df1, double df2, double ncp, int lower_tail, 24 | int log_p) 25 | { 26 | double y; 27 | 28 | #ifdef IEEE_754 29 | if (ISNAN(p) || ISNAN(df1) || ISNAN(df2) || ISNAN(ncp)) 30 | return p + df1 + df2 + ncp; 31 | #endif 32 | if (df1 <= 0. || df2 <= 0. || ncp < 0) ML_WARN_return_NAN; 33 | if (!R_FINITE(ncp)) ML_WARN_return_NAN; 34 | if (!R_FINITE(df1) && !R_FINITE(df2)) ML_WARN_return_NAN; 35 | R_Q_P01_boundaries(p, 0, ML_POSINF); 36 | 37 | if (df2 > 1e8) /* avoid problems with +Inf and loss of accuracy */ 38 | return qnchisq(p, df1, ncp, lower_tail, log_p)/df1; 39 | 40 | y = qnbeta(p, df1 / 2., df2 / 2., ncp, lower_tail, log_p); 41 | return y/(1-y) * (df2/df1); 42 | } 43 | -------------------------------------------------------------------------------- /src/qnt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 2006-2015 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | */ 19 | 20 | #include "nmath.h" 21 | #include "dpq.h" 22 | 23 | double qnt(double p, double df, double ncp, int lower_tail, int log_p) 24 | { 25 | const static double accu = 1e-13; 26 | const static double Eps = 1e-11; /* must be > accu */ 27 | 28 | double ux, lx, nx, pp; 29 | 30 | #ifdef IEEE_754 31 | if (ISNAN(p) || ISNAN(df) || ISNAN(ncp)) 32 | return p + df + ncp; 33 | #endif 34 | /* Was 35 | * df = floor(df + 0.5); 36 | * if (df < 1 || ncp < 0) ML_WARN_return_NAN; 37 | */ 38 | if (df <= 0.0) ML_WARN_return_NAN; 39 | 40 | if(ncp == 0.0 && df >= 1.0) return qt(p, df, lower_tail, log_p); 41 | 42 | R_Q_P01_boundaries(p, ML_NEGINF, ML_POSINF); 43 | 44 | if (!R_FINITE(df)) // df = Inf ==> limit N(ncp,1) 45 | return qnorm(p, ncp, 1., lower_tail, log_p); 46 | 47 | p = R_DT_qIv(p); 48 | 49 | /* Invert pnt(.) : 50 | * 1. finding an upper and lower bound */ 51 | if(p > 1 - DBL_EPSILON) return ML_POSINF; 52 | pp = fmin2(1 - DBL_EPSILON, p * (1 + Eps)); 53 | for(ux = fmax2(1., ncp); 54 | ux < DBL_MAX && pnt(ux, df, ncp, TRUE, FALSE) < pp; 55 | ux *= 2); 56 | pp = p * (1 - Eps); 57 | for(lx = fmin2(-1., -ncp); 58 | lx > -DBL_MAX && pnt(lx, df, ncp, TRUE, FALSE) > pp; 59 | lx *= 2); 60 | 61 | /* 2. interval (lx,ux) halving : */ 62 | do { 63 | nx = 0.5 * (lx + ux); // could be zero 64 | if (pnt(nx, df, ncp, TRUE, FALSE) > p) ux = nx; else lx = nx; 65 | } 66 | while ((ux - lx) > accu * fmax2(fabs(lx), fabs(ux))); 67 | 68 | return 0.5 * (lx + ux); 69 | } 70 | -------------------------------------------------------------------------------- /src/qpois.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1999-2021 The R Core Team 4 | * Copyright (C) 1998 Ross Ihaka 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The quantile function of the Poisson distribution. 23 | * 24 | * METHOD 25 | * 26 | * Uses the Cornish-Fisher Expansion to include a skewness 27 | * correction to a normal approximation. This gives an 28 | * initial value which never seems to be off by more than 29 | * 1 or 2. A search is then conducted of values close to 30 | * this initial start point. 31 | */ 32 | 33 | #include "nmath.h" 34 | #include "dpq.h" 35 | 36 | #ifdef DEBUG_qpois 37 | # define R_DBG_printf(...) REprintf(__VA_ARGS__) 38 | #else 39 | # define R_DBG_printf(...) 40 | #endif 41 | 42 | 43 | #define _thisDIST_ pois 44 | #define _dist_PARS_DECL_ double lambda 45 | #define _dist_PARS_ lambda 46 | 47 | #include "qDiscrete_search.h" 48 | // ------------------> do_search() and all called by q_DISCRETE_*() below 49 | 50 | double qpois(double p, double lambda, int lower_tail, int log_p) 51 | { 52 | #ifdef IEEE_754 53 | if (ISNAN(p) || ISNAN(lambda)) 54 | return p + lambda; 55 | #endif 56 | if(!R_FINITE(lambda)) 57 | ML_WARN_return_NAN; 58 | if(lambda < 0) ML_WARN_return_NAN; 59 | R_Q_P01_check(p); 60 | if(lambda == 0) return 0; 61 | if(p == R_DT_0) return 0; 62 | if(p == R_DT_1) return ML_POSINF; 63 | 64 | double 65 | mu = lambda, 66 | sigma = sqrt(lambda), 67 | // had gamma = sigma; PR#8058 should be skewness which is mu^-0.5 = 1/sigma 68 | gamma = 1.0/sigma; 69 | 70 | R_DBG_printf("qpois(p=%.12g, lambda=%.15g, l.t.=%d, log=%d):" 71 | " mu=%g, sigma=%g, gamma=%g;\n", 72 | p, lambda, lower_tail, log_p, mu, sigma, gamma); 73 | 74 | // never "needed" here (FIXME?): q_DISCRETE_01_CHECKS(); 75 | q_DISCRETE_BODY(); 76 | } 77 | -------------------------------------------------------------------------------- /src/qunif.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2006 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * The quantile function of the uniform distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | #include "dpq.h" 27 | 28 | double qunif(double p, double a, double b, int lower_tail, int log_p) 29 | { 30 | #ifdef IEEE_754 31 | if (ISNAN(p) || ISNAN(a) || ISNAN(b)) 32 | return p + a + b; 33 | #endif 34 | R_Q_P01_check(p); 35 | if (!R_FINITE(a) || !R_FINITE(b)) ML_WARN_return_NAN; 36 | if (b < a) ML_WARN_return_NAN; 37 | if (b == a) return a; 38 | 39 | return a + R_DT_qIv(p) * (b - a); 40 | } 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /src/qweibull.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * Copyright (C) 2005 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | * 21 | * DESCRIPTION 22 | * 23 | * The quantile function of the Weibull distribution. 24 | */ 25 | 26 | #include "nmath.h" 27 | #include "dpq.h" 28 | 29 | double qweibull(double p, double shape, double scale, int lower_tail, int log_p) 30 | { 31 | #ifdef IEEE_754 32 | if (ISNAN(p) || ISNAN(shape) || ISNAN(scale)) 33 | return p + shape + scale; 34 | #endif 35 | if (shape <= 0 || scale <= 0) ML_WARN_return_NAN; 36 | 37 | R_Q_P01_boundaries(p, 0, ML_POSINF); 38 | 39 | return scale * pow(- R_DT_Clog(p), 1./shape) ; 40 | } 41 | -------------------------------------------------------------------------------- /src/rbeta.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 2000--2016 The R Core Team 5 | * Copyright (C) 2001--2016 The R Foundation 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, a copy is available at 19 | * https://www.R-project.org/Licenses/ 20 | */ 21 | 22 | /* Reference: 23 | * R. C. H. Cheng (1978). 24 | * Generating beta variates with nonintegral shape parameters. 25 | * Communications of the ACM 21, 317-322. 26 | * (Algorithms BB and BC) 27 | */ 28 | 29 | #include "nmath.h" 30 | 31 | #define expmax (DBL_MAX_EXP * M_LN2)/* = log(DBL_MAX) */ 32 | 33 | double rbeta(double aa, double bb) 34 | { 35 | if (ISNAN(aa) || ISNAN(bb) || aa < 0. || bb < 0.) 36 | ML_WARN_return_NAN; 37 | if (!R_FINITE(aa) && !R_FINITE(bb)) // a = b = Inf : all mass at 1/2 38 | return 0.5; 39 | if (aa == 0. && bb == 0.) // point mass 1/2 at each of {0,1} : 40 | return (unif_rand() < 0.5) ? 0. : 1.; 41 | // now, at least one of a, b is finite and positive 42 | if (!R_FINITE(aa) || bb == 0.) 43 | return 1.0; 44 | if (!R_FINITE(bb) || aa == 0.) 45 | return 0.0; 46 | 47 | double a, b, alpha; 48 | double r, s, t, u1, u2, v, w, y, z; 49 | int qsame; 50 | /* FIXME: Keep Globals (properly) for threading */ 51 | /* Uses these GLOBALS to save time when many rv's are generated : */ 52 | _Thread_local static double beta, gamma, delta, k1, k2; 53 | _Thread_local static double olda = -1.0; 54 | _Thread_local static double oldb = -1.0; 55 | 56 | /* Test if we need new "initializing" */ 57 | qsame = (olda == aa) && (oldb == bb); 58 | if (!qsame) { olda = aa; oldb = bb; } 59 | 60 | a = fmin2(aa, bb); 61 | b = fmax2(aa, bb); /* a <= b */ 62 | alpha = a + b; 63 | 64 | #define v_w_from__u1_bet(AA) \ 65 | v = beta * log(u1 / (1.0 - u1)); \ 66 | if (v <= expmax) { \ 67 | w = AA * exp(v); \ 68 | if(!R_FINITE(w)) w = DBL_MAX; \ 69 | } else \ 70 | w = DBL_MAX 71 | 72 | 73 | if (a <= 1.0) { /* --- Algorithm BC --- */ 74 | 75 | /* changed notation, now also a <= b (was reversed) */ 76 | 77 | if (!qsame) { /* initialize */ 78 | beta = 1.0 / a; 79 | delta = 1.0 + b - a; 80 | k1 = delta * (0.0138889 + 0.0416667 * a) / (b * beta - 0.777778); 81 | k2 = 0.25 + (0.5 + 0.25 / delta) * a; 82 | } 83 | /* FIXME: "do { } while()", but not trivially because of "continue"s:*/ 84 | for(;;) { 85 | u1 = unif_rand(); 86 | u2 = unif_rand(); 87 | if (u1 < 0.5) { 88 | y = u1 * u2; 89 | z = u1 * y; 90 | if (0.25 * u2 + z - y >= k1) 91 | continue; 92 | } else { 93 | z = u1 * u1 * u2; 94 | if (z <= 0.25) { 95 | v_w_from__u1_bet(b); 96 | break; 97 | } 98 | if (z >= k2) 99 | continue; 100 | } 101 | 102 | v_w_from__u1_bet(b); 103 | 104 | if (alpha * (log(alpha / (a + w)) + v) - 1.3862944 >= log(z)) 105 | break; 106 | } 107 | return (aa == a) ? a / (a + w) : w / (a + w); 108 | 109 | } 110 | else { /* Algorithm BB */ 111 | 112 | if (!qsame) { /* initialize */ 113 | beta = sqrt((alpha - 2.0) / (2.0 * a * b - alpha)); 114 | gamma = a + 1.0 / beta; 115 | } 116 | do { 117 | u1 = unif_rand(); 118 | u2 = unif_rand(); 119 | 120 | v_w_from__u1_bet(a); 121 | 122 | z = u1 * u1 * u2; 123 | r = gamma * v - 1.3862944; 124 | s = a + r - w; 125 | if (s + 2.609438 >= 5.0 * z) 126 | break; 127 | t = log(z); 128 | if (s > t) 129 | break; 130 | } 131 | while (r + alpha * log(alpha / (b + w)) < t); 132 | 133 | return (aa != a) ? b / (b + w) : w / (b + w); 134 | } 135 | } 136 | -------------------------------------------------------------------------------- /src/rcauchy.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000--2008 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rcauchy(double location, double scale); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the Cauchy distribution. 28 | */ 29 | 30 | #include "nmath.h" 31 | 32 | double rcauchy(double location, double scale) 33 | { 34 | if (ISNAN(location) || !R_FINITE(scale) || scale < 0) 35 | ML_WARN_return_NAN; 36 | if (scale == 0. || !R_FINITE(location)) 37 | return location; 38 | else 39 | return location + scale * tan(M_PI * unif_rand()); 40 | } 41 | -------------------------------------------------------------------------------- /src/rchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rchisq(double df); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the chi-squared distribution. 28 | * 29 | * NOTES 30 | * 31 | * Calls rgamma to do the real work. 32 | */ 33 | 34 | #include "nmath.h" 35 | 36 | double rchisq(double df) 37 | { 38 | if (!R_FINITE(df) || df < 0.0) ML_WARN_return_NAN; 39 | 40 | return rgamma(df / 2.0, 2.0); 41 | } 42 | -------------------------------------------------------------------------------- /src/rexp.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000--2008 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rexp(double scale) 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the exponential distribution. 28 | * 29 | */ 30 | 31 | #include "nmath.h" 32 | 33 | double rexp(double scale) 34 | { 35 | if (!R_FINITE(scale) || scale <= 0.0) { 36 | if(scale == 0.) return 0.; 37 | /* else */ 38 | ML_WARN_return_NAN; 39 | } 40 | return scale * exp_rand(); // --> in ./sexp.c 41 | } 42 | -------------------------------------------------------------------------------- /src/rf.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include "mathlib.h" 23 | * double rf(double dfn, double dfd); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Pseudo-random variates from an F distribution. 28 | * 29 | * NOTES 30 | * 31 | * This function calls rchisq to do the real work 32 | */ 33 | 34 | #include "nmath.h" 35 | 36 | double rf(double n1, double n2) 37 | { 38 | double v1, v2; 39 | if (ISNAN(n1) || ISNAN(n2) || n1 <= 0. || n2 <= 0.) 40 | ML_WARN_return_NAN; 41 | 42 | v1 = R_FINITE(n1) ? (rchisq(n1) / n1) : 1; 43 | v2 = R_FINITE(n2) ? (rchisq(n2) / n2) : 1; 44 | return v1 / v2; 45 | } 46 | -------------------------------------------------------------------------------- /src/rgeom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka and the R Core Team. 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rgeom(double p); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the geometric distribution. 28 | * 29 | * NOTES 30 | * 31 | * We generate lambda as exponential with scale parameter 32 | * p / (1 - p). Return a Poisson deviate with mean lambda. 33 | * See Example 1.5 in Devroye (1986), Chapter 10, pages 488f. 34 | * 35 | * REFERENCE 36 | * 37 | * Devroye, L. (1986). 38 | * Non-Uniform Random Variate Generation. 39 | * New York: Springer-Verlag. 40 | * Pages 488f. 41 | */ 42 | 43 | #include "nmath.h" 44 | 45 | double rgeom(double p) 46 | { 47 | if (!R_FINITE(p) || p <= 0 || p > 1) ML_WARN_return_NAN; 48 | 49 | return rpois(exp_rand() * ((1 - p) / p)); 50 | } 51 | -------------------------------------------------------------------------------- /src/rlnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000--2001 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rlnorm(double logmean, double logsd); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the lognormal distribution. 28 | */ 29 | 30 | #include "nmath.h" 31 | 32 | double rlnorm(double meanlog, double sdlog) 33 | { 34 | if(ISNAN(meanlog) || !R_FINITE(sdlog) || sdlog < 0.) 35 | ML_WARN_return_NAN; 36 | 37 | return exp(rnorm(meanlog, sdlog)); 38 | } 39 | -------------------------------------------------------------------------------- /src/rlogis.c: -------------------------------------------------------------------------------- 1 | /* 2 | * R : A Computer Language for Statistical Data Analysis 3 | * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka 4 | * Copyright (C) 2000--2008 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | */ 20 | 21 | #include "nmath.h" 22 | 23 | double rlogis(double location, double scale) 24 | { 25 | if (ISNAN(location) || !R_FINITE(scale)) 26 | ML_WARN_return_NAN; 27 | 28 | if (scale == 0. || !R_FINITE(location)) 29 | return location; 30 | else { 31 | double u = unif_rand(); 32 | return location + scale * log(u / (1. - u)); 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /src/rmultinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2003-2007 The R Foundation 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2, or (at your option) 8 | * any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * void rmultinom(int n, double* prob, int K, int* rN); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random Vector from the multinomial distribution. 28 | * ~~~~~~ 29 | * NOTE 30 | * Because we generate random _vectors_ this doesn't fit easily 31 | * into the do_random[1-4](.) framework setup in ../main/random.c 32 | * as that is used only for the univariate random generators. 33 | * Multivariate distributions typically have too complex parameter spaces 34 | * to be treated uniformly. 35 | * => Hence also can have int arguments. 36 | */ 37 | 38 | #include "nmath.h" 39 | #include 40 | 41 | #ifdef MATHLIB_STANDALONE 42 | #define ML_WARN_ret_NAN(_k_) {ML_WARNING(ME_DOMAIN, "rmultinom"); rN[_k_]=-1; return;} 43 | #else 44 | #define ML_WARN_ret_NAN(_k_) {ML_WARNING(ME_DOMAIN, "rmultinom"); rN[_k_]=NA_INTEGER; return;} 45 | #endif 46 | 47 | void rmultinom(int n, double* prob, int K, int* rN) 48 | /* `Return' vector rN[1:K] {K := length(prob)} 49 | * where rN[j] ~ Bin(n, prob[j]) , sum_j rN[j] == n, sum_j prob[j] == 1, 50 | */ 51 | { 52 | int k; 53 | double pp; 54 | LDOUBLE p_tot = 0.; 55 | /* This calculation is sensitive to exact values, so we try to 56 | ensure that the calculations are as accurate as possible 57 | so different platforms are more likely to give the same 58 | result. */ 59 | 60 | #ifdef MATHLIB_STANDALONE 61 | if (K < 1) { ML_WARNING(ME_DOMAIN, "rmultinom"); return;} 62 | if (n < 0) ML_WARN_ret_NAN(0); 63 | #else 64 | if (K == NA_INTEGER || K < 1) { ML_WARNING(ME_DOMAIN, "rmultinom"); return;} 65 | if (n == NA_INTEGER || n < 0) ML_WARN_ret_NAN(0); 66 | #endif 67 | 68 | /* Note: prob[K] is only used here for checking sum_k prob[k] = 1 ; 69 | * Could make loop one shorter and drop that check ! 70 | */ 71 | for(k = 0; k < K; k++) { 72 | pp = prob[k]; 73 | if (!R_FINITE(pp) || pp < 0. || pp > 1.) ML_WARN_ret_NAN(k); 74 | p_tot += pp; 75 | rN[k] = 0; 76 | } 77 | if(fabs((double)(p_tot - 1.)) > 1e-7) 78 | MATHLIB_ERROR(_("rbinom: probability sum should be 1, but is %g"), 79 | (double) p_tot); 80 | if (n == 0) return; 81 | if (K == 1 && p_tot == 0.) return;/* trivial border case: do as rbinom */ 82 | 83 | /* Generate the first K-1 obs. via binomials */ 84 | 85 | for(k = 0; k < K-1; k++) { /* (p_tot, n) are for "remaining binomial" */ 86 | if(prob[k] != 0.) { 87 | pp = (double)(prob[k] / p_tot); 88 | /* printf("[%d] %.17f\n", k+1, pp); */ 89 | rN[k] = ((pp < 1.) ? (int) rbinom((double) n, pp) : 90 | /*>= 1; > 1 happens because of rounding */ 91 | n); 92 | n -= rN[k]; 93 | } 94 | else rN[k] = 0; 95 | if(n <= 0) /* we have all*/ return; 96 | p_tot -= prob[k]; /* i.e. = sum(prob[(k+1):K]) */ 97 | } 98 | rN[K-1] = n; 99 | return; 100 | } 101 | #undef ML_WARN_ret_NAN 102 | -------------------------------------------------------------------------------- /src/rnbinom.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000--2016 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include 23 | * double rnbinom(double n, double p) 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the negative binomial distribution. 28 | * 29 | * NOTES 30 | * 31 | * x = the number of failures before the n-th success 32 | * 33 | * REFERENCE 34 | * 35 | * Devroye, L. (1986). 36 | * Non-Uniform Random Variate Generation. 37 | * New York:Springer-Verlag. Pages 488 and 543. 38 | * 39 | * METHOD 40 | * 41 | * Generate lambda as gamma with shape parameter n and scale 42 | * parameter p/(1-p). Return a Poisson deviate with mean lambda. 43 | */ 44 | 45 | #include "nmath.h" 46 | 47 | double rnbinom(double size, double prob) 48 | { 49 | if(!R_FINITE(prob) || ISNAN(size) || size <= 0 || prob <= 0 || prob > 1) 50 | /* prob = 1 is ok, PR#1218 */ 51 | ML_WARN_return_NAN; 52 | if(!R_FINITE(size)) size = DBL_MAX / 2.; // '/2' to prevent rgamma() returning Inf 53 | return (prob == 1) ? 0 : rpois(rgamma(size, (1 - prob) / prob)); 54 | } 55 | 56 | double rnbinom_mu(double size, double mu) 57 | { 58 | if(!R_FINITE(mu) || ISNAN(size) || size <= 0 || mu < 0) 59 | ML_WARN_return_NAN; 60 | if(!R_FINITE(size)) size = DBL_MAX / 2.; 61 | return (mu == 0) ? 0 : rpois(rgamma(size, mu / size)); 62 | } 63 | -------------------------------------------------------------------------------- /src/rnchisq.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2003--2016 The R Foundation 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * double rnchisq(double df, double lambda); 23 | * 24 | * DESCRIPTION 25 | * 26 | * Random variates from the NON CENTRAL chi-squared distribution. 27 | * 28 | * NOTES 29 | * 30 | According to Hans R. Kuensch's suggestion (30 sep 2002): 31 | 32 | It should be easy to do the general case (ncp > 0) by decomposing it 33 | as the sum of a central chisquare with df degrees of freedom plus a 34 | noncentral chisquare with zero degrees of freedom (which is a Poisson 35 | mixture of central chisquares with integer degrees of freedom), 36 | see Formula (29.5b-c) in Johnson, Kotz, Balakrishnan (1995). 37 | 38 | The noncentral chisquare with arbitrary degrees of freedom is of interest 39 | for simulating the Cox-Ingersoll-Ross model for interest rates in 40 | finance. 41 | 42 | R code that works is 43 | 44 | rchisq0 <- function(n, ncp) { 45 | p <- 0 < (K <- rpois(n, lambda = ncp / 2)) 46 | r <- numeric(n) 47 | r[p] <- rchisq(sum(p), df = 2*K[p]) 48 | r 49 | } 50 | 51 | rchisq <- function(n, df, ncp=0) { 52 | if(missing(ncp)) .Internal(rchisq(n, df)) 53 | else rchisq0(n, ncp) + .Internal(rchisq(n, df)) 54 | } 55 | */ 56 | 57 | #include "nmath.h" 58 | 59 | double rnchisq(double df, double lambda) 60 | { 61 | if (ISNAN(df) || !R_FINITE(lambda) || df < 0. || lambda < 0.) 62 | ML_WARN_return_NAN; 63 | 64 | if(lambda == 0.) { 65 | return (df == 0.) ? 0. : rgamma(df / 2., 2.); 66 | } 67 | else { 68 | double r = rpois( lambda / 2.); 69 | if (r > 0.) r = rchisq(2. * r); 70 | if (df > 0.) r += rgamma(df / 2., 2.); 71 | return r; 72 | } 73 | } 74 | -------------------------------------------------------------------------------- /src/rnorm.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * SYNOPSIS 21 | * 22 | * #include "Rnorm.h" 23 | * double rnorm(double mu, double sigma); 24 | * 25 | * DESCRIPTION 26 | * 27 | * Random variates from the normal distribution. 28 | * 29 | */ 30 | 31 | #include "nmath.h" 32 | 33 | double rnorm(double mu, double sigma) 34 | { 35 | if (ISNAN(mu) || !R_FINITE(sigma) || sigma < 0.) 36 | ML_WARN_return_NAN; 37 | if (sigma == 0. || !R_FINITE(mu)) 38 | return mu; /* includes mu = +/- Inf with finite sigma */ 39 | else 40 | return mu + sigma * norm_rand(); 41 | } 42 | -------------------------------------------------------------------------------- /src/rt.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000-2008 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * Pseudo-random variates from a t distribution. 23 | * 24 | * NOTES 25 | * 26 | * This function calls rchisq and rnorm to do the real work. 27 | */ 28 | 29 | #include "nmath.h" 30 | 31 | double rt(double df) 32 | { 33 | if (ISNAN(df) || df <= 0.0) ML_WARN_return_NAN; 34 | 35 | if(!R_FINITE(df)) 36 | return norm_rand(); 37 | else { 38 | /* Some compilers (including MW6) evaluated this from right to left 39 | return norm_rand() / sqrt(rchisq(df) / df); */ 40 | double num = norm_rand(); 41 | return num / sqrt(rchisq(df) / df); 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /src/runif.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * Random variates from the uniform distribution. 23 | */ 24 | #include "nmath.h" 25 | 26 | double runif(double a, double b) 27 | { 28 | if (!R_FINITE(a) || !R_FINITE(b) || b < a) ML_WARN_return_NAN; 29 | 30 | if (a == b) 31 | return a; 32 | else { 33 | double u; 34 | /* This is true of all builtin generators, but protect against 35 | user-supplied ones */ 36 | do {u = unif_rand();} while (u <= 0 || u >= 1); 37 | return a + (b - a) * u; 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /src/rweibull.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * Copyright (C) 2000 The R Core Team 5 | * 6 | * This program is free software; you can redistribute it and/or modify 7 | * it under the terms of the GNU General Public License as published by 8 | * the Free Software Foundation; either version 2 of the License, or 9 | * (at your option) any later version. 10 | * 11 | * This program is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | * GNU General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU General Public License 17 | * along with this program; if not, a copy is available at 18 | * https://www.R-project.org/Licenses/ 19 | * 20 | * DESCRIPTION 21 | * 22 | * Random variates from the Weibull distribution. 23 | */ 24 | 25 | #include "nmath.h" 26 | 27 | double rweibull(double shape, double scale) 28 | { 29 | if (!R_FINITE(shape) || !R_FINITE(scale) || shape <= 0. || scale <= 0.) { 30 | if(scale == 0.) return 0.; 31 | /* else */ 32 | ML_WARN_return_NAN; 33 | } 34 | 35 | return scale * pow(-log(unif_rand()), 1.0 / shape); 36 | } 37 | -------------------------------------------------------------------------------- /src/sign.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 1998 Ross Ihaka 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | * SYNOPSIS 20 | * 21 | * #include 22 | * double sign(double x); 23 | * 24 | * DESCRIPTION 25 | * 26 | * This function computes the 'signum(.)' function: 27 | * 28 | * sign(x) = 1 if x > 0 29 | * sign(x) = 0 if x == 0 30 | * sign(x) = -1 if x < 0 31 | */ 32 | 33 | #include "nmath.h" 34 | 35 | double sign(double x) 36 | { 37 | if (ISNAN(x)) 38 | return x; 39 | return ((x > 0) ? 1 : ((x == 0)? 0 : -1)); 40 | } 41 | -------------------------------------------------------------------------------- /src/sunif.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Mathlib : A C Library of Special Functions 3 | * Copyright (C) 2000, 2003 The R Core Team 4 | * 5 | * This program is free software; you can redistribute it and/or modify 6 | * it under the terms of the GNU General Public License as published by 7 | * the Free Software Foundation; either version 2 of the License, or 8 | * (at your option) any later version. 9 | * 10 | * This program is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | * GNU General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU General Public License 16 | * along with this program; if not, a copy is available at 17 | * https://www.R-project.org/Licenses/ 18 | * 19 | */ 20 | 21 | /* A version of Marsaglia-MultiCarry */ 22 | 23 | _Thread_local static unsigned int I1=1234, I2=5678; 24 | 25 | void set_seed(unsigned int i1, unsigned int i2) 26 | { 27 | I1 = i1; I2 = i2; 28 | } 29 | 30 | void get_seed(unsigned int *i1, unsigned int *i2) 31 | { 32 | *i1 = I1; *i2 = I2; 33 | } 34 | 35 | 36 | double sunif_unif_rand(void) 37 | { 38 | I1= 36969*(I1 & 0177777) + (I1>>16); 39 | I2= 18000*(I2 & 0177777) + (I2>>16); 40 | return ((I1 << 16)^(I2 & 0177777)) * 2.328306437080797e-10; /* in [0,1) */ 41 | } 42 | 43 | #include 44 | #include 45 | //copied from src/main/RNG.c: 46 | //generate a random non-negative integer < 2 ^ bits in 16 bit chunks 47 | static double rbits(int bits) 48 | { 49 | int_least64_t v = 0; 50 | for (int n = 0; n <= bits; n += 16) { 51 | int v1 = (int) floor(sunif_unif_rand() * 65536); 52 | v = 65536 * v + v1; 53 | } 54 | // mask out the bits in the result that are not needed 55 | return (double) (v & ((1L << bits) - 1)); 56 | } 57 | 58 | double R_unif_index(double dn) 59 | { 60 | // rejection sampling from integers below the next larger power of two 61 | if (dn <= 0) 62 | return 0.0; 63 | int bits = (int) ceil(log2(dn)); 64 | double dv; 65 | do { dv = rbits(bits); } while (dn <= dv); 66 | return dv; 67 | } 68 | -------------------------------------------------------------------------------- /test.jl: -------------------------------------------------------------------------------- 1 | using Test, Libdl, Random 2 | const libRmath = "src/libRmath-julia.$(Libdl.dlext)" 3 | 4 | unsafe_store!(cglobal((:unif_rand_ptr, libRmath), Ptr{Cvoid}), 5 | @cfunction(rand, Float64, ())) 6 | unsafe_store!(cglobal((:norm_rand_ptr, libRmath), Ptr{Cvoid}), 7 | @cfunction(randn, Float64, ())) 8 | unsafe_store!(cglobal((:exp_rand_ptr, libRmath), Ptr{Cvoid}), 9 | @cfunction(randexp, Float64, ())) 10 | 11 | @testset "ccall" begin 12 | @test ccall((:dbeta, libRmath), Float64, (Float64, Float64, Float64, Int32), 0.5, 0.1, 5.0, 0) ≈ 0.014267678091051986 13 | @test 0 <= ccall((:rbeta, libRmath), Float64, (Float64, Float64), 0.1, 5.0) <= 1.0 14 | end 15 | 16 | @testset "rhyper" begin 17 | # double rhyper(double nn1in, double nn2in, double kkin) 18 | Nred = 30.0 19 | Nblue = 40.0 20 | Npulled = 5.0 21 | 22 | hyper_samples = [ 23 | ccall((:rhyper, libRmath), Float64, (Float64, Float64, Float64), Nred, Nblue, Npulled) 24 | for _ in 1:1_000_000 25 | ] 26 | expected_mean = Npulled * Nred / (Nred + Nblue) 27 | sample_mean = sum(hyper_samples) / length(hyper_samples) 28 | @test sample_mean ≈ expected_mean rtol = 0.01 29 | 30 | N = (Nred + Nblue) 31 | expected_variance = Npulled * Nred * (N - Nred) * (N - Npulled) / (N * N * (N - 1)) 32 | sample_variance = 1 / (length(hyper_samples)) * sum((hyper_samples .- sample_mean) .^ 2) 33 | @test sample_variance ≈ expected_variance rtol = 0.01 34 | end 35 | 36 | function sample_KkC(n; N, Q) 37 | K = rand([1,2,3,4,5]) 38 | k = ccall( 39 | (:rhyper, libRmath), Float64, (Float64, Float64, Float64), 40 | K, N-K, n 41 | ) 42 | return k 43 | end 44 | 45 | @testset "fulll" begin 46 | function f(Q) 47 | objective(n) = [sample_KkC(n; N = 819_200, Q) for _ = 1:100] 48 | vals = [10, 100] 49 | objective.(vals) 50 | end 51 | 52 | Qs = [0.05, 0.055, 0.1, 0.2, 0.3] 53 | 54 | Threads.@threads for i in eachindex(Qs) 55 | f(Qs[i]) 56 | end 57 | end 58 | --------------------------------------------------------------------------------