R Under development (unstable) (2024-08-21 r87038 ucrt) -- "Unsuffered Consequences" Copyright (C) 2024 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > #### NON-central [dpq]chisq() > #### =========== ======= (Since *central [dpq]Chisq <===> [dpq]gamma) > > library(DPQ) > ### originally was ~/R/MM/NUMERICS/dpq-functions/chisq-nonc-ex.R > ### - - - - - - - - - - - - - - - - - - - - - - - > ### with _long_ history since R 0.63.x in 1999 ! > > ###__FIXME__ Already have 3 different ./wienergerm*.R files > ### ===== Do remove things we have twice !!! > > stopifnot(exprs = { + require(graphics) + require(sfsmisc) # eaxis(), lseq(), p.m(), mult.fig(), sessionInfoX() + }) Loading required package: sfsmisc > > source(system.file(package="DPQ", "test-tools.R", + mustWork=TRUE))# ../inst/test-tools.R > ## => showProc.time(), ... list_() , loadList() , readRDS_() , save2RDS() > > unlist(.Platform) OS.type file.sep dynlib.ext GUI endian pkgType "windows" "/" ".dll" "RTerm" "little" "win.binary" path.sep r_arch ";" "x64" > ## For package-testing "diagnostics": > sessionInfoX(c("DPQ","Rmpfr")) Extended sessionInfo(): ----------------------- specific packageDescription()s: $DPQ Package: DPQ Title: Density, Probability, Quantile ('DPQ') Computations Version: 0.5-9 Date: 2024-08-23 VersionNote: Last CRAN: 0.5-8 on 2023-11-30; 0.5-7 on 2023-11-03 Authors@R: c(person("Martin","Maechler", role=c("aut","cre"), email="maechler@stat.math.ethz.ch", comment = c(ORCID = "0000-0002-8685-9910")) , person("Morten", "Welinder", role = "ctb", comment = "pgamma C code, see PR#7307, Jan. 2005; further pdhyper()") , person("Wolfgang", "Viechtbauer", role = "ctb", comment = "dtWV(), 2002") , person("Ross", "Ihaka", role = "ctb", comment = "src/qchisq_appr.c") , person("Marius", "Hofert", role = "ctb", comment = "lsum(), lssum()") , person("R-core", email = "R-core@R-project.org", role = "ctb", comment = "src/{dpq.h, algdiv.c, pnchisq.c, bd0.c}") , person("R Foundation", role = "cph", comment = "src/qchisq-appr.c") ) Description: Computations for approximations and alternatives for the 'DPQ' (Density (pdf), Probability (cdf) and Quantile) functions for probability distributions in R. Primary focus is on (central and non-central) beta, gamma and related distributions such as the chi-squared, F, and t. -- For several distribution functions, provide functions implementing formulas from Johnson, Kotz, and Kemp (1992) and Johnson, Kotz, and Balakrishnan (1995) for discrete or continuous distributions respectively. This is for the use of researchers in these numerical approximation implementations, notably for my own use in order to improve standard R pbeta(), qgamma(), ..., etc: {'"dpq"'-functions}. Depends: R (>= 4.0.0) Imports: stats, graphics, methods, utils, sfsmisc (>= 1.1-14) Suggests: Rmpfr, DPQmpfr (>= 0.3-1), gmp, MASS, mgcv, scatterplot3d, interp, cobs SuggestsNote: MASS::fractions() in ex | mgcv, scatt.., .., cobs: some tests/ License: GPL (>= 2) Encoding: UTF-8 URL: https://specfun.r-forge.r-project.org/, https://r-forge.r-project.org/R/?group_id=611, https://r-forge.r-project.org/scm/viewvc.php/pkg/DPQ/?root=specfun, svn://svn.r-forge.r-project.org/svnroot/specfun/pkg/DPQ BugReports: https://r-forge.r-project.org/tracker/?atid=2462&group_id=611 NeedsCompilation: yes Packaged: 2024-08-23 14:42:07 UTC; maechler Author: Martin Maechler [aut, cre] (), Morten Welinder [ctb] (pgamma C code, see PR#7307, Jan. 2005; further pdhyper()), Wolfgang Viechtbauer [ctb] (dtWV(), 2002), Ross Ihaka [ctb] (src/qchisq_appr.c), Marius Hofert [ctb] (lsum(), lssum()), R-core [ctb] (src/{dpq.h, algdiv.c, pnchisq.c, bd0.c}), R Foundation [cph] (src/qchisq-appr.c) Maintainer: Martin Maechler Built: R 4.5.0; x86_64-w64-mingw32; 2024-08-23 15:05:07 UTC; windows Archs: x64 -- File: D:/RCompile/CRANincoming/R-devel/lib/DPQ/Meta/package.rds $Rmpfr Package: Rmpfr Title: R MPFR - Multiple Precision Floating-Point Reliable Version: 0.9-5 Date: 2024-01-20 DateNote: Previous CRAN version 0.9-4 on 2023-12-04 Type: Package Authors@R: c(person("Martin","Maechler", role = c("aut","cre"), email = "maechler@stat.math.ethz.ch", comment = c(ORCID="0000-0002-8685-9910")) , person(c("Richard", "M."), "Heiberger", role = "ctb", email="rmh@temple.edu", comment = "formatHex(), *Bin, *Dec") , person(c("John", "C."), "Nash", role = "ctb", email="nashjc@uottawa.ca", comment = "hjkMpfr(), origin of unirootR()") , person(c("Hans", "W."), "Borchers", role = "ctb", email="hwborchers@googlemail.com", comment = "optimizeR(*, \"GoldenRatio\"); origin of hjkMpfr()") ) Description: Arithmetic (via S4 classes and methods) for arbitrary precision floating point numbers, including transcendental ("special") functions. To this end, the package interfaces to the 'LGPL' licensed 'MPFR' (Multiple Precision Floating-Point Reliable) Library which itself is based on the 'GMP' (GNU Multiple Precision) Library. SystemRequirements: gmp (>= 4.2.3), mpfr (>= 3.0.0), pdfcrop (part of TexLive) is required to rebuild the vignettes. SystemRequirementsNote: 'MPFR' (MP Floating-Point Reliable Library, https://www.mpfr.org/) and 'GMP' (GNU Multiple Precision library, https://gmplib.org/), see >> README.md Depends: gmp (>= 0.6-1), R (>= 3.6.0) Imports: stats, utils, methods Suggests: MASS, Bessel, polynom, sfsmisc (>= 1.1-14) SuggestsNote: MASS, polynom, sfsmisc: only for vignette; Enhances: dfoptim, pracma, DPQ EnhancesNote: mentioned in Rd xrefs | used in example URL: https://rmpfr.r-forge.r-project.org/ BugReports: https://r-forge.r-project.org/tracker/?group_id=386 License: GPL (>= 2) Encoding: UTF-8 NeedsCompilation: yes Packaged: 2024-01-20 16:10:31 UTC; maechler Author: Martin Maechler [aut, cre] (), Richard M. Heiberger [ctb] (formatHex(), *Bin, *Dec), John C. Nash [ctb] (hjkMpfr(), origin of unirootR()), Hans W. Borchers [ctb] (optimizeR(*, "GoldenRatio"); origin of hjkMpfr()) Maintainer: Martin Maechler Repository: CRAN Date/Publication: 2024-01-21 12:22:45 UTC Built: R 4.5.0; x86_64-w64-mingw32; 2024-08-23 01:24:26 UTC; windows Archs: x64 -- File: D:/temp/RtmpU7tZOw/RLIBS_273ac60b94c9a/Rmpfr/Meta/package.rds ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Capabilities: jpeg png tiff tcltk X11 aqua X X X X - - http/ftp sockets libxml fifo cledit iconv X X - X - X NLS Rprof profmem cairo ICU long.double X X X X X X libcurl X Sys.info: nodename CRANWIN3 user CRAN .Machine: List of 29 $ double.eps : num 2.22e-16 $ double.neg.eps : num 1.11e-16 $ double.xmin : num 2.23e-308 $ double.xmax : num 1.8e+308 $ double.base : int 2 $ double.digits : int 53 $ double.rounding : int 5 $ double.guard : int 0 $ double.ulp.digits : int -52 $ double.neg.ulp.digits : int -53 $ double.exponent : int 11 $ double.min.exp : int -1022 $ double.max.exp : int 1024 $ integer.max : int 2147483647 $ sizeof.long : int 4 $ sizeof.longlong : int 8 $ sizeof.longdouble : int 16 $ sizeof.pointer : int 8 $ sizeof.time_t : int 8 $ longdouble.eps : num 1.08e-19 $ longdouble.neg.eps : num 5.42e-20 $ longdouble.digits : int 64 $ longdouble.rounding : int 5 $ longdouble.guard : int 0 $ longdouble.ulp.digits : int -63 $ longdouble.neg.ulp.digits: int -64 $ longdouble.exponent : int 15 $ longdouble.min.exp : int -16382 $ longdouble.max.exp : int 16384 LAPACK version: 3.12.0 External software (versions): zlib 1.3.1 bzlib 1.0.8, 13-Jul-2019 xz 5.4.6 libdeflate 1.19 PCRE 10.43 2024-02-16 ICU 74.2 TRE TRE 0.8.0 R_fixes (BSD) iconv win_iconv readline BLAS Graphical software (versions): cairo 1.18.0 cairoFT pango libpng 1.6.42 jpeg 9.6 libtiff LIBTIFF, Version 4.6.0 PCRE (regex) config.: ("UTF-8" = TRUE, "Unicode properties" = TRUE, JIT = FALSE, stack = FALSE) R executable linked against libR.* ['is R shared']: TRUE R_LIBS: libPath [.libPaths()] contents in addition to R_LIBS and .Library: [1] "D:/temp/RtmpU7tZOw/RLIBS_273ac60b94c9a" [2] "D:/RCompile/recent/R/library" ** RLIBS has entries not in .libPaths(): [1] "d:\\RCompile\\CRANincoming\\R-devel\\DPQ.Rcheck\\tests\\D" [2] "D:\\temp\\RtmpU7tZOw\\RLIBS_273ac60b94c9a" Main R env. variables (for more, inspect the 'xR.env' component): [,1] R_ENVIRON "" R_PROFILE "" R_CHECK_ENVIRON "" ---------------- standard sessionInfo(): R Under development (unstable) (2024-08-21 r87038 ucrt) Platform: x86_64-w64-mingw32/x64 Running under: Windows Server 2022 x64 (build 20348) Matrix products: default locale: [1] LC_COLLATE=C LC_CTYPE=German_Germany.utf8 [3] LC_MONETARY=C LC_NUMERIC=C [5] LC_TIME=C time zone: Europe/Berlin tzcode source: internal attached base packages: [1] stats graphics grDevices utils datasets methods base other attached packages: [1] sfsmisc_1.1-19 DPQ_0.5-9 loaded via a namespace (and not attached): [1] compiler_4.5.0 tools_4.5.0 Warning message: In normalizePath(path.expand(path), winslash, mustWork) : path[1]="D": Das System kann die angegebene Datei nicht finden > > (noLdbl <- (.Machine$sizeof.longdouble <= 8)) ## TRUE when --disable-long-double [1] FALSE > > ## very large ncp gave "infinite" loop in R <= 3.6.1 : > ## ==> need new enough "3.6.1 patched" or R{-devel} > 3.6.x > (okR_Lrg <- (getRversion() > "3.6.1" || + getRversion() == "3.6.1" && R.version$`svn rev` >= 77145)) [1] TRUE > > (doExtras <- okR_Lrg && DPQ:::doExtras() && !grepl("valgrind", R.home())) [1] FALSE > > ## save directory (to read from): > (sdir <- system.file("safe", package="DPQ")) [1] "D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe" > > ## on "my" platform, and if doExtras, I'm very strict: > (myPlatf <- all(Sys.info()[c("sysname", "machine", "login")] == + c("Linux", "x86_64", "maechler"))) [1] FALSE > (beStrict <- doExtras && !noLdbl && myPlatf) [1] FALSE > (is32 <- .Machine$sizeof.pointer == 4) ## <- should work uniformly on Linux/MacOS/Windows [1] FALSE > > if(!dev.interactive(orNone=TRUE)) pdf("chisq-nonc-1.pdf") > .O.P. <- par(no.readonly=TRUE) > showProc.time() Time (user system elapsed): 0.17 0.01 0.18 > > ### Part 1 : Densities dchisq(*, ncp) > ### ---------------------------------- > > ### densities alone : > ## ===> shows Normal limit (for lambda -> Inf; true also for nu -> Inf) > nu <- 12 > nS <- length(ncSet <- if(doExtras) 10^(0:9) else 10^(0:6)) > np <- if(doExtras) 201 else 64 > cpUse <- numeric(nS); names(cpUse) <- formatC(ncSet) > mult.fig(nS, main = paste("non-central chisq(*, df=",nu, + ") and normal approx"))$old.par -> op > for(NC in ncSet) { + m <- NC + nu + s <- sqrt(2*(nu + 2*NC)) + x <- seq(from= m - 3*s, to= m + 3*s, length = np) + cpUse[formatC(NC)] <- system.time(y <- dchisq(x, df=nu, ncp=NC))[1] + plot(x, y, ylim=c(0,max(y)),type = "l", ylab='f(x)', main=paste("ncp =",NC)) + lines(x, dnorm(x,m=m,s=s), col = 'blue') + } > par(op)# resetting mult.fig() > showProc.time() Time (user system elapsed): 0.27 0 0.27 > > cbind(ncSet, cpUse, "c/ncp"= cpUse / ncSet) ncSet cpUse c/ncp 1 1e+00 0 0 10 1e+01 0 0 100 1e+02 0 0 1000 1e+03 0 0 1e+04 1e+04 0 0 1e+05 1e+05 0 0 1e+06 1e+06 0 0 > ## fails on Win 32b: "need finite 'ylim' values" : > try(plot(cpUse ~ ncSet, log = "xy", type = 'b', col = 2)) Error in plot.window(...) : need finite 'ylim' values In addition: Warning messages: 1: In xy.coords(x, y, xlabel, ylabel, log) : 7 y values <= 0 omitted from logarithmic plot 2: In min(x) : no non-missing arguments to min; returning Inf 3: In max(x) : no non-missing arguments to max; returning -Inf > if(doExtras) try(# fails occasionally (too many zeros) + print(summary(lmll <- lm(log(cpUse) ~ log(ncSet), subset = ncSet >= 1e4))) + ) > ## Coefficients: > ## Estimate Std. Error t value Pr(>|t|) > ## (Intercept) -9.099690 0.100188 -90.83 1.20e-10 *** > ## log(ncSet) 0.494316 0.005548 89.09 1.35e-10 *** > ## > ## Residual standard error: 0.08279 on 6 degrees of freedom > ## Multiple R-Squared: 0.9992, Adjusted R-squared: 0.9991 <<- ! > ## F-statistic: 7938 on 1 and 6 DF, p-value: 1.347e-10 > > ## => log(cpUse) ~= -9.1 + 0.494*log(ncSet) > ## <==> cpUse proportional to sqrt(ncp) > ## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ > > ## further experimenting shows, that only values in the center of the density > ## take longer times! ==> exactly where the normal approx (or others!) is good > > ###--- Now, limit for nu = df --> Inf : > ncp <- 16 > nS <- length(dfSet <- 10^(if(doExtras) 0:11 else 0:8)) > cpUse <- numeric(nS); names(cpUse) <- formatC(dfSet) > oPar <- mult.fig(nS, main = "non-central chisq(ncp = 16) and normal approx")$old.par > for(DF in dfSet) { + m <- DF + ncp + s <- sqrt(2*(DF + 2*ncp)) + x <- seq(from= m - 3*s, to= m + 3*s, length = np) + cpUse[formatC(DF)] <- system.time(y <- dchisq(x, df=DF, ncp=ncp))[1] + plot(x, y, ylim=c(0,max(y)),type = "l", ylab='f(x)', main=paste("df =",DF)) + lines(x, dnorm(x,m=m,s=s), col = 'blue', lty=2) + } > par(oPar) > cbind(dfSet, cpUse, "c/df"= cpUse / dfSet) dfSet cpUse c/df 1 1e+00 0 0 10 1e+01 0 0 100 1e+02 0 0 1000 1e+03 0 0 1e+04 1e+04 0 0 1e+05 1e+05 0 0 1e+06 1e+06 0 0 1e+07 1e+07 0 0 1e+08 1e+08 0 0 > ## remains fast! > showProc.time() Time (user system elapsed): 0.31 0 0.31 > > ## source("~/R/MM/NUMERICS/dpq-functions/dnchisq-fn.R")# dnoncentchisq() etc > > ## R > curve(dnoncentchisq(x, df=3, ncp=0), 0, 10) > curve(dchisq (x, df=3), 0, 10, add=TRUE, col='purple') > ## ok > curve(dnoncentchisq(x, df=3, ncp=1), 0, 10) > curve(dchisq (x, df=3, ncp=1), 0, 10, add=TRUE, col='purple') #ditto > > x <- seq(0, 10, length=101) > del <- c(0:4,10,40) > res <- matrix(NA, nr=length(x), nc=length(del), + dimnames=list(NULL, paste0("ncp=",del))) > for(id in seq(along=del)) + res[,id] <- dnoncentchisq(x=x, df=3, ncp=del[id]) > > matplot(x, res) > title("dnoncentchisq(*, df=3, ncp = ..) & dchisq(..)") > l.pch <- as.character(seq_along(del)) > legend("topright", paste("ncp =", del), col=1:6, pch=l.pch) > res2 <- outer(x, del, function(x,del)dchisq(x=x, 3, ncp=del)) > matplot(x, res2, add=TRUE) # practically no difference visible! > > signif( cbind(x, abs(1 - res/res2)) , digits=4) x ncp=0 ncp=1 ncp=2 ncp=3 ncp=4 ncp=10 ncp=40 [1,] 0.0 NaN NaN NaN NaN NaN NaN NaN [2,] 0.1 0 2.464e-13 9.992e-15 1.115e-13 1.110e-15 2.442e-15 1.132e-14 [3,] 0.2 0 7.755e-12 2.220e-16 1.932e-14 1.414e-13 5.291e-13 1.128e-13 [4,] 0.3 0 5.805e-11 2.220e-16 0.000e+00 9.992e-15 1.033e-13 1.268e-13 [5,] 0.4 0 2.408e-10 1.407e-13 0.000e+00 9.392e-14 1.132e-14 6.151e-14 [6,] 0.5 0 7.236e-10 6.506e-13 2.220e-16 2.887e-15 9.326e-14 7.876e-13 [7,] 0.6 0 1.773e-09 2.260e-12 2.331e-13 1.488e-14 5.105e-13 1.781e-13 [8,] 0.7 0 3.774e-09 6.448e-12 7.658e-13 5.662e-14 2.931e-14 1.131e-12 [9,] 0.8 0 7.246e-09 1.602e-11 2.133e-12 0.000e+00 1.128e-13 1.870e-13 [10,] 0.9 0 1.286e-08 3.548e-11 5.242e-12 0.000e+00 3.693e-13 8.276e-13 [11,] 1.0 0 2.145e-08 7.206e-11 1.177e-11 1.110e-16 1.776e-14 3.076e-12 [12,] 1.1 0 3.404e-08 1.365e-10 2.422e-11 1.110e-16 4.952e-14 4.121e-13 [13,] 1.2 0 5.182e-08 2.439e-10 4.666e-11 6.317e-14 1.270e-13 1.294e-12 [14,] 1.3 0 7.618e-08 4.152e-10 8.506e-11 1.331e-13 3.002e-13 1.597e-13 [15,] 1.4 0 1.087e-07 6.785e-10 1.479e-10 2.659e-13 1.332e-14 4.454e-13 [16,] 1.5 0 1.513e-07 1.070e-09 2.471e-10 5.042e-13 2.975e-14 1.149e-12 [17,] 1.6 0 2.059e-07 1.636e-09 3.987e-10 9.152e-13 6.195e-14 2.766e-12 [18,] 1.7 0 2.748e-07 2.434e-09 6.235e-10 1.599e-12 1.241e-13 3.182e-13 [19,] 1.8 0 3.606e-07 3.535e-09 9.488e-10 2.700e-12 2.383e-13 7.232e-13 [20,] 1.9 0 4.658e-07 5.027e-09 1.409e-09 4.489e-12 1.066e-14 1.563e-12 [21,] 2.0 0 5.935e-07 7.012e-09 2.048e-09 7.163e-12 1.932e-14 3.229e-12 [22,] 2.1 0 7.468e-07 9.613e-09 2.919e-09 1.115e-11 3.531e-14 3.606e-13 [23,] 2.2 0 9.293e-07 1.297e-08 4.086e-09 1.699e-11 6.217e-14 7.225e-13 [24,] 2.3 0 1.144e-06 1.726e-08 5.630e-09 2.535e-11 1.066e-13 1.396e-12 [25,] 2.4 0 1.396e-06 2.267e-08 7.642e-09 3.715e-11 1.781e-13 2.609e-12 [26,] 2.5 0 1.689e-06 2.942e-08 1.023e-08 5.353e-11 7.772e-15 4.739e-12 [27,] 2.6 0 2.027e-06 3.777e-08 1.353e-08 7.595e-11 1.288e-14 5.276e-13 [28,] 2.7 0 2.415e-06 4.799e-08 1.770e-08 1.062e-10 2.132e-14 9.444e-13 [29,] 2.8 0 2.857e-06 6.040e-08 2.289e-08 1.466e-10 3.375e-14 1.648e-12 [30,] 2.9 0 3.359e-06 7.536e-08 2.932e-08 1.999e-10 5.351e-14 2.813e-12 [31,] 3.0 0 3.927e-06 9.327e-08 3.722e-08 2.694e-10 8.216e-14 3.106e-13 [32,] 3.1 0 4.565e-06 1.146e-07 4.683e-08 3.593e-10 1.246e-13 5.254e-13 [33,] 3.2 0 5.279e-06 1.397e-07 5.846e-08 4.743e-10 5.773e-15 8.715e-13 [34,] 3.3 0 6.076e-06 1.693e-07 7.242e-08 6.203e-10 8.660e-15 1.420e-12 [35,] 3.4 0 6.962e-06 2.038e-07 8.909e-08 8.041e-10 1.266e-14 2.275e-12 [36,] 3.5 0 7.943e-06 2.439e-07 1.089e-07 1.034e-09 1.865e-14 3.586e-12 [37,] 3.6 0 9.026e-06 2.903e-07 1.322e-07 1.319e-09 2.753e-14 5.568e-12 [38,] 3.7 0 1.022e-05 3.437e-07 1.596e-07 1.670e-09 3.952e-14 6.333e-13 [39,] 3.8 0 1.152e-05 4.049e-07 1.916e-07 2.100e-09 5.662e-14 9.819e-13 [40,] 3.9 0 1.295e-05 4.748e-07 2.288e-07 2.623e-09 7.994e-14 1.501e-12 [41,] 4.0 0 1.452e-05 5.543e-07 2.719e-07 3.257e-09 1.121e-13 2.268e-12 [42,] 4.1 0 1.622e-05 6.444e-07 3.215e-07 4.019e-09 4.441e-16 3.385e-12 [43,] 4.2 0 1.806e-05 7.461e-07 3.785e-07 4.932e-09 6.661e-16 4.994e-12 [44,] 4.3 0 2.006e-05 8.605e-07 4.437e-07 6.021e-09 0.000e+00 5.760e-13 [45,] 4.4 0 2.222e-05 9.889e-07 5.179e-07 7.311e-09 3.331e-16 8.504e-13 [46,] 4.5 0 2.456e-05 1.133e-06 6.022e-07 8.835e-09 2.220e-16 1.244e-12 [47,] 4.6 0 2.707e-05 1.293e-06 6.976e-07 1.063e-08 3.331e-16 1.801e-12 [48,] 4.7 0 2.977e-05 1.471e-06 8.052e-07 1.273e-08 0.000e+00 2.583e-12 [49,] 4.8 0 3.267e-05 1.669e-06 9.263e-07 1.518e-08 2.220e-16 3.672e-12 [50,] 4.9 0 3.577e-05 1.887e-06 1.062e-06 1.802e-08 2.220e-16 5.173e-12 [51,] 5.0 0 3.909e-05 2.129e-06 1.214e-06 2.132e-08 2.220e-16 6.100e-13 [52,] 5.1 0 4.264e-05 2.394e-06 1.383e-06 2.512e-08 1.167e-13 8.626e-13 [53,] 5.2 0 4.642e-05 2.687e-06 1.572e-06 2.950e-08 1.528e-13 1.210e-12 [54,] 5.3 0 5.044e-05 3.007e-06 1.781e-06 3.452e-08 1.995e-13 1.684e-12 [55,] 5.4 0 5.472e-05 3.358e-06 2.013e-06 4.026e-08 2.586e-13 2.324e-12 [56,] 5.5 0 5.927e-05 3.741e-06 2.269e-06 4.681e-08 3.330e-13 3.189e-12 [57,] 5.6 0 6.408e-05 4.158e-06 2.552e-06 5.425e-08 4.267e-13 4.342e-12 [58,] 5.7 0 6.919e-05 4.612e-06 2.862e-06 6.269e-08 5.440e-13 5.875e-12 [59,] 5.8 0 7.458e-05 5.106e-06 3.203e-06 7.223e-08 6.908e-13 7.137e-13 [60,] 5.9 0 8.028e-05 5.641e-06 3.577e-06 8.300e-08 8.730e-13 9.694e-13 [61,] 6.0 0 8.630e-05 6.220e-06 3.986e-06 9.512e-08 1.097e-12 1.309e-12 [62,] 6.1 0 9.265e-05 6.846e-06 4.433e-06 1.087e-07 1.375e-12 1.757e-12 [63,] 6.2 0 9.933e-05 7.522e-06 4.919e-06 1.240e-07 1.714e-12 2.345e-12 [64,] 6.3 0 1.064e-04 8.250e-06 5.449e-06 1.410e-07 2.230e-12 3.114e-12 [65,] 6.4 0 1.137e-04 9.034e-06 6.025e-06 1.600e-07 2.761e-12 4.110e-12 [66,] 6.5 0 1.215e-04 9.877e-06 6.649e-06 1.812e-07 3.405e-12 5.397e-12 [67,] 6.6 0 1.296e-04 1.078e-05 7.325e-06 2.047e-07 4.184e-12 7.050e-12 [68,] 6.7 0 1.382e-04 1.175e-05 8.056e-06 2.308e-07 5.123e-12 8.848e-13 [69,] 6.8 0 1.471e-04 1.279e-05 8.845e-06 2.597e-07 6.252e-12 1.162e-12 [70,] 6.9 0 1.565e-04 1.390e-05 9.697e-06 2.916e-07 7.604e-12 1.518e-12 [71,] 7.0 0 1.663e-04 1.508e-05 1.061e-05 3.268e-07 9.219e-12 1.974e-12 [72,] 7.1 0 1.765e-04 1.635e-05 1.160e-05 3.656e-07 1.114e-11 2.556e-12 [73,] 7.2 0 1.871e-04 1.769e-05 1.266e-05 4.082e-07 1.342e-11 3.294e-12 [74,] 7.3 0 1.983e-04 1.913e-05 1.380e-05 4.550e-07 1.613e-11 4.228e-12 [75,] 7.4 0 2.099e-04 2.065e-05 1.501e-05 5.062e-07 1.931e-11 5.404e-12 [76,] 7.5 0 2.220e-04 2.227e-05 1.632e-05 5.624e-07 2.307e-11 6.878e-12 [77,] 7.6 0 2.346e-04 2.399e-05 1.771e-05 6.237e-07 2.756e-11 8.857e-13 [78,] 7.7 0 2.477e-04 2.581e-05 1.920e-05 6.906e-07 3.274e-11 1.134e-12 [79,] 7.8 0 2.613e-04 2.774e-05 2.079e-05 7.635e-07 3.880e-11 1.445e-12 [80,] 7.9 0 2.754e-04 2.978e-05 2.248e-05 8.429e-07 4.587e-11 1.835e-12 [81,] 8.0 0 2.901e-04 3.194e-05 2.429e-05 9.292e-07 5.409e-11 2.321e-12 [82,] 8.1 0 3.054e-04 3.423e-05 2.620e-05 1.023e-06 6.363e-11 2.925e-12 [83,] 8.2 0 3.212e-04 3.663e-05 2.824e-05 1.124e-06 7.467e-11 3.674e-12 [84,] 8.3 0 3.376e-04 3.917e-05 3.040e-05 1.234e-06 8.744e-11 4.600e-12 [85,] 8.4 0 3.546e-04 4.185e-05 3.270e-05 1.353e-06 1.022e-10 5.739e-12 [86,] 8.5 0 3.722e-04 4.467e-05 3.513e-05 1.482e-06 1.191e-10 7.137e-12 [87,] 8.6 0 3.904e-04 4.764e-05 3.770e-05 1.620e-06 1.386e-10 9.452e-13 [88,] 8.7 0 4.092e-04 5.076e-05 4.042e-05 1.770e-06 1.609e-10 1.182e-12 [89,] 8.8 0 4.287e-04 5.403e-05 4.330e-05 1.931e-06 1.865e-10 1.473e-12 [90,] 8.9 0 4.489e-04 5.747e-05 4.634e-05 2.104e-06 2.156e-10 1.831e-12 [91,] 9.0 0 4.697e-04 6.108e-05 4.955e-05 2.290e-06 2.489e-10 2.268e-12 [92,] 9.1 0 4.912e-04 6.487e-05 5.294e-05 2.489e-06 2.868e-10 2.801e-12 [93,] 9.2 0 5.134e-04 6.883e-05 5.650e-05 2.703e-06 3.299e-10 3.449e-12 [94,] 9.3 0 5.362e-04 7.299e-05 6.026e-05 2.933e-06 3.787e-10 4.236e-12 [95,] 9.4 0 5.598e-04 7.733e-05 6.421e-05 3.179e-06 4.339e-10 5.189e-12 [96,] 9.5 0 5.841e-04 8.188e-05 6.836e-05 3.441e-06 4.964e-10 6.337e-12 [97,] 9.6 0 6.092e-04 8.663e-05 7.273e-05 3.722e-06 5.670e-10 7.718e-12 [98,] 9.7 0 6.350e-04 9.160e-05 7.731e-05 4.022e-06 6.465e-10 1.056e-12 [99,] 9.8 0 6.616e-04 9.678e-05 8.212e-05 4.341e-06 7.360e-10 1.291e-12 [100,] 9.9 0 6.889e-04 1.022e-04 8.717e-05 4.682e-06 8.366e-10 1.578e-12 [101,] 10.0 0 7.171e-04 1.078e-04 9.246e-05 5.045e-06 9.494e-10 1.921e-12 > > matplot(x, abs(1 - res/res2)[,-1], type="b", lty=1, log="y", yaxt="n"); eaxis(2) Warning message: In xy.coords(x, y, xlabel, ylabel, log = log, recycle = TRUE) : 6 y values <= 0 omitted from logarithmic plot > title("Rel.Err |1 - dnoncentchisq(*, df=3, ncp = ..) / dchisq(..)|") > legend("bottomright", paste("ncp =", del[-1]), col=1:6, lty=1, pch=l.pch, bty="n") > > showProc.time() Time (user system elapsed): 0.05 0 0.05 > > ###---- March 2008 ----- "large ncp" : > > n <- if(doExtras) 1e4 else 512 > > ## From: Martin Maechler > ## To: Peter Dalgaard > ## Subject: Re: non-central chisq density > ## Date: Thu, 27 Mar 2008 22:22:15 +0100 > > ## [...............] > > ## Hi Peter, > > ## I've recently looked at problems in computing the non-central > ## beta density for largish non-centrality parameter, > ## which made me eventually considering the non-central chisq, > ## and I have recalled your R News (Vol.1, nr.1; 2001) > ## article on its big improvement by finding the maximal term in > ## the sum and then sum outwards; > ## and of course, the same idea will be applicable to the dnbeta() > ## as well. > > ## However, for bigger ncp things, become eventually unfeasible as > ## you've also noted in your article. > ## Hoever, there, you've mentioned that the new method would work > ## even up to ncp = 100'000^2 which I found astonishing (but not wrong) > ## because I saw much potential for underflow already in the > ## central term. > ## Also, I saw that the current pnchisq() does not compute the > ## log-density more accurately in places where the density > ## underflows to zero... > > curve(dchisq(x, df=3, ncp=30000, log=TRUE), 0, 50000) > > ## also not a big deal, but for me one more reason to look > ## at normal / central approximation formula for "large" ncp .. > ## for all (or many of) the non-central distributions. > > ## Anyway, I started to look a bit more closely and then saw this > > d <- 1e6; curve(dchisq(x, df=3, ncp=d, log=TRUE), .98*d, 1.02*d, n=n) > > ## when going to smaller ncp and looking more closely something like > > curve(dchisq(x, df=3, ncp=30000, log=TRUE), 27300, 27500, n=n) > > ## which you may find amusing.... > > ## all this no need for immediate action, but something to > ## consider, and as said, > ## I'm looking into this first for dnbeta(), but then more > ## generally. > > ## All in all, your R News article has been again a very nice piece > ## of inspiration. > ## > ## Martin > > ## dchisqAsym (x, df, ncp, log = FALSE) --> ../R/dnchisq-fn.R > ## ---------- ~~~~~~~~~~~~ > > curve(dchisq(x, df=3, ncp=30000, log=TRUE), 26000, 34000, n=n) > curve(dchisqAsym(x, df=3, ncp=30000, log=TRUE), + add=TRUE, col="purple", n=n) > curve(dnorm(x, m=3+30000, sd=sqrt(2*(3 + 2*30000)), log=TRUE), + add = TRUE, col="blue", n=n) > ##==> It seems the chisqAsym() approximation is slightly better; > ## also from this : > x <- rchisq(if(doExtras) 1e6 else 1e4, df=3, ncp=30000) > (sN <- sum(dnorm(x, m=3+30000, sd=sqrt(2*(3 + 2*30000)), log=TRUE))) [1] -72691.74 > (sCh<- sum(dchisqAsym(x, df=3, ncp=30000, log=TRUE))) ## larger (less negative) <-> better [1] -72692.2 > all.equal(sN, sCh) # ... 2.6887e-6" [Win 32b: 2.873e-5] [1] "Mean relative difference: 6.351644e-06" > > ## dnchisqBessel(x, df, ncp, log = FALSE) --> ../R/dnchisq-fn.R > ## ------------- ~~~~~~~~~~~~ > > ## From ?pl2curves() [ == ../man/pl2curves.Rd ] : > p.dnchiB <- function(df, ncp, log=FALSE, from=0, to = 2*ncp, p.log="", n = if(doExtras) 2001 else 512, ...) + { + pl2curves(dnchisqBessel, dchisq, df=df, ncp=ncp, log=log, + from=from, to=to, p.log=p.log, n=n, ...) + } > > ## simple check > stopifnot(all.equal(dchisq(1:30, df=3, ncp=1:30), + dnchisqBessel(1:30, df = 3, ncp = 1:30), + tol = 1e-13)) ## tol=0 --> "Mean rel.diff.: 2.3378e-14" > > p.dnchiB(df=1.2, ncp=500,, 200, 800) > p.dnchiB(df=1.2, ncp=500, log=TRUE)# differ in tail > > p.dnchiB(df=20, ncp=500,, 200, 800) > p.dnchiB(df=20, ncp=500, log=TRUE) # ok (differ for large x) > p.dnchiB(df=20, ncp=100) # looks good > p.dnchiB(df=20, ncp=100, , 0, 500, p.log="y") # looks good too (differ large x) Warning message: In xy.coords(x, y, xlabel, ylabel, log) : 1 y value <= 0 omitted from logarithmic plot > p.dnchiB(df=20, ncp=100, log=TRUE, 0,500) # the same > > p.dnchiB(df=20, ncp=200, log=TRUE, 0,600) # the same > p.dnchiB(df=35, ncp=400, log=TRUE, 0,1500) # the same > p.dnchiB(df= 3, ncp=600, log=TRUE, 0,2500) # the same > p.dnchiB(df= 3, ncp=800, log=TRUE, 0,3500) # for large x --> NaN in besselI > > ## However, large ncp -- gives overflow in besselI(): > dnchisqBessel(8000, df=20, ncp=5000) ## NaN -- no longer: now 1.3197e-78 [1] 1.319703e-78 > > ## Hmm, I'm slightly confused that the cutoff seems at 1500 [ < 1e4 !] > x <- if(doExtras) 1000:1600 else seq(1000, 1600, by = 5) > plot (x, besselI(x, 9, TRUE), type="l") > ## Warning message: > ## In besselI(x, nu, 1 + as.logical(expon.scaled)) : NaNs produced > lines(x, besselI(x, 1.2, TRUE), col=2) > lines(x, besselI(x, 1.0, TRUE), col=2) > lines(x, besselI(x, 0.1, TRUE), col=2) > lines(x, besselI(x, 1.8, TRUE), col=2) > > ### OTOH: Bessel asymptotic I_a(y) ~ exp(y) / sqrt(2*pi*y) for y >> a > lines(x, 1/sqrt(2*pi*x), col=3, lty=3, lwd=3) > ## hmm, looks like the nu=1.2 case, but *not* the nu=9 one ?? > > lines(x, besselI(x, 2.2, TRUE), col="blue") > lines(x, besselI(x, 3.2, TRUE), col="blue") > lines(x, besselI(x, 4.2, TRUE), col="blue") > lines(x, besselI(x, 5.2, TRUE), col="blue") > lines(x, besselI(x, 6.2, TRUE), col="blue") > lines(x, besselI(x, 7.2, TRUE), col="blue") > lines(x, besselI(x, 8.2, TRUE), col="blue") > ##--> Need asymptotic for besselI(x, nu) with a term that depends on nu > > ##--> ...bessel-large-x.R and better ~/R/Pkgs/Bessel/ > ## ~~~~~~~~~~~~~~~~~~~[April 2008] ================ > > showProc.time() Time (user system elapsed): 0.12 0.02 0.14 > > ### Part 2 : pchisq (non-central!) > ### ------------------------------- > > if(!dev.interactive(orNone=TRUE)) { dev.off(); pdf("chisq-nonc-2.pdf") } > > ## source("/u/maechler/R/MM/NUMERICS/dpq-functions/pnchisq.R")#-> pnchisq(), pnchisqV() > > ## In examples ../man/pnchisqAppr.Rd --------- > ## ((again there at beginning)) > > > ### Note Brian's change (which completely broke df=0 case !) for R 2.3.0: > > ## r37287 | ripley | 2006-02-07 23:12:38 +0100 (Tue, 07 Feb 2006) | 6 lines > > ## improvements to [pq]nchisq > ## - use direct formula which allows for lower_tail = FALSE if ncp < 80 > ## (this is often a lot more accurate). > ## - use starting point and lower_tail in qnchisq > ## - can be slower, so make interruptible > > ## --- df = 0 ------------ > stopifnot(pchisq(0:10, 0,1) >= exp(-1/2)) ## gave NaN from 2.3.0 to 2.6.1 > ## For a series of ncp = lambda : > lam <- seq(0,100, by=.25) > p00 <- pchisq(0, df=0, ncp=lam) > p.0 <- pchisq(1e-300, df=0, ncp=lam) > stopifnot(all.equal(p00, exp(-lam/2), tol=2e-16),# '0' (when compiled alike) + all.equal(p.0, exp(-lam/2), tol=4e-16))# was "1e-100" aka tol=0 .. > > ###------ > ### Accuracy buglet(s) : > ## df -> 0 : pnchisq() allows this, but it's pretty wierd : > ## ------- > ## (and S-plus does it better !!) > ## Theory: (df=0, ncp=0 ) is point mass (1) at 0 --> 1-P == 0 everywhere > ## ------ (df=0, ncp= L) has point mass exp(-L/2) at 0 > plot(function(x)pchisq(x, df=0, ncp=0, lower=FALSE),1e-1, 5000,log="x")## fine (all 0) > plot(function(x)pchisq(x, df=0, ncp=0, lower=FALSE),2000, 5000) ## all = 0 > plot(function(x)pchisq(x, df=1e-4, ncp=0, lower=FALSE),2000, 5000) ## all = 0 still > ## this is ok (2014-04) > plot(function(x)pchisq(x, df=1e-4, ncp=0, lower=FALSE),1e-1, 5000, log="xy")## !? Warning message: In xy.coords(x, y, xlabel, ylabel, log) : 12 y values <= 0 omitted from logarithmic plot > ## The R version of this: > curve( pnchisqV (x, df=1e-4, ncp=0, lower=FALSE), add=TRUE, col=adjustcolor(2,1/2), lwd=4) > ## central chisq is ok here: > curve( pchisq(x, df=1e-4, lower=FALSE),add = TRUE, col = "red") > curve( pchisq(x, df=1e-4, lower=FALSE),1e-1, 5000)#, add = TRUE) > curve( pchisq(x, df=1e-4, lower=FALSE),1e-1, 5000, log = 'xy') Warning message: In xy.coords(x, y, xlabel, ylabel, log) : 12 y values <= 0 omitted from logarithmic plot > > ##--- but the problem persists for df > 0 for small non-zero ncp: > curve( pchisq(x, df=0.01, ncp = 0.1), 1e-1, 5000, log="x") # fine > par(new=TRUE) > curve( pchisq(x, df=0.01, ncp = 0.1, lower=FALSE,log=TRUE), + 1e-1, 5000, log="x", ylab="", yaxt="n", col=2) > axis(4, col.axis=2); mtext("log(1 - p)", 4, col=2) > ## --> underflows to -Inf [because it computes log(.) > > ###--- this was "noncentral-ex.R" : > > x <- x10 <- 10^(-300:300)#-> this is x-range is NOT plottable! > x <- x10 <- 10^(-150:150)#-> *is* plottable > > system.time(pch.x10 <- pchisq(x,x ))# 0.01 in R; 4.77 in Splus 3.4 user system elapsed 0 0 0 > system.time(pch.x10n <- pchisq(x,x,ncp=1e-10))#-- hangs for ever [R <= 0.63.3] user system elapsed 0 0 0 > ## R 1.2.x : 0.57 > ## in S-plus 3.4: > ##- Error in .C("S_ncchisq_prob",: subroutine S_ncchisq_prob: > ##- 284 Inf value(s) in argument 2 > ##- Dumped > ##- Timing stopped at: 4.77 0.00999999 5 0 0 > > stopifnot(is.na(pch.x10) == is.na(pch.x10n))#> TRUE R & Splus 3.4 > stopifnot(!any(is.na(pch.x10))) > > summary(pch.x10 - pch.x10n) Min. 1st Qu. Median Mean 3rd Qu. Max. 0.000e+00 0.000e+00 2.420e-11 2.501e-11 5.000e-11 5.000e-11 > ## Splus: > ##- Min. 1st Qu. Median Mean 3rd Qu. Max. NA's > ##- 0 0 0 0 0 0 284 > > ## R 1.2.x: > ##- Min. 1st Qu. Median Mean 3rd Qu. Max. > ##- -9.054e-09 5.000e-11 5.000e-11 2.426e-01 5.000e-01 5.000e-01 > > ## Much better now: Max = 5e-11 > > ## However, closer inspection reveals > summary(pch.x10[pch.x10 != 1]) Min. 1st Qu. Median Mean 3rd Qu. Max. 0.5000 0.5000 0.5000 0.5513 0.5000 1.0000 > ##-R Min. 1st Qu. Median Mean 3rd Qu. Max. > ##-R 0.5000 0.5000 0.5000 0.5271 0.5000 1.0000 > > ##-S+3.4 Min. 1st Qu. Median Mean 3rd Qu. Max. > ##-S+3.4 -Inf -Inf -Inf -Inf -Inf 1 > summary(pch.x10[pch.x10 != 1 & is.finite(pch.x10)]) Min. 1st Qu. Median Mean 3rd Qu. Max. 0.5000 0.5000 0.5000 0.5513 0.5000 1.0000 > ##- Min. 1st Qu. Median Mean 3rd Qu. Max. > ##- 0.4912 0.5009 0.9294 0.7696 1 1 > > > ###----- less extreme x values: > > rele.pch <- function(x) 1 - pchisq(x,x,ncp=1e-100) / pchisq(x,x) > > (rl <- rele.pch(2^(-12:10))) [1] 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 > stopifnot(rl == 0)## << S-plus 3.4, later R > > ## The uniroot no longer works, but look at > curve(1-pchisq(x,1,1), 69, 1500, n = 2001, + main="1-pchisq(x,1,1), x in [69, 1500]", sub = R.version.string) > axis(1, at= c(69, 1500)) > abline(h=0, col="gray70") > ##--> lots of noise -- but around correct value = 1 > ## now, all fine : > pc1 <- + curve(pchisq(x,1,1, lower.tail=FALSE), 69, 1500, n = 2001, log = "y", + main="1-pchisq(x,1,1), x in [69, 1500]", sub = R.version.string) > > ## 1-P of course jumps to 0 *much* earlier: > plot(pc1, type="l", log="y", yaxt="n", ylab="", + main="1-pchisq(x,1,1), x in [69, 1500]", sub = R.version.string) > eaxis(2) ## whereas this underflows much much much earlier (at x ~ 100) > curve(1-pchisq(x,1,1), add=TRUE, col=adjustcolor("red", 0.5), lwd=3, n = 2001) > > > x <- 100:1511 > p <- pchisq(x,1,1, lower=FALSE) > stopifnot(0 <= p, p <= 2e-19) > lp <- log(p) > stopifnot(is.finite(lp), lp <= -43, abs(diff(lp) + 0.475) < 0.02) > showProc.time() Time (user system elapsed): 0.17 0 0.17 > > ### try other (df,ncp) -- compare with Wienergerm approx. > ## setwd("/u/maechler/R/MM/NUMERICS/dpq-functions/") > ## source("wienergerm_nchisq-fn.R") > ## dyn.load("wienergerm_nchisq.so") > > p.pchUp <- function(df, ncp, from, to, log.p=FALSE, n=2001) { + c1 <- + curve(pchisq(x, df=df, ncp=ncp, lower.tail=FALSE, log.p=log.p), + from=from, to=to, n=n, + main = paste0("pchisq(x, ",formatC(df),", ",formatC(ncp), + ", lower=F", if(log.p)", log=T", "),", + " x in [",formatC(from),", ", formatC(to), "]"), + sub = R.version.string) + axis(1, at= c(from, to)) + abline(h=0, col="gray70", lty=3) + c2 <- curve(pchisqW(x, df=df, ncp=ncp, lower.tail=FALSE, log.p=log.p), n=n, + add = TRUE, col = 2) + legend("topright", xjust = 1/2, yjust = 1.1, + c("normal", "Wienerg.approx"), col=1:2, lty=1) + invisible(data.frame(x = c1$x, pchisq = c1$y, pchisqW = c2$y)) + } > ## in all these, Wienerg.approx. looks very good: x >> df+ncp > p.pchUp( 0.1, 0.1, 51, 1500) > p.pchUp( 1, 1, 69, 1500) > p.pchUp( 1, 1, 69, 1500, log=TRUE)# small discrepancy for largish x > p.pchUp( 2.5, 0.02, 61, 1500, log=TRUE)# (nothing visible) > p.pchUp( 25, 10, 150, 1600, log=TRUE)# discrepancy largish x > summary(warnings()) ; showProc.time() 1 identical warnings: In xy.coords(x, y, xlabel, ylabel, log) : 12 y values <= 0 omitted from logarithmic plot Time (user system elapsed): 0.13 0.03 0.16 > p.pchUp( 100, 500, 980, 1900)# normal:noise(and cutoff at 1); Wienerg: smooth There were 50 or more warnings (use warnings() to see the first 50) > p.pchUp( 100, 500, 980, 1900, log=TRUE)# pchisq() breaks down There were 50 or more warnings (use warnings() to see the first 50) > p.pchUp( 500, 100, 897, 3000) There were 50 or more warnings (use warnings() to see the first 50) > p.pchUp( 500, 100, 897, 3000, log=TRUE)# pchisq break down There were 50 or more warnings (use warnings() to see the first 50) > p.pchUp( 5e3, 100, 5795, 1.e4) # zoom in.. There were 50 or more warnings (use warnings() to see the first 50) > p.pchUp( 5e3, 100, 5777, 6000) # --> Wiener has less noise long before! There were 50 or more warnings (use warnings() to see the first 50) > ## (but it also is systematically a bit larger - correct?) > summary(warnings()) ; showProc.time() 50 identical warnings: In pchisq(x, df = df, ncp = ncp, lower.tail = FALSE, log.p = log.p) : full precision may not have been achieved in 'pnchisq' Time (user system elapsed): 0.89 0.01 0.9 > > if(doExtras) withAutoprint({ # ----------------------------------- + ## Now have m + 5*s cutoff, ... + cc <- p.pchUp( 5e3, 5e3, 10400, 11e3) # still pchisq() jumps to 0 at 10866.2, too early + p.m(cc, type="l", log="y", lwd=c(1,3), col=c("black", adjustcolor("red",0.5))) + ## now (larger cutoff) "fine" but also too early to jump to zero: + c2 <- p.pchUp( 1e5, 2e4, 11.6e4, 12.6e4, n=1001) # see Wienergerm-singularity !! + p.m(c2, type="l", log="y", lwd=c(1,3), col=c("black", adjustcolor("red",0.5))) + + ## Still shows that the m + 5*s cutoff is too early! + p.pchUp( 5e3, 5e3, 10800, 11e3) + cc <- p.pchUp( 5e3, 5e3, 8000, 20e3) + p.m(cc, type="l", log="y", lwd=c(1,3), col=c("black", adjustcolor("red",0.5))) + p.pchUp( 1e5, 2e4, 12.25e4, 12.35e4)# m + 5*s __much__ too early here.. + showProc.time() # ~ 0.5 sec + }) ## only if(doExtras) ----------------------------------- > > ### NOTA BENE: We have the *big* problem when s ~= 1, x <= ncp+df > ### --------- --------------------------------------------------- > ### this is unsolved and the reason we have not yet ... > > ### ==> conclusion: Use Wienergerm as soon as P > 1 - 1e-12, > ## ---------- but probably much earlier > ## To *find* that P > 1 - 1e-12 we could try a cheap qchisq() approx. > ## unfortunately, these are quite INaccurate in the tails... > > > ## when pnchisq.c is RE-compiled with -DDEBUG_pnch > ## these give interesting output > > ## Simulate this, using pnchisq() > ## Ok, "now" for ncp <= 80, we use direct formula > ## "now" := r37287 | ripley | 2006-02-07 23:12:38 > ## > ## ---> these no longer use old algo: > > ## Case lt n(#it) > pnchisq(1000, 1,1, verbose=2)# 2 -496.8 666 pnchisq(x= 1000, ncp < cutoff): pr = 0.606531 .. ==> final pr=1.189e-14, i = 13, sum2 = 0.9999999999999996 [1] 1 > pnchisq(1300, 1,1)# 2 -646.6 838 [1] 1 > pnchisq(1400, 1,1)# 2 -696.6 895 [1] 1 > pnchisq(1420, 1,1)# 2 -706.6 906 [1] 1 > pnchisq(1422, 1,1)# 2 -707.6 907 [1] 1 > > pnchisq(1425, 1,1)# 2 -709.6 L + x large --> 1 [1] 1 > pnchisq(1430, 1,1)# 2 -711.6 L + x large --> 1 [1] 1 > pnchisq(1490, 1,1)# 2 -741.6 L + x large --> 1 [1] 1 > > > > ## With the newly (2003-01-16) visible warning [no longer; 2004-02] > pchisq(1e-5, df=100, ncp=1) [1] 0 > ## [1] 0 > ##- Warning message: > ##- too large x (= 1e-05) or noncentrality parameter 1 for current algorithm; > ##- result is probably invalid! > > pnchisq(1e-5, df=100, ncp=1, verbose = TRUE) pnchisq(x= 1e-05, ncp < cutoff): pr = 0.606531 .. ==> final pr=1.189e-14, i = 13, sum2 = 0.9999999999999996 [1] 0 > ## lt= -758.8, t=exp(lt)= 0 > ##- _OL_: n= 1 fx.2n = 102 > 0 ==> flag > ## [1] 0 > > ## where as > pnchisq(10e-5, df=100, ncp=1, verbose = TRUE) pnchisq(x= 0.0001, ncp < cutoff): pr = 0.606531 .. ==> final pr=1.189e-14, i = 13, sum2 = 0.9999999999999996 [1] 1.771157e-280 > ## lt= -643.7, t=exp(lt)= 2.92e-280 > ## _OL_: n= 1 fx.2n = 102 > 0 ==> flag > > ## [1] 1.771154e-280 > > > ##---------------- another bug: large x with ncp > 0 > > ### NOTA BENE: Fix this with "Wiener Germ Approx." formula !!! > > ### now (R 1.8.x at least) ok > mult.fig(3, main = "pchisq(x >= 1497,*, ncp=) BUG (no longer!)")$old.par -> op > curve(pchisq(x, df=1, ncp= 1), from=1,to=1e4, log='x', main="ncp = 1") > curve(pchisq(x, df=1, ncp=300), from=1,to=1e4, log='x', main="ncp = 300") > curve(pchisq(x, df=1, ncp=0), from=1,to=1e4, log='x', main="ncp = 0") > par(op) > > ## still (2004-01 ... 2014-01 !!) true: > ## now looking closer, at the upper tail {algorithm is not good on log scale!} > curve(pchisq(x, df=1, ncp=0, lower=FALSE,log=TRUE), + from=1,to=1e4, log='x', main="ncp = 0")# -> goes down to -700 or so > > ## ncp > 80 is different .. > xp <- curve(pchisq(x, df=1, ncp=300, lower=FALSE,log=TRUE), xaxt="n", + from=1, to=1e4, log='x', main="ncp = 300, log=TRUE")# only down to ~ -25 There were 25 warnings (use warnings() to see them) > eaxis(1, sub10=2) > ## .. hmm, really bad... > > ## .. the reason is that we compute on (lower=TRUE, log=FALSE) scale and only then transform: > ## --> gives warnings! (and 'verbose' output): > curve(pchisq(x, df=1, ncp=300, lower=FALSE), + from=100,to=2000, log='xy', main="ncp = 300, upper tail", axes=FALSE) -> pxy There were 44 warnings (use warnings() to see them) > summary(warnings()) Summary of (a total of 44) warning messages: 43x : In pchisq(x, df = 1, ncp = 300, lower = FALSE) : full precision may not have been achieved in 'pnchisq' 1x : In xy.coords(x, y, xlabel, ylabel, log) : 23 y values <= 0 omitted from logarithmic plot > eaxis(1, sub10=3); eaxis(2) > curve(pnchisqV(x, df=1, ncp=300, errmax = 4e-16, lower=FALSE, verbose=1),# ,log=TRUE), + add = TRUE, col=2); mtext("ncp = 300 -- pnchisqV() pure R", col=2) lt= -47.92, t=exp(lt)= 1.539e-21 n= 50, fx.2n = 1 > 0 BREAK n= 136 ; bound= 5.774e-24 <= errmax rel.err= 9.464e-12 <= reltol lt= -49.43, t=exp(lt)= 3.415e-22 n= 52, fx.2n = 1.959 > 0 BREAK n= 138 ; bound= 1.06e-23 <= errmax rel.err= 7.301e-12 <= reltol lt= -50.98, t=exp(lt)= 7.235e-23 n= 53, fx.2n = 0.8254 > 0 BREAK n= 140 ; bound= 2.034e-23 <= errmax rel.err= 5.786e-12 <= reltol lt= -52.58, t=exp(lt)= 1.462e-23 n= 55, fx.2n = 1.597 > 0 BREAK n= 142 ; bound= 4.082e-23 <= errmax rel.err= 4.712e-12 <= reltol lt= -54.23, t=exp(lt)= 2.811e-24 n= 56, fx.2n = 0.2696 > 0 BREAK n= 143 ; bound= 2.202e-22 <= errmax rel.err= 9.107e-12 <= reltol lt= -55.93, t=exp(lt)= 5.14e-25 n= 58, fx.2n = 0.8414 > 0 BREAK n= 145 ; bound= 4.735e-22 <= errmax rel.err= 7.807e-12 <= reltol lt= -57.68, t=exp(lt)= 8.92e-26 n= 60, fx.2n = 1.309 > 0 BREAK n= 147 ; bound= 1.06e-21 <= errmax rel.err= 6.89e-12 <= reltol lt= -59.48, t=exp(lt)= 1.467e-26 n= 62, fx.2n = 1.669 > 0 BREAK n= 149 ; bound= 2.471e-21 <= errmax rel.err= 6.264e-12 <= reltol lt= -61.34, t=exp(lt)= 2.283e-27 n= 64, fx.2n = 1.918 > 0 BREAK n= 151 ; bound= 5.98e-21 <= errmax rel.err= 5.87e-12 <= reltol lt= -63.26, t=exp(lt)= 3.357e-28 n= 65, fx.2n = 0.05386 > 0 BREAK n= 153 ; bound= 1.502e-20 <= errmax rel.err= 5.677e-12 <= reltol lt= -65.24, t=exp(lt)= 4.653e-29 n= 67, fx.2n = 0.07172 > 0 BREAK n= 155 ; bound= 3.91e-20 <= errmax rel.err= 5.669e-12 <= reltol lt= -67.27, t=exp(lt)= 6.07e-30 n= 70, fx.2n = 1.968 > 0 BREAK n= 157 ; bound= 1.053e-19 <= errmax rel.err= 5.851e-12 <= reltol lt= -69.37, t=exp(lt)= 7.44e-31 n= 72, fx.2n = 1.74 > 0 BREAK n= 159 ; bound= 2.93e-19 <= errmax rel.err= 6.247e-12 <= reltol lt= -71.54, t=exp(lt)= 8.552e-32 n= 74, fx.2n = 1.384 > 0 BREAK n= 161 ; bound= 8.411e-19 <= errmax rel.err= 6.905e-12 <= reltol lt= -73.77, t=exp(lt)= 9.2e-33 n= 76, fx.2n = 0.8948 > 0 BREAK n= 163 ; bound= 2.487e-18 <= errmax rel.err= 7.908e-12 <= reltol lt= -76.06, t=exp(lt)= 9.244e-34 n= 78, fx.2n = 0.2691 > 0 BREAK n= 165 ; bound= 7.56e-18 <= errmax rel.err= 9.393e-12 <= reltol lt= -78.43, t=exp(lt)= 8.657e-35 n= 81, fx.2n = 1.503 > 0 BREAK n= 168 ; bound= 1.124e-17 <= errmax rel.err= 5.656e-12 <= reltol lt= -80.87, t=exp(lt)= 7.541e-36 n= 83, fx.2n = 0.5917 > 0 BREAK n= 170 ; bound= 3.659e-17 <= errmax rel.err= 7.349e-12 <= reltol lt= -83.39, t=exp(lt)= 6.096e-37 n= 86, fx.2n = 1.531 > 0 BREAK n= 172 ; bound= 1.218e-16 <= errmax rel.err= 9.927e-12 <= reltol lt= -85.98, t=exp(lt)= 4.563e-38 n= 88, fx.2n = 0.3166 > 0 BREAK n= 175 ; bound= 2.072e-16 <= errmax rel.err= 7.095e-12 <= reltol lt= -88.65, t=exp(lt)= 3.155e-39 n= 91, fx.2n = 0.9436 > 0 BREAK n= 178 ; bound= 3.704e-16 <= errmax rel.err= 5.425e-12 <= reltol lt= -91.41, t=exp(lt)= 2.01e-40 n= 94, fx.2n = 1.407 > 0 BREAK n= 182 ; bound= 3.551e-16 <= errmax rel.err= 2.302e-12 <= reltol lt= -94.24, t=exp(lt)= 1.178e-41 n= 97, fx.2n = 1.702 > 0 BREAK n= 186 ; bound= 3.647e-16 <= errmax rel.err= 1.07e-12 <= reltol lt= -97.17, t=exp(lt)= 6.325e-43 n= 100, fx.2n = 1.824 > 0 BREAK n= 191 ; bound= 2.073e-16 <= errmax rel.err= 2.856e-13 <= reltol lt= -100.2, t=exp(lt)= 3.107e-44 n= 103, fx.2n = 1.767 > 0 BREAK n= 195 ; bound= 2.46e-16 <= errmax rel.err= 1.62e-13 <= reltol lt= -103.3, t=exp(lt)= 1.392e-45 n= 106, fx.2n = 1.526 > 0 BREAK n= 199 ; bound= 3.12e-16 <= errmax rel.err= 1.013e-13 <= reltol lt= -106.5, t=exp(lt)= 5.669e-47 n= 109, fx.2n = 1.095 > 0 BREAK n= 204 ; bound= 2.238e-16 <= errmax rel.err= 3.738e-14 <= reltol lt= -109.8, t=exp(lt)= 2.095e-48 n= 112, fx.2n = 0.4681 > 0 BREAK n= 208 ; bound= 3.266e-16 <= errmax rel.err= 2.873e-14 <= reltol lt= -113.2, t=exp(lt)= 6.997e-50 n= 116, fx.2n = 1.64 > 0 BREAK n= 213 ; bound= 2.735e-16 <= errmax rel.err= 1.327e-14 <= reltol lt= -116.7, t=exp(lt)= 2.107e-51 n= 119, fx.2n = 0.6041 > 0 BREAK n= 218 ; bound= 2.48e-16 <= errmax rel.err= 6.881e-15 <= reltol lt= -120.3, t=exp(lt)= 5.699e-53 n= 123, fx.2n = 1.354 > 0 BREAK n= 223 ; bound= 2.434e-16 <= errmax rel.err= 4.012e-15 <= reltol lt= -124, t=exp(lt)= 1.381e-54 n= 127, fx.2n = 1.884 > 0 BREAK n= 228 ; bound= 2.584e-16 <= errmax rel.err= 2.63e-15 <= reltol lt= -127.9, t=exp(lt)= 2.987e-56 n= 130, fx.2n = 0.1868 > 0 BREAK n= 233 ; bound= 2.965e-16 <= errmax rel.err= 1.94e-15 <= reltol lt= -131.8, t=exp(lt)= 5.747e-58 n= 134, fx.2n = 0.2553 > 0 BREAK n= 238 ; bound= 3.672e-16 <= errmax rel.err= 1.608e-15 <= reltol lt= -135.9, t=exp(lt)= 9.801e-60 n= 138, fx.2n = 0.08263 > 0 BREAK n= 244 ; bound= 2.762e-16 <= errmax rel.err= 8.517e-16 <= reltol lt= -140.1, t=exp(lt)= 1.476e-61 n= 143, fx.2n = 1.661 > 0 BREAK n= 250 ; bound= 2.271e-16 <= errmax rel.err= 5.136e-16 <= reltol lt= -144.4, t=exp(lt)= 1.956e-63 n= 147, fx.2n = 0.9841 > 0 BREAK n= 255 ; bound= 3.579e-16 <= errmax rel.err= 6.127e-16 <= reltol lt= -148.8, t=exp(lt)= 2.272e-65 n= 151, fx.2n = 0.04293 > 0 BREAK n= 261 ; bound= 3.489e-16 <= errmax rel.err= 4.746e-16 <= reltol lt= -153.4, t=exp(lt)= 2.303e-67 n= 156, fx.2n = 0.8298 > 0 BREAK n= 267 ; bound= 3.711e-16 <= errmax rel.err= 4.164e-16 <= reltol lt= -158.2, t=exp(lt)= 2.029e-69 n= 161, fx.2n = 1.337 > 0 BREAK n= 274 ; bound= 2.507e-16 <= errmax rel.err= 2.425e-16 <= reltol lt= -163, t=exp(lt)= 1.548e-71 n= 166, fx.2n = 1.555 > 0 BREAK n= 280 ; bound= 3.188e-16 <= errmax rel.err= 2.719e-16 <= reltol lt= -168.1, t=exp(lt)= 1.017e-73 n= 171, fx.2n = 1.475 > 0 BREAK n= 287 ; bound= 2.605e-16 <= errmax rel.err= 2.031e-16 <= reltol lt= -173.2, t=exp(lt)= 5.737e-76 n= 176, fx.2n = 1.089 > 0 BREAK n= 293 ; bound= 3.945e-16 <= errmax rel.err= 2.849e-16 <= reltol lt= -178.6, t=exp(lt)= 2.763e-78 n= 181, fx.2n = 0.3874 > 0 BREAK n= 300 ; bound= 3.885e-16 <= errmax rel.err= 2.668e-16 <= reltol lt= -184.1, t=exp(lt)= 1.131e-80 n= 187, fx.2n = 1.36 > 0 BREAK n= 308 ; bound= 2.535e-16 <= errmax rel.err= 1.689e-16 <= reltol lt= -189.8, t=exp(lt)= 3.912e-83 n= 193, fx.2n = 1.998 > 0 BREAK n= 315 ; bound= 3.038e-16 <= errmax rel.err= 1.962e-16 <= reltol lt= -195.6, t=exp(lt)= 1.139e-85 n= 198, fx.2n = 0.2894 > 0 BREAK n= 322 ; bound= 3.993e-16 <= errmax rel.err= 2.511e-16 <= reltol lt= -201.6, t=exp(lt)= 2.776e-88 n= 204, fx.2n = 0.2252 > 0 BREAK n= 330 ; bound= 3.536e-16 <= errmax rel.err= 2.186e-16 <= reltol lt= -207.8, t=exp(lt)= 5.63e-91 n= 211, fx.2n = 1.794 > 0 BREAK n= 338 ; bound= 3.474e-16 <= errmax rel.err= 2.111e-16 <= reltol lt= -214.2, t=exp(lt)= 9.452e-94 n= 217, fx.2n = 0.985 > 0 BREAK n= 346 ; bound= 3.781e-16 <= errmax rel.err= 2.257e-16 <= reltol lt= -220.8, t=exp(lt)= 1.306e-96 n= 224, fx.2n = 1.786 > 0 BREAK n= 355 ; bound= 2.851e-16 <= errmax rel.err= 1.682e-16 <= reltol lt= -227.6, t=exp(lt)= 1.477e-99 n= 230, fx.2n = 0.1864 > 0 BREAK n= 363 ; bound= 3.822e-16 <= errmax rel.err= 2.208e-16 <= reltol lt= -234.6, t=exp(lt)= 1.358e-102 n= 237, fx.2n = 0.1728 > 0 BREAK n= 372 ; bound= 3.584e-16 <= errmax rel.err= 2.039e-16 <= reltol lt= -241.8, t=exp(lt)= 1.009e-105 n= 245, fx.2n = 1.733 > 0 BREAK n= 381 ; bound= 3.752e-16 <= errmax rel.err= 2.099e-16 <= reltol lt= -249.2, t=exp(lt)= 6.016e-109 n= 252, fx.2n = 0.8541 > 0 BREAK n= 391 ; bound= 2.807e-16 <= errmax rel.err= 1.553e-16 <= reltol lt= -256.8, t=exp(lt)= 2.862e-112 n= 260, fx.2n = 1.523 > 0 BREAK n= 400 ; bound= 3.674e-16 <= errmax rel.err= 1.991e-16 <= reltol lt= -264.7, t=exp(lt)= 1.078e-115 n= 268, fx.2n = 1.725 > 0 BREAK n= 410 ; bound= 3.467e-16 <= errmax rel.err= 1.85e-16 <= reltol lt= -272.8, t=exp(lt)= 3.196e-119 n= 276, fx.2n = 1.447 > 0 BREAK n= 420 ; bound= 3.677e-16 <= errmax rel.err= 1.93e-16 <= reltol lt= -281.2, t=exp(lt)= 7.394e-123 n= 284, fx.2n = 0.6742 > 0 BREAK n= 431 ; bound= 2.869e-16 <= errmax rel.err= 1.488e-16 <= reltol lt= -289.8, t=exp(lt)= 1.325e-126 n= 293, fx.2n = 1.391 > 0 BREAK n= 441 ; bound= 3.853e-16 <= errmax rel.err= 1.957e-16 <= reltol lt= -298.7, t=exp(lt)= 1.827e-130 n= 302, fx.2n = 1.582 > 0 BREAK n= 452 ; bound= 3.839e-16 <= errmax rel.err= 1.919e-16 <= reltol lt= -307.9, t=exp(lt)= 1.921e-134 n= 311, fx.2n = 1.232 > 0 BREAK n= 464 ; bound= 2.881e-16 <= errmax rel.err= 1.424e-16 <= reltol lt= -317.3, t=exp(lt)= 1.528e-138 n= 320, fx.2n = 0.3238 > 0 BREAK n= 475 ; bound= 3.685e-16 <= errmax rel.err= 1.785e-16 <= reltol lt= -327.1, t=exp(lt)= 9.119e-143 n= 330, fx.2n = 0.8405 > 0 BREAK n= 487 ; bound= 3.578e-16 <= errmax rel.err= 1.706e-16 <= reltol lt= -337.1, t=exp(lt)= 4.046e-147 n= 340, fx.2n = 0.7647 > 0 BREAK n= 499 ; bound= 3.952e-16 <= errmax rel.err= 1.852e-16 <= reltol lt= -347.4, t=exp(lt)= 1.323e-151 n= 350, fx.2n = 0.07831 > 0 BREAK n= 512 ; bound= 3.376e-16 <= errmax rel.err= 1.561e-16 <= reltol lt= -358.1, t=exp(lt)= 3.159e-156 n= 361, fx.2n = 0.7629 > 0 BREAK n= 525 ; bound= 3.305e-16 <= errmax rel.err= 1.505e-16 <= reltol lt= -369, t=exp(lt)= 5.453e-161 n= 372, fx.2n = 0.7993 > 0 BREAK n= 538 ; bound= 3.704e-16 <= errmax rel.err= 1.656e-16 <= reltol lt= -380.3, t=exp(lt)= 6.742e-166 n= 383, fx.2n = 0.1677 > 0 BREAK n= 552 ; bound= 3.276e-16 <= errmax rel.err= 1.445e-16 <= reltol lt= -392, t=exp(lt)= 5.908e-171 n= 395, fx.2n = 0.8479 > 0 BREAK n= 566 ; bound= 3.34e-16 <= errmax rel.err= 1.449e-16 <= reltol lt= -404, t=exp(lt)= 3.632e-176 n= 407, fx.2n = 0.8189 > 0 BREAK n= 580 ; bound= 3.916e-16 <= errmax rel.err= 1.668e-16 <= reltol lt= -416.3, t=exp(lt)= 1.549e-181 n= 419, fx.2n = 0.05924 > 0 BREAK n= 595 ; bound= 3.698e-16 <= errmax rel.err= 1.552e-16 <= reltol lt= -429.1, t=exp(lt)= 4.536e-187 n= 432, fx.2n = 0.5466 > 0 BREAK n= 611 ; bound= 2.845e-16 <= errmax rel.err= 1.18e-16 <= reltol lt= -442.2, t=exp(lt)= 9.009e-193 n= 445, fx.2n = 0.2581 > 0 BREAK n= 626 ; bound= 3.613e-16 <= errmax rel.err= 1.469e-16 <= reltol lt= -455.7, t=exp(lt)= 1.2e-198 n= 459, fx.2n = 1.17 > 0 BREAK n= 642 ; bound= 3.762e-16 <= errmax rel.err= 1.505e-16 <= reltol lt= -469.7, t=exp(lt)= 1.058e-204 n= 473, fx.2n = 1.258 > 0 BREAK n= 659 ; bound= 3.251e-16 <= errmax rel.err= 1.283e-16 <= reltol lt= -484, t=exp(lt)= 6.108e-211 n= 487, fx.2n = 0.4979 > 0 BREAK n= 676 ; bound= 3.291e-16 <= errmax rel.err= 1.278e-16 <= reltol lt= -498.8, t=exp(lt)= 2.276e-217 n= 502, fx.2n = 0.8627 > 0 BREAK n= 693 ; bound= 3.894e-16 <= errmax rel.err= 1.485e-16 <= reltol lt= -514.1, t=exp(lt)= 5.405e-224 n= 517, fx.2n = 0.3263 > 0 BREAK n= 711 ; bound= 3.891e-16 <= errmax rel.err= 1.46e-16 <= reltol lt= -529.8, t=exp(lt)= 8.068e-231 n= 533, fx.2n = 0.8613 > 0 BREAK n= 730 ; bound= 3.321e-16 <= errmax rel.err= 1.23e-16 <= reltol lt= -546, t=exp(lt)= 7.464e-238 n= 549, fx.2n = 0.4395 > 0 BREAK n= 749 ; bound= 3.352e-16 <= errmax rel.err= 1.222e-16 <= reltol lt= -562.7, t=exp(lt)= 4.217e-245 n= 566, fx.2n = 1.032 > 0 BREAK n= 768 ; bound= 3.995e-16 <= errmax rel.err= 1.429e-16 <= reltol lt= -579.9, t=exp(lt)= 1.434e-252 n= 583, fx.2n = 0.6078 > 0 BREAK n= 789 ; bound= 3.039e-16 <= errmax rel.err= 1.075e-16 <= reltol lt= -597.6, t=exp(lt)= 2.889e-260 n= 601, fx.2n = 1.137 > 0 BREAK n= 809 ; bound= 3.742e-16 <= errmax rel.err= 1.299e-16 <= reltol lt= -615.9, t=exp(lt)= 3.393e-268 n= 619, fx.2n = 0.5879 > 0 BREAK n= 831 ; bound= 3.002e-16 <= errmax rel.err= 1.029e-16 <= reltol lt= -634.7, t=exp(lt)= 2.286e-276 n= 638, fx.2n = 0.9271 > 0 BREAK n= 852 ; bound= 3.882e-16 <= errmax rel.err= 1.305e-16 <= reltol lt= -654.1, t=exp(lt)= 8.69e-285 n= 657, fx.2n = 0.121 > 0 BREAK n= 875 ; bound= 3.337e-16 <= errmax rel.err= 1.107e-16 <= reltol lt= -674.1, t=exp(lt)= 1.831e-293 n= 677, fx.2n = 0.1348 > 0 BREAK n= 898 ; bound= 3.457e-16 <= errmax rel.err= 1.128e-16 <= reltol lt= -694.6, t=exp(lt)= 2.1e-302 n= 698, fx.2n = 0.9326 > 0 BREAK n= 922 ; bound= 3.245e-16 <= errmax rel.err= 1.043e-16 <= reltol lt= -715.9 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -737.7 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -760.2 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -783.4 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -807.4 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -832 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -857.4 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -883.6 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -910.5 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -938.3 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -966.9 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 lt= -996.4 => exp(lt) underflow protection and x > E(X) + 5 *sigma(X) : too large --> 1 > showProc.time() Time (user system elapsed): 0.09 0.02 0.11 > > > ## also seems to hang (or take much too long?) on Winbuilder [32 bit *and* 64 bit ] > if(.Platform$OS.type == "unix" && !noLdbl) withAutoprint({ + pncRC <- pnchisqRC(pxy$x, df=1, ncp=300, lower=FALSE, verbose=1) + all.equal(pxy$y, pncRC, tol = 0)# "often" TRUE, depends on exact R version, etc + stopifnot( + all.equal(pxy$y, pncRC, tol = if(noLdbl) 5e-14 else 0)# noLdbl: seen 1.129e-14 + ) + summary(warnings()) + showProc.time() + })# ---------------------only if(.. "unix" ....)---------------------------- > > > ## Really large 'df' and 'x' -- "case I": > ## no problem anymore: > f <- c(.9,.999,.99999, 1, 1.00001,1.111, 1.1) > x <- 1e18*f > stopifnot(exprs = { + all.equal(pchisq(x, df=1e18, ncp=1) -> p, + c(0,0,0, 1/2, 1,1,1)) + all.equal(p, pnchisqRC(x, df=1e18, ncp=1), tol = 4e-16) # see 0 + }) > ## case I -- underflow protection large x --> 1 > tt <- 10^-(6:12) > stopifnot(!is.unsorted(xm <- 1e18*(1 + c(-tt, 0, rev(tt))))) > (pn <- pnchisqV (xm, df=1e18, ncp=1)) #-> 0...1 is correct [1] 0.000000e+00 0.000000e+00 7.687298e-13 2.397501e-01 4.718140e-01 [6] 4.971791e-01 4.997179e-01 5.000000e-01 5.002821e-01 5.028209e-01 [11] 5.281860e-01 7.602500e-01 1.000000e+00 1.000000e+00 1.000000e+00 > pp <- pchisq (xm, df=1e18, ncp=1) > ## > if(.Platform$OS.type == "unix") withAutoprint({ #------------------- + pp. <- pnchisqRC(xm, df=1e18, ncp=1, verbose=1) + ## Pnchisq_R(x, f, th, ... lower.tail=1, log.p=0, cut_ncp=80, it_simple=110, + ## errmax=1e-12, reltol=1.77636e-15, epsS=8.88178e-16, itrmax=1000000, verbose=1) + ## --> n:= max(length(.),..) = 15 + ## but then does *NOT* terminate in time on Winbuilder + all(pp == pp.)# >>> TRUE : *RC is also C code, perfect + all.equal(pp, pn, tol = 0) # see 1.6e-16 (even on Win 32b) + if(doExtras && !noLdbl) # who knows .. + stopifnot(pp == pp.) + stopifnot(exprs = { + all.equal(pp, pp., tol = 1e-15) # see 0 + all.equal(pp, pn, tol = 1e-15) # see 1.6e-16 + }) + })## only if( .. unix .. ) > > ## (also "problematic" with Wienergerm: s=0) > showProc.time()#----------------- Time (user system elapsed): 0 0 0 > > > ### largish f and ncp {no problem visible here, but see below} > curve(pchisq(x, df= 10000, ncp=300), + from=1e-3, to=20000, log='x', main="ncp = 300") > curve(pchisq(x, df= 10000, ncp=300), + from=2000, to=20000, log='x', main="ncp = 300") > > x <- seq(3000,11000, length=201) > if(FALSE)## to see the break: + x <- seq(5500,11000, length=201) > px <- pchisq(x, df=10000, ncp=300, log=TRUE) > plot(x, px, type='l', col=2, lwd=2, + main="pchisq(*, df=10000,ncp=300, log=TRUE))") > head(px, 20) [1] -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf -Inf [16] -Inf -Inf -Inf -Inf -Inf > ## for the (5500,11000): -Inf -Inf ..... -Inf -650.2379 -640.3743 -630.6.. > showProc.time() Time (user system elapsed): 0 0 0 > > pnchisq(5500, df= 10000, ncp=300, verbose=2) lt= -744.4 => exp(lt) underflow protection ln(x)= 8.612503 _OL_: n= 1 n= 1, fx.2n = 4502 > 0 BREAK n= 1 ; bound= 0 <= errmax rel.err= NaN <= reltol [1] 0 attr(,"iter") [1] 1 > ## lt= -744.4 => exp(lt) underflow protection ln(x)= 8.612503 > ## _OL_: n= 1 n= 1, fx.2n = 4502 > 0 > ## BREAK n= 1 ; bound= 0 <= errmax rel.err= NaN <= reltol > > ## New: allow large ncp {this now (that we use reltol !) *TAKES TIME*} > curve(pnchisqV(x, df= 10000, ncp= 4000), + from=12000, to= 16000, main="df = 10000, ncp = 4000") > curve(400*dchisq(x, df= 10000, ncp= 4000), add = TRUE, col = "green") > ## R's pchisq() looks fine now: > curve(pchisq(x, df= 10000, ncp= 4000), add=TRUE, + col=adjustcolor("blue",1/4), lwd=4) > > curve(pnchisqV(x, df= 16e3, ncp= 16e3), + from=30e3, to= 35e3, main="df = 16e3, ncp = 16e3") > curve(400*dchisq(x, df= 16e3, ncp= 16e3), add = TRUE, + col = adjustcolor("green4",.5), lwd=3) > showProc.time() Time (user system elapsed): 0.99 0 0.99 > > if(doExtras) withAutoprint({ + ## current R version: -- (also relatively slow, but much faster!) *and* non-convergence warning + rr <- curve(pchisq(x, df= 10000, ncp=3e5), type = "o", cex = 1/2, n = 49) + summary(warnings()) ## all non-convergences (but *looks* ok) + ## non-convergence in 100000 iterations : -- S.L.O.W. (~ 1 min. on 2014 lynne) + rV <- curve(pnchisqV(x, df= 10000, ncp=3e5), n = 49, + from=3.13e5, to= 3.14e5, main="ncp = 3e5 - pnchisqV()") + summary(warnings()) + identical(rr$x, rV$x) + showProc.time()#----------------- + }) > > ### NOTA BENE: dnchisq() has a similar sum and the following i.Max > imaxD <- function(x,df,lambda) + pmax(0, ceiling(0.25* (-(2+df) +sqrt((df-2)^2 + 4*lambda* x)))) > ## A few test comparisons with ssR4[,,] : > ## ==> imaxD() is too small (has correct order of magnitude, unless for > ## p(x) > 1-1e-4 > > ### Investigate pnchisq() algorithm sum(v[i] * t[i]) : > ### > ### rr(i) : is it increasing / decreasing / maximal / .. ? > plRpois(lambda = 1000) > > mult.fig(8, main = r_pois_expr, tit.wid = 6)$old.par -> op > for(la in c(5,20,50,100,200,500,1500,5000)) + plRpois(lambda = la, do.main=FALSE) Warning message: In xy.coords(x, y, xlabel, ylabel, log) : 2044 y values <= 0 omitted from logarithmic plot > par(op) > ## -> Wow! > ## 1) Always decreasing; > ## 2) r(i,lambda) < lambda / i and ~=~ for i < lambda) > > ## How well approximation from *ratio* point of view: > ## Interesting i < ~ lambda (ok, clearly improvable): > ## ----------- i >= lambda : need better approx > plotrq <- function(lambda, i = 1:(3*round(lambda))) { + lab <- as.expression(substitute(lambda==la, list(la=lambda))) + plot(i, r_pois(i,lam=lambda) / (lambda/i), + type='b', cex=.4, col=2) + abline(v=lambda, col='gray', lty=2) + axis(3, at = lambda, label = lab) + } > plotrq(10) > > mult.fig(4, main = " r_pois(i) / (lambda/i)")$old.par -> op > plotrq(20) > plotrq(50) > plotrq(100) > plotrq(500) > par(op) > showProc.time() Time (user system elapsed): 0.47 0.02 0.48 > > ## How well approximation from difference point of view: > ## Interesting i < ~ lambda (ok, clearly improvable): > ## ----------- i >= lambda : need better approx > plotDr <- function(lambda, i = 1:(4*round(lambda))) { + lab <- as.expression(substitute(lambda==la, list(la=lambda))) + plot(i, (lambda/i) - r_pois(i,lam=lambda), + type='b', cex=.4, col=2) + abline(v=lambda, col='gray', lty=2) + axis(3, at = lambda, label = lab) + } > > mult.fig(9, main = quote(plotDr(lambda)))$old.par -> op > plotDr( 4) > plotDr(10) > plotDr(20) > plotDr(50) > plotDr(100) > plotDr(200) > plotDr(500) > plotDr(1000) > plotDr(2000)## oops: problem (no longer !) > par(op) > > ### Now back to the original problem: > ### Using ss() terms and see where they are maximal, etc. > (pR <- pnchisq (1.2,df=1,ncp=3, verbose=FALSE))# iter = 12, now 13 [1] 0.2598452 > all.equal(c(pR), pnchisq_ss(1.2,df=1,ncp=3), tol=0)# 2.19e-12, now 9.61e-14, [1] "Mean relative difference: 4.272633e-16" > ## 6.4e-16 on Win 32b ! > > (pR <- pnchisq (1.2,df=1,ncp=30, verbose=FALSE))# iter = 12, now 16 [1] 5.885645e-06 > all.equal(pR, pnchisq_ss(1.2,df=1,ncp=30), tol= 2e-13) [1] TRUE > ## was 2.616 e-8 (thanks to 'reltol'!) > (pR <- pnchisq (1.2,df=1,ncp=30, verbose=FALSE,reltol=3e-16))# 19 it. [1] 5.885645e-06 > all.equal(pR, pnchisq_ss(1.2,df=1,ncp=30), tol= 2e-16) [1] TRUE > > str(sss <- ss(1.2,df=1,ncp=30))# s[1:161], max = 3 List of 3 $ s : num [1:161] 3.06e-07 1.96e-06 3.77e-06 3.48e-06 1.88e-06 ... $ i1 : int 1 $ max: int 3 > plot(sss$s, type="h", col=2) > ## i: for log-ax bug (warning) {still not nice looking > range(which(i <- 1e8*sss$s > .Machine$double.xmin * sss$s[sss$max]))# 1:160 [1] 1 160 > plot(sss$s[i], type="b", col=2, log = 'xy') > ## Which indices are relevant for the sum? > range(which(ii <- sss$s > .Machine$double.eps * sss$s[sss$max])) [1] 1 19 > ## 1:19 -- as we had 19 iterations above! > stopifnot(sum(sss$s[ii]) == sum(sss$s)) > > ## Left tail probabilities are now much better: > (pR <- pnchisq (1.2, df=100, ncp=30, verbose=FALSE,reltol=3e-16)) [1] 5.384254e-83 > ## 5.384254 e-83 , 12 iter. > pchisq (1.2, df=100, ncp=30) [1] 5.384254e-83 > ## 4.461632 e-83, which is identical to > pnchisq (1.2, df=100, ncp=30, reltol=1)# =^= "old" C code (1 iter!) [1] 5.384254e-83 > > ### What about large df and x -- #{terms} ? > str(sss <- ss(100,100, 1e-3))# 1 469 List of 3 $ s : num [1:469] 1 0.98 0.943 0.889 0.823 ... $ i1 : int 1 $ max: int 1 > pnchisq_ss(100,100,1e-3) [1] 0.5187802 > pchisq (100,100,1e-3) [1] 0.5187802 > ((Ss <- sum(sss$s)) - sum(rev(sss$s)))/Ss # -1.9286 e-16 [1] 0 > > ss2(100,100, 1e-3) i1 i2 iN1 iN2 max 1 469 1 71 1 > ##- i1 i2 iN1 iN2 max > ##- 1 469 1 71 1 > Ns <- 2^c(-200, -15, -5, -1:15, 30, 100) > names(Ns) <- paste("2",formatC(log(Ns,2)),sep="^") > tab.ss1c <- t(sapply(Ns, function(u) ss2(100,100,ncp=u, i.max=10000))) There were 12 warnings (use warnings() to see them) > tab.ss1c i1 i2 iN1 iN2 max 2^-200 1 469 1 71 1 2^-15 1 469 1 71 1 2^-5 1 469 1 71 1 2^-1 1 469 1 71 2 2^0 1 469 1 71 3 2^1 1 469 1 71 4 2^2 1 469 1 71 5 2^3 1 469 1 72 7 2^4 1 469 1 72 10 2^5 1 469 1 74 15 2^6 1 469 1 79 24 2^7 1 469 4 92 38 2^8 1 469 15 119 60 2^9 1 469 36 160 92 2^10 1 467 69 219 138 2^11 114 306 120 299 203 2^12 222 10000 Inf -Inf 223 2^13 171 10000 Inf -Inf 172 2^14 141 10000 Inf -Inf 142 2^15 121 10000 Inf -Inf 122 2^30 41 10000 Inf -Inf 42 2^100 11 10000 Inf -Inf 12 > ##-> i2 is "constant": 469 (or 468);problems from ncp >= 2^12 = 4096 > tab.ss10 <- t(sapply(Ns, function(u) ss2(10,10, ncp=u, i.max=10000))) There were 14 warnings (use warnings() to see them) > cbind(tab.ss10, tab.ss1c) ## only from ncp ~= 2^6, things change i1 i2 iN1 iN2 max i1 i2 iN1 iN2 max 2^-200 1 248 1 29 1 1 469 1 71 1 2^-15 1 248 1 29 1 1 469 1 71 1 2^-5 1 248 1 29 1 1 469 1 71 1 2^-1 1 248 1 29 2 1 469 1 71 2 2^0 1 248 1 29 2 1 469 1 71 3 2^1 1 248 1 29 2 1 469 1 71 4 2^2 1 248 1 29 3 1 469 1 71 5 2^3 1 248 1 30 4 1 469 1 72 7 2^4 1 248 1 31 5 1 469 1 72 10 2^5 1 248 1 33 8 1 469 1 74 15 2^6 1 248 1 38 11 1 469 1 79 24 2^7 1 248 1 47 16 1 469 4 92 38 2^8 1 248 1 59 24 1 469 15 119 60 2^9 1 248 5 75 34 1 469 36 160 92 2^10 1 220 13 97 49 1 467 69 219 138 2^11 339 10000 Inf -Inf 340 114 306 120 299 203 2^12 222 10000 Inf -Inf 223 222 10000 Inf -Inf 223 2^13 171 10000 Inf -Inf 172 171 10000 Inf -Inf 172 2^14 141 10000 Inf -Inf 142 141 10000 Inf -Inf 142 2^15 121 10000 Inf -Inf 122 121 10000 Inf -Inf 122 2^30 41 10000 Inf -Inf 42 41 10000 Inf -Inf 42 2^100 11 10000 Inf -Inf 12 11 10000 Inf -Inf 12 > > (t1k.1c <- t(sapply(Ns, function(u) ss2(1000,100, ncp=u)))) i1 i2 iN1 iN2 max 2^-200 1 1806 274 652 450 2^-15 1 1806 274 652 450 2^-5 1 1806 274 652 450 2^-1 1 1806 274 652 450 2^0 1 1806 274 652 450 2^1 1 1806 274 652 450 2^2 1 1806 274 652 450 2^3 1 1806 274 652 450 2^4 1 1806 274 652 450 2^5 1 1806 274 652 450 2^6 1 1806 274 652 450 2^7 1 1806 274 652 450 2^8 1 1806 274 652 450 2^9 1 1806 274 652 450 2^10 1 1806 356 661 488 2^11 47 10000 Inf -Inf 340 2^12 222 10000 Inf -Inf 223 2^13 171 10000 Inf -Inf 172 2^14 141 10000 Inf -Inf 142 2^15 121 10000 Inf -Inf 122 2^30 41 10000 Inf -Inf 42 2^100 11 10000 Inf -Inf 12 There were 14 warnings (use warnings() to see them) > ## even with i.max = 100000, thing "go wrong" from ncp = 2^11 > str(s.. <- ss(1000,10, 2048)) List of 3 $ s : num [1:10000] 0 0 0 0 0 0 0 0 0 0 ... $ i1 : int 38 $ max: int 340 > s..$s[1:400] #-- sequence diverges to +Inf -- can we better re-scale? [1] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [6] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [11] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [16] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [21] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [26] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [31] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [36] 0.000000e+00 0.000000e+00 0.000000e+00 4.940656e-324 2.020728e-321 [41] 5.757841e-319 1.564695e-316 4.062506e-314 1.008779e-311 2.398059e-309 [46] 5.462484e-307 1.193371e-304 2.502580e-302 5.041795e-300 9.765848e-298 [51] 1.820088e-295 3.266253e-293 5.647908e-291 9.416732e-289 1.514856e-286 [56] 2.352745e-284 3.530001e-282 5.119489e-280 7.180867e-278 9.746847e-276 [61] 1.280912e-273 1.630669e-271 2.011962e-269 2.407085e-267 2.793727e-265 [66] 3.146985e-263 3.442032e-261 3.657048e-259 3.775916e-257 3.790229e-255 [71] 3.700246e-253 3.514661e-251 3.249269e-249 2.924785e-247 2.564257e-245 [76] 2.190469e-243 1.823752e-241 1.480434e-239 1.172045e-237 9.052464e-236 [81] 6.823184e-234 5.020342e-232 3.606869e-230 2.531048e-228 1.735250e-226 [86] 1.162605e-224 7.614207e-223 4.875849e-221 3.053639e-219 1.870826e-217 [91] 1.121506e-215 6.579962e-214 3.779192e-212 2.125326e-210 1.170573e-208 [96] 6.315555e-207 3.338536e-205 1.729505e-203 8.782062e-202 4.371863e-200 [101] 2.134108e-198 1.021713e-196 4.798273e-195 2.210877e-193 9.996452e-192 [106] 4.436143e-190 1.932497e-188 8.265321e-187 3.471369e-185 1.431901e-183 [111] 5.801854e-182 2.309567e-180 9.033830e-179 3.472620e-177 1.312054e-175 [116] 4.873258e-174 1.779604e-172 6.390364e-171 2.256768e-169 7.839117e-168 [121] 2.678708e-166 9.005739e-165 2.979246e-163 9.699342e-162 3.108010e-160 [126] 9.803500e-159 3.044332e-157 9.308238e-156 2.802590e-154 8.310349e-153 [131] 2.427152e-151 6.983000e-150 1.979263e-148 5.527504e-147 1.521130e-145 [136] 4.125363e-144 1.102712e-142 2.905439e-141 7.546678e-140 1.932583e-138 [141] 4.879805e-137 1.215042e-135 2.983644e-134 7.226218e-133 1.726334e-131 [146] 4.068446e-130 9.459372e-129 2.170029e-127 4.912212e-126 1.097325e-124 [151] 2.419236e-123 5.264329e-122 1.130750e-120 2.397650e-119 5.019217e-118 [156] 1.037416e-116 2.117248e-115 4.267042e-114 8.492833e-113 1.669485e-111 [161] 3.241531e-110 6.217106e-109 1.177957e-107 2.204986e-106 4.078019e-105 [166] 7.452308e-104 1.345741e-102 2.401554e-101 4.235582e-100 7.383358e-99 [171] 1.272168e-97 2.166774e-96 3.648299e-95 6.073002e-94 9.994957e-93 [176] 1.626487e-91 2.617221e-90 4.164639e-89 6.553727e-88 1.020000e-86 [181] 1.570144e-85 2.390737e-84 3.600837e-83 5.365123e-82 7.908349e-81 [186] 1.153312e-79 1.664131e-78 2.375923e-77 3.356646e-76 4.692787e-75 [191] 6.492801e-74 8.890634e-73 1.204914e-71 1.616311e-70 2.146160e-69 [196] 2.820915e-68 3.670550e-67 4.728326e-66 6.030324e-65 7.614695e-64 [201] 9.520602e-63 1.178684e-61 1.445017e-60 1.754329e-59 2.109274e-58 [206] 2.511648e-57 2.962161e-56 3.460212e-55 4.003692e-54 4.588832e-53 [211] 5.210106e-52 5.860210e-51 6.530118e-50 7.209234e-49 7.885623e-48 [216] 8.546343e-47 9.177838e-46 9.766399e-45 1.029866e-43 1.076209e-42 [221] 1.114551e-41 1.143955e-40 1.163697e-39 1.173305e-38 1.172571e-37 [226] 1.161558e-36 1.140599e-35 1.110281e-34 1.071411e-33 1.024990e-32 [231] 9.721638e-32 9.141799e-31 8.523387e-30 7.879468e-29 7.222730e-28 [236] 6.565098e-27 5.917412e-26 5.289181e-25 4.688417e-24 4.121547e-23 [241] 3.593398e-22 3.107251e-21 2.664942e-20 2.267015e-19 1.912892e-18 [246] 1.601070e-17 1.329316e-16 1.094859e-15 8.945691e-15 7.251196e-14 [251] 5.831214e-13 4.652384e-12 3.682755e-11 2.892439e-10 2.254048e-09 [256] 1.742941e-08 1.337323e-07 1.018208e-06 7.693009e-06 5.768045e-05 [261] 4.291866e-04 3.169287e-03 2.322669e-02 1.689413e-01 1.219605e+00 [266] 8.738768e+00 6.214991e+01 4.387351e+02 3.074310e+03 2.138397e+04 [271] 1.476509e+05 1.012052e+06 6.886522e+06 4.651993e+07 3.119835e+08 [276] 2.077251e+09 1.373164e+10 9.012454e+10 5.873030e+11 3.800063e+12 [281] 2.441405e+13 1.557472e+14 9.866037e+14 6.206090e+15 3.876653e+16 [286] 2.404750e+17 1.481384e+18 9.062755e+18 5.506281e+19 3.322555e+20 [291] 1.991187e+21 1.185190e+22 7.006643e+22 4.114228e+23 2.399567e+24 [296] 1.390124e+25 7.999444e+25 4.572586e+26 2.596386e+27 1.464507e+28 [301] 8.206129e+28 4.567927e+29 2.526058e+30 1.387779e+31 7.574597e+31 [306] 4.107429e+32 2.212896e+33 1.184518e+34 6.299721e+34 3.328960e+35 [311] 1.747884e+36 9.118892e+36 4.727223e+37 2.435081e+38 1.246444e+39 [316] 6.340049e+39 3.204659e+40 1.609715e+41 8.035303e+41 3.986121e+42 [321] 1.965178e+43 9.628638e+43 4.688649e+44 2.269127e+45 1.091456e+46 [326] 5.217926e+46 2.479376e+47 1.170974e+48 5.496941e+48 2.564906e+49 [331] 1.189614e+50 5.484453e+50 2.513395e+51 1.144975e+52 5.184979e+52 [336] 2.334110e+53 1.044544e+54 4.646976e+54 2.055230e+55 Inf [341] Inf Inf Inf Inf Inf [346] Inf Inf Inf Inf Inf [351] Inf Inf Inf Inf Inf [356] Inf Inf Inf Inf Inf [361] Inf Inf Inf Inf Inf [366] Inf Inf Inf Inf Inf [371] Inf Inf Inf Inf Inf [376] Inf Inf Inf Inf Inf [381] Inf Inf Inf Inf Inf [386] Inf Inf Inf Inf Inf [391] Inf Inf Inf Inf Inf [396] Inf Inf Inf Inf Inf > ## (yes, we can: pnchisq() does so -- leave this for now) > > ## Now vary x from small to large: > (t.x.1k <- t(sapply(Ns, function(x) ss2(x,df=100, ncp=100))))# probl. from 2^11 i1 i2 iN1 iN2 max 2^-200 1 5 1 1 1 2^-15 1 49 1 4 1 2^-5 1 87 1 7 1 2^-1 1 124 1 12 1 2^0 1 138 1 14 1 2^1 1 156 1 18 1 2^2 1 179 1 22 2 2^3 1 209 1 28 4 2^4 1 250 1 36 8 2^5 1 307 1 49 14 2^6 1 392 1 67 23 2^7 1 523 4 102 39 2^8 1 740 17 185 79 2^9 1 1123 84 353 206 2^10 1 1839 283 666 462 2^11 1 3234 Inf -Inf 536 2^12 1 6004 Inf -Inf 289 2^13 1 10000 Inf -Inf 213 2^14 1 10000 Inf -Inf 171 2^15 1 10000 Inf -Inf 144 2^30 1 10000 Inf -Inf 46 2^100 1 10000 Inf -Inf 12 There were 14 warnings (use warnings() to see them) > > > str(s <- ss(1000,100, ncp=3000)) List of 3 $ s : num [1:10000] 0 0 0 0 0 0 0 0 0 0 ... $ i1 : int 165 $ max: int 260 > str(s <- ss(100,100, ncp=1000)) List of 3 $ s : num [1:468] 7.12e-218 3.50e-215 8.43e-213 1.33e-210 1.54e-208 ... $ i1 : int 1 $ max: int 136 > ## $ s : num [1:469] 1.00e+00 4.91e+02 1.18e+05 1.86e+07 2.16e+09 ... > ## $ i1 : int 1 > ## $ max: int 136 > s$s[s$max] # 1.4 e-130 : down scaled [1] 1.40924e-130 > ss2(100,100, ncp=1000) i1 i2 iN1 iN2 max 1 468 68 216 136 > ##- i1 i2 iN1 iN2 max > ##- 1 468 68 216 136 > ss2(100,100, ncp=2000) i1 i2 iN1 iN2 max 95 326 118 296 201 > ##- i1 i2 iN1 iN2 max > ##- 95 326 118 296 201 > > ## But: > all( ss(100,100,5000)$s == 0) # TRUE -- no longer [1] FALSE > ## because lu needs much better scaling "-lambda" is too much > ## "Fixed" : > table( ss(100,100, ncp=5000)$s ) ## only values in {0, Inf}, mostly Inf ! 0 Inf 204 9796 > > ##==> give up for these high ncp for the moment! > > showProc.time() Time (user system elapsed): 0.73 0.1 0.84 > > ## Instead use C - code which parallels pnchisq()'s in C: > ## dyn.load("/u/maechler/R/MM/NUMERICS/dpq-functions/pnchisq-it.so") > str(pit <- pnchisqIT(3,2,4))# 1:21 List of 4 $ prob : num 0.29 $ i0 : int 0 $ n.terms: int 21 $ terms : num [1:21] 0.0453 0.1019 0.0849 0.0403 0.0134 ... > stopifnot(with(pit, all.equal(sum(terms), prob))) > ## this is a bit funny: all 0 terms > stopifnot(with(pit2 <- pnchisqIT(100,100,5000), + all.equal(sum(terms), prob))) > all(pit2$terms == 0)# TRUE [1] TRUE > stopifnot(with(pit3 <- pnchisqIT(100,100,5), + all.equal(sum(terms), prob, tol=1e-15))) > str(pit3)# 1:69 List of 4 $ prob : num 0.384 $ i0 : int 0 $ n.terms: int 69 $ terms : num [1:69] 0.00462 0.01586 0.02887 0.03795 0.04133 ... > str(pit <- pnchisqIT(10000,10000,5))# 567 List of 4 $ prob : num 0.488 $ i0 : int 0 $ n.terms: int 567 $ terms : num [1:567] 0.000463 0.001621 0.003066 0.004269 0.005018 ... > str(pit <- pnchisqIT(10004,10000,5))# 569 terms List of 4 $ prob : num 0.499 $ i0 : int 0 $ n.terms: int 569 $ terms : num [1:569] 0.000463 0.001621 0.003067 0.004272 0.005024 ... > str(pit <- pnchisqIT(10010,10000,5))# 572 terms (i0=0) List of 4 $ prob : num 0.516 $ i0 : int 0 $ n.terms: int 572 $ terms : num [1:572] 0.000462 0.001618 0.003065 0.004271 0.005025 ... > str(pit <- pnchisqIT(12000,10000,5))# 1612 terms (i0=0) List of 4 $ prob : num 1 $ i0 : int 0 $ n.terms: int 1612 $ terms : num [1:1612] 1.89e-42 7.95e-42 1.81e-41 3.02e-41 4.26e-41 ... > ## hmm, quite interesting: > plot(pit$terms,type='l') > par(new=TRUE) > plot(pit$terms,type='l', log = 'y',yaxt='n',col=2)# looks like -x^2 ! > axis(4, col.axis=2) > summary(pit$terms) # max = 0.005150251 -- the first few 100 are unneeded Min. 1st Qu. Median Mean 3rd Qu. Max. 0.000e+00 0.000e+00 7.000e-09 6.203e-04 1.743e-04 5.150e-03 > > str(pit <- pnchisqIT(12000,10000,5000))# 2442 terms, i0=877; max.term= 2.5e-60 ! List of 4 $ prob : num 2.49e-58 $ i0 : int 877 $ n.terms: int 2442 $ terms : num [1:2442] 0 0 0 0 0 0 0 0 0 0 ... > ## many unneeded terms! > str(pit <- pnchisqIT(15000,10000,5000))# 3189 terms, i0=877; max=.003287 List of 4 $ prob : num 0.502 $ i0 : int 877 $ n.terms: int 3189 $ terms : num [1:3189] 0 0 0 0 0 0 0 0 0 0 ... > > str(pit <- pnchisqIT(20000,10000,5))# -> 1 immediately {0 terms} List of 4 $ prob : num 1 $ i0 : int 1495 $ n.terms: int 5783 $ terms : num [1:5783] 0 0 0 0 0 0 0 0 0 0 ... Warning message: In pnchisqIT(20000, 10000, 5) : x > E[X] + 3*sigma(X) -- result may not be good > > ## Now use ss2.() for the "term statistics": > ss2.(15000,10000, 5000)# 3189 terms, i0=877 i0 nT i1 i2 iN1 iN2 iMax 877 3189 1008 3189 2157 3189 2547 > ss2.(1, 10000, 5000)# immediate 0 -> 1 term only i0 nT i1 i2 iN1 iN2 iMax 1 1 NA NA 1 1 1 > ss2.(1e5, 10000, 5000)# immediate 1 -> "0 terms" i0 nT i1 i2 iN1 iN2 iMax 36862 46714 36862 46714 43133 46714 45000 Warning message: In ss2.(1e+05, 10000, 5000) : x > E[X] + 3*sigma(X) -- result may not be good > > ## Takes (already quite a bit) time: > rs <- sapply(14990:15010, function(x) ss2.(x,10000,5000)) > t(rs) i0 nT i1 i2 iN1 iN2 iMax [1,] 877 3185 1007 3185 2156 3185 2545 [2,] 877 3185 1008 3185 2156 3185 2545 [3,] 877 3185 1008 3185 2156 3185 2545 [4,] 877 3186 1008 3186 2156 3186 2546 [5,] 877 3186 1008 3186 2156 3186 2546 [6,] 877 3187 1008 3187 2156 3187 2546 [7,] 877 3187 1008 3187 2157 3187 2546 [8,] 877 3188 1008 3188 2157 3188 2547 [9,] 877 3188 1008 3188 2157 3188 2547 [10,] 877 3189 1008 3189 2157 3189 2547 [11,] 877 3189 1008 3189 2157 3189 2547 [12,] 877 3190 1008 3190 2157 3190 2547 [13,] 877 3190 1008 3190 2157 3190 2548 [14,] 877 3191 1009 3191 2158 3191 2548 [15,] 877 3191 1009 3191 2158 3191 2548 [16,] 877 3192 1009 3192 2158 3192 2548 [17,] 877 3192 1009 3192 2158 3192 2549 [18,] 877 3193 1009 3193 2158 3193 2549 [19,] 877 3193 1009 3193 2158 3193 2549 [20,] 877 3194 1009 3194 2158 3194 2549 [21,] 877 3194 1009 3194 2158 3194 2550 > ## as expected : n.terms gives proper 'right border': > stopifnot(rs["i2",] == rs["nT", ], + rs["i2",] == rs["iN2", ]) > ## swap df & ncp ===> the *double* number of terms! > x <- c(1000,10000,14000,14500, 14990,15000,15010,15500, 15600, 15670, 15675) > rs <- sapply(x, function(x) ss2.(x,5000,10000)) Warning message: In ss2.(x, 5000, 10000) : x > E[X] + 3*sigma(X) -- result may not be good > cbind(t(rs), prob = sapply(x, function(x) pnchisqIT(x, 5000,10000)$prob)) i0 nT i1 i2 iN1 iN2 iMax prob [1,] 1 1 NA NA 1 1 1 0.000000e+00 [2,] 2596 4298 2596 4298 3499 4298 3907 1.697298e-137 [3,] 2596 5290 2880 5290 4358 5290 4810 2.625129e-06 [4,] 2596 5469 2953 5469 4459 5469 4921 1.212588e-02 [5,] 2596 5684 3031 5684 4560 5684 5044 4.838253e-01 [6,] 2596 5689 3032 5689 4562 5689 5047 5.016652e-01 [7,] 2596 5694 3034 5694 4564 5694 5049 5.194951e-01 [8,] 2596 5942 3116 5942 4675 5942 5251 9.867808e-01 [9,] 2596 5995 3134 5995 4701 5995 5301 9.960697e-01 [10,] 2596 6031 3146 6031 4719 6031 5336 9.984810e-01 [11,] 2596 6034 3147 6034 4721 6034 5338 9.985853e-01 Warning message: In pnchisqIT(x, 5000, 10000) : x > E[X] + 3*sigma(X) -- result may not be good > ## i0 nT i1 i2 iN1 iN2 iMax prob > ## 1 1 NA NA 1 1 1 0.000000e+00 > ## 2596 4298 2596 4298 3499 4298 3907 1.697298e-137 > ## 2596 5290 2880 5290 4358 5290 4810 2.625129e-06 > ## 2596 5469 2953 5469 4459 5469 4921 1.212588e-02 > ## 2596 5684 3031 5684 4560 5684 5044 4.838253e-01 > ## 2596 5689 3032 5689 4562 5689 5047 5.016652e-01 > ## 2596 5694 3034 5694 4564 5694 5049 5.194951e-01 > ## 2596 5942 3116 5942 4675 5942 5251 9.867808e-01 > ## 2596 5995 3134 5995 4701 5995 5301 9.960697e-01 > ## 2596 6031 3146 6031 4719 6031 5336 9.984810e-01 > ## 2596 6034 3147 6034 4721 6034 5338 9.985853e-01 << was "1.00" ! > > ## but we cannot go too far : > str(pp <- pnchisqIT(20000, 5000,10000)) List of 4 $ prob : num 1 $ i0 : int 3995 $ n.terms: int 8283 $ terms : num [1:8283] 0 0 0 0 0 0 0 0 0 0 ... Warning message: In pnchisqIT(20000, 5000, 10000) : x > E[X] + 3*sigma(X) -- result may not be good > ## $ prob : num 1 > ## $ i0 : int 3995 > ## $ n.terms: int 8283 > ## $ terms : num [1:8283] 0 0 0 0 0 0 0 0 0 0 ... > 1-pp$pr; 1-sum(sort(pp$terms)) [1] -1.17264e-11 [1] -1.172662e-11 > ## -8.999912e-12 > ## -8.999024e-12 > ## i.e. P > 1 is certainly not okay anymore! > ## E = df + ncp = 15000 > ## sigma = sqrt( 2*(df + 2*ncp)) = 223.607 > 5000 / sqrt( 2*(5000 + 2*10000)) [1] 22.36068 > ## = 22.36 i.e. 20'000 is 22.3 sigma out of E[] > > showProc.time() Time (user system elapsed): 0.08 0.08 0.16 > > set.seed(635) > ## 1st simulation --------------------------------------------------------------- > ## Collect data: --- this took about 2 hours on "nb-mm" (P III, 700 MHz) > ## takes 4.5 sec on ada-17 (or alo > nL <- 20 > nF <- 16 > nX <- length(pX <- c(0.01, (1:9)/10, 0.99, 0.9999)) > > sfil1 <- file.path(sdir, "tests_chisq-nonc-ssR.rds") > if(!doExtras && file.exists(sfil1)) { + ssR_l <- readRDS_(sfil1) + str(ssR_l) + ## dfs : num [1:16] 15.9 20.7 21 29.5 47.8 ... + ## lam : num [1:20] 5.74 8.26 8.34 8.64 10.12 ... + ## ssR : num [1:4, 1:20, 1:16, 1:12] 8.08 1 25 2 9.24 ... + loadList(ssR_l) + + } else { ## do run the simulation always if(doExtras) : + + lam <- sort(rlnorm(nL, 3, 1)) + dfs <- sort(rlnorm(nF, 4, 1)) + ssR <- array(NA, dim=c(1+3, nL,nF,nX), + dimnames = list(c("x","iN1","iN2", "iMax"), + lam = formatC(lam,digits=5), + df = formatC(dfs,digits=5), + x = formatC(pX, width=1))) + for(iL in 1:nL) { + lm <- lam[iL] + cat("lam=", formatC(lm),":") + for(iF in 1:nF) { + f <- dfs[iF] + x <- qchisq(pX, df=f, ncp=lm) + for(iX in 1:nX) + ssR[, iL,iF,iX] <- c(x[iX], ss2.(x[iX], df=f, ncp=lm)[5:7]) + cat(".") + }; cat("\n") + } + save2RDS(list_(lam, dfs, ssR), file = sfil1) + + } # {run simulation} Reading from D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe/tests_chisq-nonc-ssR.rds Time (user system elapsed): 0 0 0 List of 3 $ lam: num [1:20] 5.74 8.26 8.34 8.64 10.12 ... $ dfs: num [1:16] 15.9 20.7 21 29.5 47.8 ... $ ssR: num [1:4, 1:20, 1:16, 1:12] 8.08 1 25 2 9.24 ... ..- attr(*, "dimnames")=List of 4 .. ..$ : chr [1:4] "x" "iN1" "iN2" "iMax" .. ..$ lam: chr [1:20] "5.7401" "8.2607" "8.3435" "8.6395" ... .. ..$ df : chr [1:16] "15.912" "20.683" "21.041" "29.467" ... .. ..$ x : chr [1:12] "0.01" "0.1" "0.2" "0.3" ... > > x. <- ssR["x" ,,,] > iM <- ssR["iMax",,,] > iN1 <- ssR["iN1" ,,,] > iN2 <- ssR["iN2" ,,,] > iS <- iN2 - iN1 # the "index Spread": how many terms need to be summed > ## Visualize iM(x) for some (df,lambda): > Sel <- function(i) round(quantile(i, names=FALSE)) > > mult.fig(mfrow=c(5,5), ## << since length(quantile()) == 5 + marP = c(-1,-1,0,0))$old.par -> op > for(iL in Sel(1:nL)) { + lm <- lam[iL] + for(iF in Sel(1:nF)) { + f <- dfs[iF] + plot(x.[iL,iF,], + iM[iL,iF,], type = 'o', xlab = "x", ylab = "iMax", + main=paste("df=",formatC(f),", lam=",formatC(lm))) + } + } > par(op) > ##--> 1st order, qualitatively "same" function (x) > > ## Same plot, but using "Wienergerm's" sW(x,df,lam) instead of x > ## source("/u/maechler/R/MM/NUMERICS/dpq-functions/wienergerm_nchisq-fn.R") > mult.fig(mfrow=c(5,5), ## << since length(quantile()) == 5 + marP = c(-1,-1,0,0), main = "iMax vs. sW()")$old.par -> op > for(iL in Sel(1:nL)) { + lm <- lam[iL] + for(iF in Sel(1:nF)) { + f <- dfs[iF] + plot(sW(x.[iL,iF,], df=f, ncp=lm)$s, + iM[iL,iF,], type = 'o', xlab = "sW(x,...)", ylab = "iMax", + main=paste("df=",formatC(f),", lam=",formatC(lm))) + } + } > par(op) > ## very similar > showProc.time() Time (user system elapsed): 0.08 0.02 0.09 > > ###--- visualize 'iN1' = the first index *needed* : > ## Idea: use "current" algorithm (simply summing from i=1...) when ok : > > fCont <- function(ix = 6, kind = c("iN1","iN2","iMax", "d.i"), + pch=1, cex=.5, + sdat = ssR, + lam = as.numeric(dimnames(sdat)[["lam"]]), + dfs = as.numeric(dimnames(sdat)[["df"]]), + ## what a horrible hack .. + pX = as.numeric(dimnames(sdat)[["x"]]) + ) + { + ## Purpose: + ## ---------------------------------------------------------------------- + ## Arguments: + ## ---------------------------------------------------------------------- + ## Author: Martin Maechler, Date: 18 Feb 2004, 18:31 + kind <- match.arg(kind) + datname <- deparse(substitute(sdat)) + nx <- dim(sdat)[4] + if(ix < 1 || ix > nx) stop("'ix' must be in 1:",nx) + if(kind == "d.i") { + m <- sdat["iN2" ,,, ix] - sdat["iN1" ,,, ix] + mtxt <- paste("Spread ", datname,"[ 'iN2 - iN1' ,,, ", ix,"]", sep='') + } else { + m <- sdat[kind ,,, ix] + mtxt <- paste(datname,"[",kind," ,,, ", ix,"]", sep='') + } + mtxt <- paste(mtxt, " (i.e., x=", + formatC(100*pX[ix],digits=10,wid=1),"%-perc.)",sep='') + if(kind == "iN1") { + filled.contour(lam, dfs, m, + levels=c(1,2,3,5,10,15,20,30)-.01, + col = c("light gray", terrain.colors(6)), + plot.axes={ points(expand.grid(lam,dfs),cex=cex,pch=pch) + axis(1); axis(2)}, + plot.title={ title(mtxt, + xlab="ncp (lambda)",ylab="df (nu)")} + ) + } else { # automatic levels and color + filled.contour(lam, dfs, m, + color.palette = terrain.colors, + plot.axes={ points(expand.grid(lam,dfs),cex=cex,pch=pch) + axis(1); axis(2)}, + plot.title={ title(mtxt, + xlab="ncp (lambda)",ylab="df (nu)")} + ) + } + } > > par(.O.P.)# just in case for filled.contour() to work > fCont()# iN1, 6 > fCont(1)# iN1, 11 > fCont(kind="d", pch='.')## "spread" > fCont(kind="iN2", cex=.25)## practically == "spread" (i.e. iN1 ~= 0 !) > fCont(12, kind="iN2") > > showProc.time() Time (user system elapsed): 0.11 0 0.11 > > ## > ## 4th simulation: ---------------------------------------------------- > ## > ## pX: at these quantiles(), compute pnchisq() > nx <- length(pX <- c(0.01, (1:9)/10, 0.99, 0.9999, 1-1e-6, 1-1e-9)) > > sfil4 <- file.path(sdir, "tests_chisq-nonc-ssR4.rds") > if(!doExtras && file.exists(sfil4)) { + ssR_l <- readRDS_(sfil4) + str(ssR_l) + loadList(ssR_l) + } else { + set.seed(41) + ## smallish (lam,df) -- use several x --- ideally all these give "iN1"=1 + ss <- c(.1, .2, .5, 1:5, 7,10,15,c(2:6,8,10,12,15,20,30,50)*10) + nl <- length(lam4 <- ss) + nd <- length(dfs4 <- ss) + ## I use "round" numbers, and can pack all the info into ssR4's dimnames: + ssR4 <- array(NA, dim=c(1+ 3, nl,nd,nx), + dimnames = list(c("x", "iN1","iN2", "iMax"), + lam = formatC(lam4), + df = formatC(dfs4), + pr.x= ifelse(pX < 0.999, formatC(pX), + paste("1-", formatC(1-pX),sep='')))) + for(il in 1:nl) { + lm <- lam4[il] + for(id in 1:nd) { + f <- dfs4[id] + ## use more than one x per (df,lam) pair: + x <- qchisq(pX, df=f, ncp=lm) + for(ix in 1:nx) + ssR4[, il,id,ix] <- c(x[ix], ss2.(x[ix], df=f, ncp=lm)[5:7]) + cat(".") + }; cat(il,"") + }; cat("\n") + + save2RDS(list_(lam4, dfs4, ssR4), file=sfil4) + } Reading from D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe/tests_chisq-nonc-ssR4.rds Time (user system elapsed): 0.01 0 0.02 List of 3 $ lam4: num [1:23] 0.1 0.2 0.5 1 2 3 4 5 7 10 ... $ dfs4: num [1:23] 0.1 0.2 0.5 1 2 3 4 5 7 10 ... $ ssR4: num [1:4, 1:23, 1:23, 1:14] 3.18e-40 1.00 1.00 1.00 8.64e-40 ... ..- attr(*, "dimnames")=List of 4 .. ..$ : chr [1:4] "x" "iN1" "iN2" "iMax" .. ..$ lam : chr [1:23] "0.1" "0.2" "0.5" "1" ... .. ..$ df : chr [1:23] "0.1" "0.2" "0.5" "1" ... .. ..$ pr.x: chr [1:14] "0.01" "0.1" "0.2" "0.3" ... > > ## Compute the 'iMax' value that corresponds to x = E[X] = df + ncp > ## from that, with the above 'general f(x)', we can hopefully > ## get a good estimated iMax(x, df, ncp) ... > str(iM.E <- iM[,,1]) num [1:20, 1:16] 2 3 3 3 3 4 4 5 5 6 ... - attr(*, "dimnames")=List of 2 ..$ lam: chr [1:20] "5.7401" "8.2607" "8.3435" "8.6395" ... ..$ df : chr [1:16] "15.912" "20.683" "21.041" "29.467" ... > for(iL in 1:nL) { + lm <- lam[iL] + for(iF in 1:nF) { + f <- dfs[iF] + E <- f + lm # = E[X] + iM.E[iL,iF] <- approx(x.[iL,iF,], + iM[iL,iF,], xout = E)$y + } + } > > str(iM.E) num [1:20, 1:16] 5 6.41 6.41 6.4 7.39 ... - attr(*, "dimnames")=List of 2 ..$ lam: chr [1:20] "5.7401" "8.2607" "8.3435" "8.6395" ... ..$ df : chr [1:16] "15.912" "20.683" "21.041" "29.467" ... > > > > persp(lam, dfs, iM.E)# pretty linear.. > ##-> > filled.contour(lam, dfs, iM.E, xlab="ncp lambda", ylab="df nu") > ## indeed: very linear in "lambda / ncp", a bit less linear in "df: > dat1 <- cbind(expand.grid(lam,dfs), c(iM.E)) > names(dat1) <- c("ncp", "df", "iM") > summary(lm1 <- lm(iM ~ ncp + df, data = dat1)) ## R^2 = 99.79% Call: lm(formula = iM ~ ncp + df, data = dat1) Residuals: Min 1Q Median 3Q Max -3.09051 -0.49367 0.00851 0.41544 2.36925 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.9595201 0.0687625 43.04 <2e-16 *** ncp 0.5251609 0.0013463 390.07 <2e-16 *** df 0.0032560 0.0001173 27.75 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.7931 on 317 degrees of freedom Multiple R-squared: 0.9979, Adjusted R-squared: 0.9979 F-statistic: 7.646e+04 on 2 and 317 DF, p-value: < 2.2e-16 > with(dat1, p.res.2x(x=ncp,y=df, residuals(lm1))) # pretty structured.. > image (x=lam,y= dfs, array(residuals(lm1),dim=dim(iM.E))) > > summary(lm2 <- lm(iM ~ ncp * df, data = dat1)) ## R^2 = 99.84% Call: lm(formula = iM ~ ncp * df, data = dat1) Residuals: Min 1Q Median 3Q Max -1.79931 -0.44833 -0.01055 0.37676 2.26037 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 3.159e+00 6.392e-02 49.414 <2e-16 *** ncp 5.196e-01 1.319e-03 393.904 <2e-16 *** df 2.179e-03 1.520e-04 14.336 <2e-16 *** ncp:df 3.030e-05 3.135e-06 9.664 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.6979 on 316 degrees of freedom Multiple R-squared: 0.9984, Adjusted R-squared: 0.9984 F-statistic: 6.586e+04 on 3 and 316 DF, p-value: < 2.2e-16 > summary(lm3 <- lm(iM ~ poly(ncp, df, degree=2), data = dat1)) ## R^2 = 99.96% Call: lm(formula = iM ~ poly(ncp, df, degree = 2), data = dat1) Residuals: Min 1Q Median 3Q Max -1.36840 -0.21920 0.00659 0.25868 0.77677 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 22.23619 0.02003 1110.21 <2e-16 *** poly(ncp, df, degree = 2)1.0 309.34888 0.35829 863.41 <2e-16 *** poly(ncp, df, degree = 2)2.0 -3.94391 0.35829 -11.01 <2e-16 *** poly(ncp, df, degree = 2)0.1 22.00747 0.35829 61.42 <2e-16 *** poly(ncp, df, degree = 2)1.1 120.63989 6.40920 18.82 <2e-16 *** poly(ncp, df, degree = 2)0.2 -9.90114 0.35829 -27.64 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.3583 on 314 degrees of freedom Multiple R-squared: 0.9996, Adjusted R-squared: 0.9996 F-statistic: 1.501e+05 on 5 and 314 DF, p-value: < 2.2e-16 > > ## Using sqrt() -- not really better (and predict/fitted is failing !? FIXME !! > summary(lm3s <- lm(sqrt(iM) ~ poly(ncp, df, degree=2), data = dat1)) Call: lm(formula = sqrt(iM) ~ poly(ncp, df, degree = 2), data = dat1) Residuals: Min 1Q Median 3Q Max -0.28083 -0.08010 0.01017 0.07933 0.18733 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 4.40572 0.00554 795.195 <2e-16 *** poly(ncp, df, degree = 2)1.0 29.52898 0.09911 297.941 <2e-16 *** poly(ncp, df, degree = 2)2.0 -4.66293 0.09911 -47.048 <2e-16 *** poly(ncp, df, degree = 2)0.1 2.43251 0.09911 24.544 <2e-16 *** poly(ncp, df, degree = 2)1.1 -1.67471 1.77293 -0.945 0.346 poly(ncp, df, degree = 2)0.2 -1.24791 0.09911 -12.591 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.09911 on 314 degrees of freedom Multiple R-squared: 0.9966, Adjusted R-squared: 0.9965 F-statistic: 1.835e+04 on 5 and 314 DF, p-value: < 2.2e-16 > > with(dat1, p.res.2x(x=ncp,y=df, residuals(lm3))) # pretty structured.. > image (x=lam,y= dfs, array(residuals(lm3),dim=dim(iM.E))) > > library(mgcv) Loading required package: nlme This is mgcv 1.9-1. For overview type 'help("mgcv-package")'. > summary(gam1. <- gam(iM ~ s(ncp) + s(df), data = dat1)) Family: gaussian Link function: identity Formula: iM ~ s(ncp) + s(df) Parametric coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 22.23619 0.02657 836.8 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Approximate significance of smooth terms: edf Ref.df F p-value s(ncp) 3.944 4.811 88040.5 <2e-16 *** s(df) 4.194 4.664 564.4 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 R-sq.(adj) = 0.999 Deviance explained = 99.9% GCV = 0.23259 Scale est. = 0.22595 n = 320 > ## df = 1 + 4 + 4; R^2 = 0.999; s^ = 0.226 > summary(gam1.2 <- gam(iM ~ ncp + s(df), data = dat1)) Family: gaussian Link function: identity Formula: iM ~ ncp + s(df) Parametric coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 3.5616511 0.0435626 81.76 <2e-16 *** ncp 0.5251609 0.0008989 584.26 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Approximate significance of smooth terms: edf Ref.df F p-value s(df) 4.094 4.556 465.5 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 R-sq.(adj) = 0.999 Deviance explained = 99.9% GCV = 0.28579 Scale est. = 0.28034 n = 320 > ## df = 2 + 4 ; R^2 = 0.999; s^ = 0.280 > plot(gam1.2) #pretty square > > summary(gam2. <- gam(iM ~ s(ncp, df), data = dat1)) ## 100% explained, Family: gaussian Link function: identity Formula: iM ~ s(ncp, df) Parametric coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 22.23619 0.01423 1562 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Approximate significance of smooth terms: edf Ref.df F p-value s(ncp,df) 26.29 28.49 52174 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 R-sq.(adj) = 1 Deviance explained = 100% GCV = 0.070864 Scale est. = 0.064821 n = 320 > ## but equiv.deg.freedom = 1+26.3 > if(FALSE)## FAILS + summary(gam2.10 <- gam(iM ~ s(ncp, df, 10), data = dat1)) > ## df = 1 + 9 ; R^2 = 1.000; s^ = 0.107 > with(dat1, p.res.2x(x=ncp,y=df, residuals(gam2.))) > ## ok, but > plot(fitted(gam2.), fitted(lm3)) ; abline(0,1,col=3) > ## suggesting the quadratic fit being quite ok. > > ## OTOH, I do need an explicit formula; > ## a simple 2d- regression spline instead of quadratic? > > showProc.time() Time (user system elapsed): 1.31 0.09 1.41 > > ###---- 2nd "simulation": -- only go for one x = E[] > nSim <- if(doExtras) 5000 else 500 > sfil2 <- file.path(sdir, "tests_chisq-nonc-ssR2.rds") > if(!doExtras && file.exists(sfil2)) { + ssR2 <- readRDS_(sfil2) + } else { + set.seed(2) + lam <- rlnorm(nSim, 5, 2) + dfs <- rlnorm(nSim, 6, 1.5) + ssR2 <- rbind(rbind(lam,dfs), matrix(NA, 3, nSim)) + for(i in 1:nSim) { + lm <- lam[i] + f <- dfs[i] + x <- f + lm + ssR2[3:5, i] <- ss2.(x, df=f, ncp=lm)[5:7] + cat("."); if(i %% 100 == 0) cat("\n",i) + } + dimnames(ssR2) <- list(c("lam","df","iN1","iN2", "iMax"),NULL) + ssR2 <- t(ssR2) + ssR2 <- ssR2[sort.list(ssR2[,"lam"]),] + save2RDS(ssR2, file=sfil2) + } Reading from D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe/tests_chisq-nonc-ssR2.rds Time (user system elapsed): 0.02 0 0.01 > > ## 3rd simulation: --- this takes a little while (1 min ?) > sfil3 <- file.path(sdir, "tests_chisq-nonc-ssR3.rds") > if(!doExtras && file.exists(sfil3)) { + ssR3_l <- readRDS_(sfil3) + str(ssR3_l) + loadList(ssR3_l) + } else { + set.seed(31) + ss <- c(20,50, c(1:8,10,13,18,25)*100, 3000) + nl <- length(lam3 <- c(ss, seq(5000, 100000, length=1+ 4*19))) + nd <- length(dfs3 <- c(ss, seq(5000, 100000, length=1+ 2*19))) + ssR3 <- array(NA, dim=c(3, nl,nd), + dimnames = list(c("iN1","iN2", "iMax"), + formatC(lam3), formatC(dfs3))) + for(il in 1:nl) { + lm <- lam3[il] + for(id in 1:nd) { + f <- dfs3[id] + x <- f + lm + ssR3[, il,id] <- ss2.(x, df=f, ncp=lm)[5:7] + }; cat(il,"") + }; cat("\n") + save2RDS(list_(lam3, dfs3, ssR3), file=sfil3) + } Reading from D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe/tests_chisq-nonc-ssR3.rds Time (user system elapsed): 0 0 0 List of 3 $ lam3: num [1:92] 20 50 100 200 300 400 500 600 700 800 ... $ dfs3: num [1:54] 20 50 100 200 300 400 500 600 700 800 ... $ ssR3: num [1:3, 1:92, 1:54] 1 58 13 2 84 29 15 124 54 48 ... ..- attr(*, "dimnames")=List of 3 .. ..$ : chr [1:3] "iN1" "iN2" "iMax" .. ..$ : chr [1:92] "20" "50" "100" "200" ... .. ..$ : chr [1:54] "20" "50" "100" "200" ... > showProc.time() Time (user system elapsed): 0 0 0 > > ### now change these "3" values into a data.frame as this one: > dsR2 <- as.data.frame(ssR2) > > ## > d3 <- dim(ssR3) > ss3 <- matrix(ssR3, d3[1], prod(d3[2:3])) > dsR3 <- cbind(expand.grid(lam = lam3, df = dfs3), t(ss3)) > colnames(dsR3)[3:5] <- dimnames(ssR3)[[1]] > > dsR <- rbind(dsR2, dsR3) > rownames(dsR) <- paste(1:nrow(dsR)) > ## visualize "design space": > iOutl <- c(648, 1841, 5000) > plot(df ~ lam, data =dsR, log = "xy") > points(dsR[iOutl,], col=2:4, cex=2) > dsR[iOutl,] lam df iN1 iN2 iMax 648 16.32139 62195.04309 1 1384 20 1841 81.71060 77189.82611 3 1570 62 5000 176268.15639 24.16364 86431 90423 88285 > > plot(df ~ lam, data =dsR, log = "") > points(dsR[iOutl,], col=2:4, cex=2) > points(dsR[4997:5000,], col="gray", cex=2, pch=3) > > with(dsR, which(lam > 100000))# 4998, 4999, 5000 [1] 4998 4999 5000 > ## -- leave these away for the regression (high leverage!) > str(dsR. <- subset(dsR, lam <= 100000)) 'data.frame': 9965 obs. of 5 variables: $ lam : num 0.0428 0.0577 0.1234 0.1538 0.2609 ... $ df : num 1431.8 268.4 1362.6 84.9 32 ... $ iN1 : num 1 1 1 1 1 1 1 1 1 1 ... $ iN2 : num 225 105 220 64 44 280 252 99 114 32 ... $ iMax: num 2 2 2 2 2 3 3 3 3 2 ... > > summary(l.1 <- lm(iMax ~ lam, data=dsR.))## R^2(adj) = 1; s^ = 23.73 Call: lm(formula = iMax ~ lam, data = dsR.) Residuals: Min 1Q Median 3Q Max -52.554 -14.354 -8.112 7.941 74.551 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.142e+01 2.936e-01 72.97 <2e-16 *** lam 5.015e-01 7.627e-06 65745.30 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 23.77 on 9963 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 4.322e+09 on 1 and 9963 DF, p-value: < 2.2e-16 > summary(l.2 <- lm(iMax ~ lam + df, data=dsR.))## s^ = 12.49 Call: lm(formula = iMax ~ lam + df, data = dsR.) Residuals: Min 1Q Median 3Q Max -75.278 -7.399 -2.252 8.405 28.914 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.363e+01 1.611e-01 84.6 <2e-16 *** lam 5.011e-01 4.414e-06 113528.6 <2e-16 *** df 7.462e-04 4.598e-06 162.3 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 12.45 on 9962 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 7.874e+09 on 2 and 9962 DF, p-value: < 2.2e-16 > summary(l.3 <- lm(iMax ~ lam * df, data=dsR.))## s^ = 12.22 Call: lm(formula = iMax ~ lam * df, data = dsR.) Residuals: Min 1Q Median 3Q Max -83.077 -6.717 -1.716 7.944 27.166 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.266e+01 1.660e-01 76.22 <2e-16 *** lam 5.012e-01 5.470e-06 91634.79 <2e-16 *** df 8.340e-04 6.403e-06 130.25 <2e-16 *** lam:df -2.621e-09 1.356e-10 -19.33 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 12.23 on 9961 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 5.446e+09 on 3 and 9961 DF, p-value: < 2.2e-16 > summary(l.4 <- lm(iMax ~ lam * df+ I(lam^2), data=dsR.))## s^ = 8.251 Call: lm(formula = iMax ~ lam * df + I(lam^2), data = dsR.) Residuals: Min 1Q Median 3Q Max -62.680 -4.496 -1.107 4.044 25.874 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.018e+01 1.145e-01 88.849 <2e-16 *** lam 5.023e-01 1.041e-05 48271.714 <2e-16 *** df 6.546e-04 4.633e-06 141.295 <2e-16 *** I(lam^2) -1.357e-08 1.248e-10 -108.775 <2e-16 *** lam:df 1.062e-10 9.503e-11 1.118 0.264 --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 8.266 on 9960 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 8.935e+09 on 4 and 9960 DF, p-value: < 2.2e-16 > summary(l.5 <- lm(iMax ~ lam * df+ I(lam^2)+I(df^2), data=dsR.))#s^= 7.812 Call: lm(formula = iMax ~ lam * df + I(lam^2) + I(df^2), data = dsR.) Residuals: Min 1Q Median 3Q Max -53.045 -4.419 -0.891 4.129 20.800 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 9.552e+00 1.095e-01 87.264 < 2e-16 *** lam 5.022e-01 1.002e-05 50134.932 < 2e-16 *** df 9.984e-04 1.068e-05 93.447 < 2e-16 *** I(lam^2) -1.316e-08 1.182e-10 -111.267 < 2e-16 *** I(df^2) -4.340e-09 1.231e-10 -35.265 < 2e-16 *** lam:df 6.237e-10 9.080e-11 6.868 6.88e-12 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 7.794 on 9959 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 8.04e+09 on 5 and 9959 DF, p-value: < 2.2e-16 > ## Estimate Std. Error t value Pr(>|t|) > ## (Intercept) 9.437e+00 1.105e-01 85.42 < 2e-16 > ## lam 5.022e-01 1.034e-05 48573.09 < 2e-16 > ## df 9.861e-04 1.095e-05 90.03 < 2e-16 > ## I(lam^2) -1.333e-08 1.219e-10 -109.39 < 2e-16 > ## I(df^2) -4.202e-09 1.257e-10 -33.44 < 2e-16 > ## lam:df 6.433e-10 9.405e-11 6.84 8.42e-12 > summary(l.6 <- update(l.5, . ~ . + log(lam)))## R^2(adj) = 1; s^ = 6.135 (7 p) Call: lm(formula = iMax ~ lam + df + I(lam^2) + I(df^2) + log(lam) + lam:df, data = dsR.) Residuals: Min 1Q Median 3Q Max -40.885 -3.428 -0.544 3.163 18.994 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -7.547e+00 2.322e-01 -32.50 <2e-16 *** lam 5.015e-01 1.146e-05 43769.58 <2e-16 *** df 9.018e-04 8.456e-06 106.64 <2e-16 *** I(lam^2) -8.417e-09 1.102e-10 -76.35 <2e-16 *** I(df^2) -3.899e-09 9.653e-11 -40.39 <2e-16 *** log(lam) 3.408e+00 4.301e-02 79.24 <2e-16 *** lam:df 1.553e-09 7.208e-11 21.55 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 6.104 on 9958 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.092e+10 on 6 and 9958 DF, p-value: < 2.2e-16 > ## Estimate Std. Error t value Pr(>|t|) > ## (Intercept) -7.477e+00 2.348e-01 -31.85 <2e-16 > ## lam 5.016e-01 1.179e-05 42528.90 <2e-16 > ## df 8.951e-04 8.681e-06 103.11 <2e-16 > ## I(lam^2) -8.579e-09 1.137e-10 -75.48 <2e-16 > ## I(df^2) -3.804e-09 9.881e-11 -38.50 <2e-16 > ## log(lam) 3.391e+00 4.373e-02 77.54 <2e-16 > ## lam:df 1.546e-09 7.477e-11 20.68 <2e-16 > summary(l.7 <- update(l.5, . ~ . + log(lam)*log(df)))## s^ = 5.389 (9 p) Call: lm(formula = iMax ~ lam + df + I(lam^2) + I(df^2) + log(lam) + log(df) + lam:df + log(lam):log(df), data = dsR.) Residuals: Min 1Q Median 3Q Max -33.991 -2.915 -0.641 2.745 25.175 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 6.323e+00 5.735e-01 11.025 < 2e-16 *** lam 5.014e-01 1.039e-05 48238.492 < 2e-16 *** df 5.170e-04 1.172e-05 44.123 < 2e-16 *** I(lam^2) -7.137e-09 1.006e-10 -70.949 < 2e-16 *** I(df^2) -6.480e-10 1.102e-10 -5.883 4.17e-09 *** log(lam) 6.437e-02 8.100e-02 0.795 0.427 log(df) -2.072e+00 8.675e-02 -23.882 < 2e-16 *** lam:df -1.110e-10 7.460e-11 -1.487 0.137 log(lam):log(df) 5.323e-01 1.143e-02 46.579 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.376 on 9956 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.056e+10 on 8 and 9956 DF, p-value: < 2.2e-16 > ##- Estimate Std. Error t value Pr(>|t|) > ##- (Intercept) 6.315e+00 5.773e-01 10.938 < 2e-16 *** > ##- lam 5.014e-01 1.066e-05 47049.885 < 2e-16 *** > ##- df 4.992e-04 1.204e-05 41.449 < 2e-16 *** > ##- I(lam^2) -7.278e-09 1.034e-10 -70.356 < 2e-16 *** > ##- I(df^2) -4.404e-10 1.131e-10 -3.893 9.98e-05 *** > ##- log(lam) 4.249e-02 8.164e-02 0.520 0.6028 > ##- log(df) -2.062e+00 8.728e-02 -23.628 < 2e-16 *** > ##- lam:df -1.775e-10 7.703e-11 -2.305 0.0212 * > ##- log(lam):log(df) 5.348e-01 1.151e-02 46.476 < 2e-16 *** > > drop1(l.7)# cannot drop non-sign. log(lam) Single term deletions Model: iMax ~ lam + df + I(lam^2) + I(df^2) + log(lam) + log(df) + lam:df + log(lam):log(df) Df Sum of Sq RSS AIC 287692 33528 I(lam^2) 1 145457 433149 37604 I(df^2) 1 1000 288692 33561 lam:df 1 64 287756 33529 log(lam):log(df) 1 62693 350385 35491 > summary(l.8 <- update(l.7, . ~ . - log(lam)))## s^ = 5.389 (8 p) Call: lm(formula = iMax ~ lam + df + I(lam^2) + I(df^2) + log(df) + lam:df + log(lam):log(df), data = dsR.) Residuals: Min 1Q Median 3Q Max -33.933 -2.920 -0.659 2.752 25.309 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 6.714e+00 2.941e-01 22.831 < 2e-16 *** lam 5.014e-01 1.032e-05 48604.390 < 2e-16 *** df 5.150e-04 1.143e-05 45.062 < 2e-16 *** I(lam^2) -7.138e-09 1.006e-10 -70.968 < 2e-16 *** I(df^2) -6.251e-10 1.063e-10 -5.880 4.24e-09 *** log(df) -2.122e+00 5.902e-02 -35.960 < 2e-16 *** lam:df -1.420e-10 6.351e-11 -2.237 0.0253 * log(df):log(lam) 5.403e-01 5.344e-03 101.117 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.375 on 9957 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.207e+10 on 7 and 9957 DF, p-value: < 2.2e-16 > summary(l.9 <- update(l.8, . ~ . - lam:df)) ## s^ = 5.391 (7 p) Call: lm(formula = iMax ~ lam + df + I(lam^2) + I(df^2) + log(df) + log(df):log(lam), data = dsR.) Residuals: Min 1Q Median 3Q Max -33.481 -2.942 -0.702 2.700 25.723 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 6.679e+00 2.937e-01 22.738 < 2e-16 *** lam 5.014e-01 1.026e-05 48858.261 < 2e-16 *** df 5.117e-04 1.134e-05 45.132 < 2e-16 *** I(lam^2) -7.200e-09 9.671e-11 -74.451 < 2e-16 *** I(df^2) -6.501e-10 1.057e-10 -6.147 8.19e-10 *** log(df) -2.102e+00 5.833e-02 -36.035 < 2e-16 *** log(df):log(lam) 5.386e-01 5.290e-03 101.820 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.377 on 9958 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.408e+10 on 6 and 9958 DF, p-value: < 2.2e-16 > summary(l.10<- update(l.9, . ~ . - I(df^2))) ## s^ = 5.396 (6 p) Call: lm(formula = iMax ~ lam + df + I(lam^2) + log(df) + log(df):log(lam), data = dsR.) Residuals: Min 1Q Median 3Q Max -34.262 -2.885 -0.737 2.631 26.129 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 5.795e+00 2.566e-01 22.58 <2e-16 *** lam 5.014e-01 1.027e-05 48834.13 <2e-16 *** df 4.451e-04 3.331e-06 133.64 <2e-16 *** I(lam^2) -7.180e-09 9.683e-11 -74.15 <2e-16 *** log(df) -1.966e+00 5.407e-02 -36.36 <2e-16 *** log(df):log(lam) 5.444e-01 5.215e-03 104.39 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.386 on 9959 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.683e+10 on 5 and 9959 DF, p-value: < 2.2e-16 > summary(l.11<- update(l.10, . ~ . - I(lam^2)))## s^ = 5.396 (6 p) Call: lm(formula = iMax ~ lam + df + log(df) + log(df):log(lam), data = dsR.) Residuals: Min 1Q Median 3Q Max -30.403 -4.728 -0.731 4.241 34.466 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 8.289e+00 3.170e-01 26.15 <2e-16 *** lam 5.007e-01 3.857e-06 129796.17 <2e-16 *** df 4.207e-04 4.129e-06 101.90 <2e-16 *** log(df) -3.276e+00 6.366e-02 -51.46 <2e-16 *** log(df):log(lam) 7.675e-01 5.307e-03 144.62 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 6.71 on 9960 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.356e+10 on 4 and 9960 DF, p-value: < 2.2e-16 > summary(l.12<- update(l.11, . ~ . + log(lam)))## s^ = 5.396 (6 p) Call: lm(formula = iMax ~ lam + df + log(df) + log(lam) + log(df):log(lam), data = dsR.) Residuals: Min 1Q Median 3Q Max -32.676 -4.647 -0.595 4.245 35.132 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.742e+00 6.192e-01 4.429 9.58e-06 *** lam 5.007e-01 3.838e-06 130442.085 < 2e-16 *** df 4.346e-04 4.317e-06 100.674 < 2e-16 *** log(df) -2.570e+00 9.283e-02 -27.682 < 2e-16 *** log(lam) 8.656e-01 8.317e-02 10.408 < 2e-16 *** log(df):log(lam) 6.603e-01 1.158e-02 57.044 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 6.674 on 9959 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 1.096e+10 on 5 and 9959 DF, p-value: < 2.2e-16 > > ## dsR3 instead of dsR. : > summary(l.13<- lm(iMax ~ lam*df+ log(lam)*log(df), data=dsR3)) Call: lm(formula = iMax ~ lam * df + log(lam) * log(df), data = dsR3) Residuals: Min 1Q Median 3Q Max -24.6763 -3.1236 -0.0293 3.6032 27.2376 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -8.455e+00 2.361e+00 -3.581 0.000345 *** lam 5.005e-01 5.746e-06 87102.598 < 2e-16 *** df 5.328e-04 6.179e-06 86.213 < 2e-16 *** log(lam) 4.400e+00 2.474e-01 17.782 < 2e-16 *** log(df) -5.096e+00 2.581e-01 -19.749 < 2e-16 *** lam:df -5.404e-10 1.015e-10 -5.325 1.05e-07 *** log(lam):log(df) 7.357e-01 2.522e-02 29.164 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.687 on 4961 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 6.489e+09 on 6 and 4961 DF, p-value: < 2.2e-16 > summary(l.14<- update(l.13, . ~ . - lam:df)) Call: lm(formula = iMax ~ lam + df + log(lam) + log(df) + log(lam):log(df), data = dsR3) Residuals: Min 1Q Median 3Q Max -24.0045 -3.1072 -0.0806 3.7799 26.9847 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -1.579e+01 1.922e+00 -8.216 2.65e-16 *** lam 5.005e-01 4.256e-06 117584.328 < 2e-16 *** df 5.089e-04 4.274e-06 119.063 < 2e-16 *** log(lam) 5.232e+00 1.925e-01 27.177 < 2e-16 *** log(df) -4.218e+00 1.991e-01 -21.192 < 2e-16 *** log(lam):log(df) 6.472e-01 1.903e-02 34.015 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.702 on 4962 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 7.744e+09 on 5 and 4962 DF, p-value: < 2.2e-16 > summary(l.15<- update(l.14, . ~ . - 1)) Call: lm(formula = iMax ~ lam + df + log(lam) + log(df) + log(lam):log(df) - 1, data = dsR3) Residuals: Min 1Q Median 3Q Max -23.2654 -3.1550 -0.1025 3.8678 25.5473 Coefficients: Estimate Std. Error t value Pr(>|t|) lam 5.005e-01 4.199e-06 119172.03 <2e-16 *** df 5.149e-04 4.241e-06 121.40 <2e-16 *** log(lam) 3.706e+00 5.124e-02 72.32 <2e-16 *** log(df) -5.773e+00 6.228e-02 -92.70 <2e-16 *** log(lam):log(df) 7.913e-01 7.402e-03 106.91 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 5.741 on 4963 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 2.242e+10 on 5 and 4963 DF, p-value: < 2.2e-16 > > with(dsR3, p.res.2x(lam, df, residuals(l.15))) > ## ok; it's really the low 'lam' (and the low 'df') > if(doExtras) { ##-> try more ----------------------------------- + iMaxR3 <- matrix(dsR3$iMax, length(lam3)) + persp (log10(lam3), log10(dfs3), iMaxR3/ (lam3/2)) + persp (log10(lam3), log10(dfs3), log10(iMaxR3/ (lam3/2))) + filled.contour(log10(lam3), log10(dfs3), iMaxR3/ (lam3/2), + plot.title = { + contour(log10(lam3), log10(dfs3), iMaxR3/ (lam3/2),add=TRUE) + title(main = "iMax / (lam/2) ['dsR3' data]", + xlab = "log10(lam)", ylab = "log10(df)") + ##points(expand.grid(log10(lam3), log10(dfs3)), pch='.') + with(dsR3, points(log10(lam), log10(df), pch='.')) + }) + ## almost same with log(iMax / (lam/2)): + filled.contour(log10(lam3), log10(dfs3), log10(iMaxR3/ (lam3/2)), + plot.title = { + contour(log10(lam3), log10(dfs3), log10(iMaxR3/ (lam3/2)),add=TRUE) + title(main = "log10(iMax / (lam/2)) ['dsR3' data]", + xlab = "log10(lam)", ylab = "log10(df)") + ##points(expand.grid(log10(lam3), log10(dfs3)), pch='.') + with(dsR3, points(log10(lam), log10(df), pch='.')) + }) + } #-- only if(doExtras) ------------------------------------- > > showProc.time() Time (user system elapsed): 1 0.06 1.06 > > if(doExtras && require("interp")) { + ## same with both data --> need interp ! : s/dsR3/dsR./ : + ds1 <- subset(dsR., lam >= 1) + sr.I <- with(ds1, interp(log(lam), log(df), iMax)) + sr.Iq <- with(ds1, interp(log(lam), log(df), iMax / (lam/2))) + filled.contour(sr.I, xlab="ln(lam)", ylab="ln(df)", main="iMax") + filled.contour(sr.Iq, + plot.title = { + contour(sr.Iq, add=TRUE) + title(main = "iMax / (lam/2) ['ds1' data]", + xlab = "ln(lam)", ylab = "ln(df)") + with(ds1, points(log(lam), log(df), pch='.')) + }) + print(summary(l.q1 <- lm(iMax / (lam/2) ~ log(lam) * log(df), data= ds1))) + TA.plot(l.q1) + plot(resid(l.q1) ~ lam, data=ds1, pch ='.', log = 'x') + print(summary(l.q2 <- update(l.q1, .~. + I(1/lam)))) + print(summary(l.q3 <- update(l.q2, .~. + I(log(lam)^2) + I(1/log(lam))))) + plot(resid(l.q3) ~ lam, data=ds1, pch ='.', log = 'x') + ### --> Aha! 1/lam seems the best term !! + with(dsR., p.res.2x(lam, df, residuals(l.q3), scol=2:3)) + ## -- maybe try lam^(-a) ? + showProc.time() # 0.9 + } # only if(.X.) > > ## This is impressive (but shows "non-fit") > with(dsR., p.res.2x(log10(lam), log10(df), residuals(l.5), scol=2:3)) > with(dsR., p.res.2x(lam, df, residuals(l.5))) > > with(dsR., p.res.2x(lam, df, residuals(l.10), scol=2:3)) > with(dsR., p.res.2x(log(lam), log(df), residuals(l.6), scol=2:3)) > > plot(l.5, ask=FALSE) ## 2-3 outliers: > ## 5000 : maximal lambda > ## 1841 : maximal df > > if(doExtras) withAutoprint({ # ----------------------------------- + ### Yet another idea: + summary(lq2 <- lm(I(iMax/lam) ~ (lam+ log(lam) + df + log(df))^2, data=dsR.)) + lq2s <- step(lq2) + summary(lq2s, corr=TRUE, symb=TRUE) + ## shows the complete non-sense (large lambda values fit very badly + with(dsR., n.plot(fitted(lq2s)*lam, iMax)) + + if(doExtras)## GAM -- needs tons of cpu + memory: + summary(g.5 <- gam(iMax ~ s(lam) + s(df) + s(lam,df), data=dsR.))#s^=4.489 + ## -> (too) many deg.freedom s + }) #-------------------------------------------- > > showProc.time() Time (user system elapsed): 1.66 0.1 1.75 > > > if(doExtras && require("interp")) { ## visualize more: ---------- + sr2I <- with(dsR., interp(log(lam), log(df), iMax)) + filled.contour(sr2I, xlab="ln(lam)", ylab="ln(df)", main="iMax") + sr2I <- with(dsR., interp(log(lam), log(df), log(iMax))) + sr2I <- with(dsR., interp(log(lam), log(df), log(iN2))) + filled.contour(sr2I, xlab="ln(lam)", ylab="ln(df)", main="ln(iN2)") + ## linear for large lambda + persp(sr2I,xlab="log(lam)", ylab="log(df)",zlab="log(iMax)",ticktype="detailed") + + ## restrict on those where iN1 > 1 + str(dsR2r <- subset(dsR2, iN1 > 1))# only 3383 instead of 5000 + + sr2I <- with(dsR., interp((lam), (df), (iN2))) + filled.contour(sr2I, xlab="(lam)", ylab="(df)", main="(iN2)") + ## Looks *very* nicely linear + persp(sr2I,xlab="(lam)", ylab="(df)",zlab="(iMax)",ticktype="detailed") + + ## + sr2I <- with(dsR., interp((lam), (df), iMax/lam)) + filled.contour(sr2I, xlab="(lam)", ylab="(df)", main="iMax/lam") + persp(sr2I,xlab="(lam)", ylab="(df)",zlab="iMax/lam",ticktype="detailed") + + ## restrict on those where iN1 > 1 + str(dsR.r <- subset(dsR., iN1 > 1)) + + sr2rI <- with(dsR.r, interp((lam), (df), (iN2))) + persp(sr2rI,xlab="(lam)",ylab="(df)",zlab="(iN2)",ticktype="detailed") + sr2rI <- with(dsR.r, interp(log(lam), log(df), log(iN2))) + persp(sr2rI,xlab="log(lam)",ylab="log(df)",zlab="log(iN2)",ticktype="detailed") + + sr2rI <- with(dsR.r, interp(log(lam), log(df), log(iMax))) + persp(sr2rI,xlab="log(lam)",ylab="log(df)",zlab="log(iMax)",ticktype="detailed") + } else { + cat("Define dsR2r : \n") ; str(dsR2r <- subset(dsR., iN1 > 1)) + cat("and also dsR.r : \n") ; str(dsR.r <- subset(dsR., iN1 > 1)) + } Define dsR2r : 'data.frame': 8241 obs. of 5 variables: $ lam : num 42.8 46.7 49.6 52.2 52.7 ... $ df : num 2.91 13.18 12.77 9 6.77 ... $ iN1 : num 2 2 2 3 3 3 2 3 2 2 ... $ iN2 : num 72 79 82 82 82 83 89 86 95 94 ... $ iMax: num 24 27 28 29 30 30 31 30 32 31 ... and also dsR.r : 'data.frame': 8241 obs. of 5 variables: $ lam : num 42.8 46.7 49.6 52.2 52.7 ... $ df : num 2.91 13.18 12.77 9 6.77 ... $ iN1 : num 2 2 2 3 3 3 2 3 2 2 ... $ iN2 : num 72 79 82 82 82 83 89 86 95 94 ... $ iMax: num 24 27 28 29 30 30 31 30 32 31 ... > showProc.time() Time (user system elapsed): 0.03 0 0.04 > summary(ll.2 <- lm(log(iMax) ~ log(lam) + log(df), data=dsR.r)) Call: lm(formula = log(iMax) ~ log(lam) + log(df), data = dsR.r) Residuals: Min 1Q Median 3Q Max -0.040675 -0.025633 -0.005255 0.013155 0.245732 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -0.5056127 0.0014718 -343.53 <2e-16 *** log(lam) 0.9754184 0.0001795 5435.59 <2e-16 *** log(df) 0.0081810 0.0001698 48.19 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.03449 on 8238 degrees of freedom Multiple R-squared: 0.9998, Adjusted R-squared: 0.9998 F-statistic: 2.026e+07 on 2 and 8238 DF, p-value: < 2.2e-16 > summary(ll.3 <- lm(log(iMax) ~ log(lam) * log(df), data=dsR.r)) Call: lm(formula = log(iMax) ~ log(lam) * log(df), data = dsR.r) Residuals: Min 1Q Median 3Q Max -0.049577 -0.023999 -0.001019 0.018029 0.200513 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -6.517e-01 4.270e-03 -152.61 <2e-16 *** log(lam) 9.930e-01 5.136e-04 1933.19 <2e-16 *** log(df) 2.858e-02 5.866e-04 48.73 <2e-16 *** log(lam):log(df) -2.332e-03 6.458e-05 -36.11 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.03205 on 8237 degrees of freedom Multiple R-squared: 0.9998, Adjusted R-squared: 0.9998 F-statistic: 1.565e+07 on 3 and 8237 DF, p-value: < 2.2e-16 > summary(ll.4 <- lm(log(iMax) ~ log(lam) * log(df) + I(log(lam)^2), data=dsR.r)) Call: lm(formula = log(iMax) ~ log(lam) * log(df) + I(log(lam)^2), data = dsR.r) Residuals: Min 1Q Median 3Q Max -0.034035 -0.010425 0.000300 0.005038 0.105993 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -3.140e-01 2.786e-03 -112.7 <2e-16 *** log(lam) 8.842e-01 6.731e-04 1313.6 <2e-16 *** log(df) 4.488e-02 2.886e-04 155.5 <2e-16 *** I(log(lam)^2) 7.558e-03 4.374e-05 172.8 <2e-16 *** log(lam):log(df) -4.233e-03 3.198e-05 -132.4 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.0149 on 8236 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 5.428e+07 on 4 and 8236 DF, p-value: < 2.2e-16 > plot(residuals(ll.2) ~ dsR.r$lam, log='x') > plot(residuals(ll.3) ~ dsR.r$lam, log='x') > plot(residuals(ll.4) ~ dsR.r$lam, log='x') > plot(dsR.r$iMax - exp(fitted(ll.4)) ~ dsR.r$lam, log='x') > > if(doExtras) { + summary(gl.4 <- gam(log(iMax) ~ s(lam) + log(df), data=dsR.r))## very bad + ## but this is very good: + summary(gl.4 <- gam(log(iMax) ~ s(log(lam)) + log(df), data = dsR.r)) + plot(gl.4, ask=FALSE) + if(FALSE) { # fails now + summary(gl.5 <- gam(log(iMax) ~ s(log(lam),4) + log(df)*log(lam), data=dsR.r)) + plot(gl.5, ask=FALSE) + } + } # only if(.X.) > ##-> try > summary(ll.5 <- lm(log(iMax) ~ (log(lam) + poly(pmax(0,log(lam)-5),2))*log(df), + data=dsR.r)) Call: lm(formula = log(iMax) ~ (log(lam) + poly(pmax(0, log(lam) - 5), 2)) * log(df), data = dsR.r) Residuals: Min 1Q Median 3Q Max -0.027548 -0.005987 -0.000237 0.005372 0.112109 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) -0.7432624 0.0229196 -32.429 < 2e-16 log(lam) 1.0038052 0.0027130 369.998 < 2e-16 poly(pmax(0, log(lam) - 5), 2)1 0.9563792 0.6088250 1.571 0.116 poly(pmax(0, log(lam) - 5), 2)2 0.2293347 0.0358176 6.403 1.61e-10 log(df) 0.2180638 0.0038321 56.904 < 2e-16 log(lam):log(df) -0.0246454 0.0004534 -54.362 < 2e-16 poly(pmax(0, log(lam) - 5), 2)1:log(df) 4.5202063 0.1013637 44.594 < 2e-16 poly(pmax(0, log(lam) - 5), 2)2:log(df) 0.2136034 0.0044958 47.512 < 2e-16 (Intercept) *** log(lam) *** poly(pmax(0, log(lam) - 5), 2)1 poly(pmax(0, log(lam) - 5), 2)2 *** log(df) *** log(lam):log(df) *** poly(pmax(0, log(lam) - 5), 2)1:log(df) *** poly(pmax(0, log(lam) - 5), 2)2:log(df) *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.009826 on 8233 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 7.134e+07 on 7 and 8233 DF, p-value: < 2.2e-16 > > summary(dsR.r$iMax - exp(fitted(ll.5))) # one very negative Min. 1st Qu. Median Mean 3rd Qu. Max. -411.1956 -7.2680 -0.0882 -18.2510 31.2581 124.3729 > plot(ll.5, ask=FALSE) > showProc.time() Time (user system elapsed): 2.92 0.12 3.06 > > > ## First try to find formula for maximal number of terms needed > summary(l.N2.1 <- lm(iN2 ~ lam*df , data=dsR2r)) Call: lm(formula = iN2 ~ lam * df, data = dsR2r) Residuals: Min 1Q Median 3Q Max -274.960 -88.047 -7.159 83.844 222.369 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.462e+02 1.817e+00 135.5 <2e-16 *** lam 5.175e-01 5.253e-05 9851.2 <2e-16 *** df 1.763e-02 6.230e-05 283.0 <2e-16 *** lam:df -1.379e-07 1.284e-09 -107.4 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 112.3 on 8237 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 6.158e+07 on 3 and 8237 DF, p-value: < 2.2e-16 > summary(l.N2.2 <- lm(iN2 ~ lam*df + I(lam^2)+I(df^2), data=dsR2r),corr=TRUE) Call: lm(formula = iN2 ~ lam * df + I(lam^2) + I(df^2), data = dsR2r) Residuals: Min 1Q Median 3Q Max -161.15 -62.07 -10.11 51.30 320.84 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.107e+02 1.317e+00 159.92 <2e-16 *** lam 5.239e-01 1.039e-04 5043.73 <2e-16 *** df 2.168e-02 1.102e-04 196.73 <2e-16 *** I(lam^2) -8.726e-08 1.207e-09 -72.31 <2e-16 *** I(df^2) -6.612e-08 1.255e-09 -52.69 <2e-16 *** lam:df -1.119e-07 9.338e-10 -119.84 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 78 on 8235 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 7.663e+07 on 5 and 8235 DF, p-value: < 2.2e-16 Correlation of Coefficients: (Intercept) lam df I(lam^2) I(df^2) lam -0.37 df -0.28 -0.27 I(lam^2) 0.22 -0.93 0.23 I(df^2) 0.16 0.19 -0.91 -0.10 lam:df 0.23 0.00 -0.17 -0.24 -0.15 > summary(l.N2.3 <- lm(iN2 ~ lam*df + I(lam^2)+I(lam^3), data=dsR2r),corr=TRUE) Call: lm(formula = iN2 ~ lam * df + I(lam^2) + I(lam^3), data = dsR2r) Residuals: Min 1Q Median 3Q Max -234.383 -58.125 6.565 41.694 274.512 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.081e+02 1.445e+00 144.01 <2e-16 *** lam 5.334e-01 2.568e-04 2076.80 <2e-16 *** df 1.601e-02 5.063e-05 316.25 <2e-16 *** I(lam^2) -3.538e-07 7.302e-09 -48.45 <2e-16 *** I(lam^3) 1.878e-12 5.187e-14 36.20 <2e-16 *** lam:df -1.132e-07 1.006e-09 -112.53 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 83.78 on 8235 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 6.643e+07 on 5 and 8235 DF, p-value: < 2.2e-16 Correlation of Coefficients: (Intercept) lam df I(lam^2) I(lam^3) lam -0.40 df -0.26 -0.29 I(lam^2) 0.29 -0.96 0.27 I(lam^3) -0.25 0.90 -0.21 -0.98 lam:df 0.20 0.16 -0.76 -0.21 0.17 > summary(l.N2.4 <- lm(iN2 ~ lam*df + I(lam^2)+I(lam^3)+I(df^2), data=dsR2r),corr=TRUE) Call: lm(formula = iN2 ~ lam * df + I(lam^2) + I(lam^3) + I(df^2), data = dsR2r) Residuals: Min 1Q Median 3Q Max -149.63 -57.54 -7.76 54.07 204.03 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 1.988e+02 1.248e+00 159.28 <2e-16 *** lam 5.317e-01 2.219e-04 2396.52 <2e-16 *** df 2.110e-02 1.023e-04 206.20 <2e-16 *** I(lam^2) -3.274e-07 6.267e-09 -52.25 <2e-16 *** I(lam^3) 1.732e-12 4.447e-14 38.94 <2e-16 *** I(df^2) -6.342e-08 1.155e-09 -54.90 <2e-16 *** lam:df -1.066e-07 8.688e-10 -122.70 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 71.68 on 8234 degrees of freedom Multiple R-squared: 1, Adjusted R-squared: 1 F-statistic: 7.561e+07 on 6 and 8234 DF, p-value: < 2.2e-16 Correlation of Coefficients: (Intercept) lam df I(lam^2) I(lam^3) I(df^2) lam -0.37 df -0.23 -0.25 I(lam^2) 0.28 -0.96 0.18 I(lam^3) -0.24 0.90 -0.14 -0.98 I(df^2) 0.14 0.14 -0.91 -0.08 0.06 lam:df 0.18 0.14 -0.19 -0.20 0.16 -0.14 > plot(residuals(l.N2.2) ~ dsR2r$lam) > > dsR2r$lamP20k <- pmax(0, dsR2r$lam - 20000) > dsR2r$lamM20k <- pmin(0, dsR2r$lam - 20000) > summary(l.N2.1P <- lm(iN2 ~ lam+df + I(lamP20k ^2)+I(lamM20k ^2) , data=dsR2r)) Call: lm(formula = iN2 ~ lam + df + I(lamP20k^2) + I(lamM20k^2), data = dsR2r) Residuals: Min 1Q Median 3Q Max -307.51 -85.46 -29.44 62.78 432.19 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 6.621e+02 7.971e+00 83.061 < 2e-16 *** lam 5.101e-01 2.420e-04 2107.418 < 2e-16 *** df 1.159e-02 5.072e-05 228.438 < 2e-16 *** I(lamP20k^2) -1.389e-08 3.303e-09 -4.206 2.63e-05 *** I(lamM20k^2) -1.100e-06 2.180e-08 -50.436 < 2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 128.4 on 8236 degrees of freedom Multiple R-squared: 0.9999, Adjusted R-squared: 0.9999 F-statistic: 3.533e+07 on 4 and 8236 DF, p-value: < 2.2e-16 > > > ## This is to save typing: all variables 'log'ged: > dLr <- as.data.frame(lapply(dsR2r, log)) Warning message: In FUN(X[[i]], ...) : NaNs produced > summary(l.N2. <- lm(iN2 ~ lam*df + I(lam^2)+I(df^2), data=dLr),corr=TRUE) Call: lm(formula = iN2 ~ lam * df + I(lam^2) + I(df^2), data = dLr) Residuals: Min 1Q Median 3Q Max -0.54161 -0.06081 -0.00190 0.05313 0.51891 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.3679223 0.0196070 120.77 <2e-16 *** lam 0.1983089 0.0043464 45.63 <2e-16 *** df 0.2639313 0.0030228 87.31 <2e-16 *** I(lam^2) 0.0560720 0.0002839 197.52 <2e-16 *** I(df^2) 0.0146407 0.0002010 72.84 <2e-16 *** lam:df -0.0466746 0.0002222 -210.03 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.09621 on 8235 degrees of freedom Multiple R-squared: 0.9978, Adjusted R-squared: 0.9978 F-statistic: 7.322e+05 on 5 and 8235 DF, p-value: < 2.2e-16 Correlation of Coefficients: (Intercept) lam df I(lam^2) I(df^2) lam -0.82 df -0.54 -0.02 I(lam^2) 0.68 -0.93 0.12 I(df^2) 0.40 0.02 -0.79 0.10 lam:df 0.19 0.00 -0.26 -0.36 -0.37 > summary(l.N2 <- lm(iN2 ~ lam*df + I(lam^2)*I(df^2), data=dLr)) Call: lm(formula = iN2 ~ lam * df + I(lam^2) * I(df^2), data = dLr) Residuals: Min 1Q Median 3Q Max -0.51550 -0.06160 0.00376 0.04794 0.52297 Coefficients: Estimate Std. Error t value Pr(>|t|) (Intercept) 2.757e+00 4.173e-02 66.07 <2e-16 *** lam 1.279e-01 7.951e-03 16.08 <2e-16 *** df 1.902e-01 7.606e-03 25.01 <2e-16 *** I(lam^2) 5.843e-02 3.597e-04 162.45 <2e-16 *** I(df^2) 1.720e-02 3.146e-04 54.69 <2e-16 *** lam:df -3.723e-02 9.218e-04 -40.39 <2e-16 *** I(lam^2):I(df^2) -3.740e-05 3.546e-06 -10.55 <2e-16 *** --- Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 Residual standard error: 0.09557 on 8234 degrees of freedom Multiple R-squared: 0.9978, Adjusted R-squared: 0.9978 F-statistic: 6.184e+05 on 6 and 8234 DF, p-value: < 2.2e-16 > ## back transformed residuals: > r <- dsR2r$iN2 - exp(fitted(l.N2)) > n.plot(dsR2r$lam, r, log='x'); abline(h=0,lty=3) > ## extreme (negative): 3383, also 3381, 3382 > n.plot(dsR2r$lam, r, log='x', ylim=500*c(-1,1)); abline(h=0,lty=3) > > showProc.time() Time (user system elapsed): 0.89 0 0.89 > > > ###---- older tests --------------------------------------- > > > if(dev.interactive(TRUE)) { cat("sys.function(): "); str(sys.function()) } > if(.do.ask <- dev.interactive() && is.null(sys.function())) + par(ask=TRUE); cat(".do.ask : ", .do.ask, "\n") .do.ask : FALSE > mult.fig(2)$old.par -> op > ## large NC -- still (2018-08) very expensive!! > ## 10^(3:10) is (still!) much too expensive, 10^8 alone costs 31.8 sec ! > NC2 <- if(doExtras) 10^(2:7) else 10^(2:6) > for(NC in NC2) { + cat("ncp=",NC,":\n") + curve(dchisq(x, df=1, ncp=NC), from=NC/10,to=NC*100, + log='x', main=paste("Density ncp =",NC)) + curve(pchisq(x, df=1, ncp=NC), from=NC/10,to=NC*100, + log='x', main=paste("CDF ncp =",NC)) + showProc.time() + } ncp= 100 : Time (user system elapsed): 0.03 0 0.03 ncp= 1000 : Time (user system elapsed): 0 0 0 ncp= 10000 : Time (user system elapsed): 0.02 0 0.02 ncp= 1e+05 : Time (user system elapsed): 0.09 0 0.09 ncp= 1e+06 : Time (user system elapsed): 0.97 0 0.98 > par(op) > if(.do.ask) par(ask=FALSE) > > ## NOTE: I found that the median = qchisq(1/2, *) is "mostly" > ## ---- in (m-1, m) where m = mean = nu + lambda = df + ncp > > ## One exception (I've carefully searched for) where > ## median < m-1 <==> m - median > 1 : (maximal ~ 1.6): > df <- .0005; curve((df+x) - qchisq(1/2, df, ncp=x), 1, 2, col=2) > df <- .005 ; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE, col=3) > df <- .05 ; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE, col=4) > > ## These are all quite close (and quite CPU-costly !!) : > df <- 1e-4; curve((df+x) - qchisq(1/2, df, ncp=x), 0.5, 40, col=2) > abline(h=1, col='gray') > df <- 1e-4; curve((df+x) - qchisq(1/2, df, ncp=x), 1.2, 2, col=2) > if(doExtras) { + df <- 2e-4; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=3) + df <- 4e-4; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=4) + df <- 8e-4; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=5) + } > df <-16e-4; curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=6) > showProc.time() # 0.41 {2019-09} Time (user system elapsed): 1.52 0.03 1.55 > > df <- 1e-100; curve((df+x) - qchisq(1/2, df, ncp=x), 1.38, 1.40, col=2) > dfs <- 2^(if(doExtras) seq(-300,-2, length=21) else -2) # as they are costly > for(df in dfs) { + curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=3) + cat(formatC(df)," ") + }; cat("\n") 0.25 > showProc.time() Time (user system elapsed): 0.84 0 0.84 > > if(doExtras) { ## -- show irregularity more closely --------------- + df <- 1e-300; curve((df+x) - qchisq(1/2, df, ncp=x), 1.38628, 1.38630, col=2) + for(df in dfs) { + curve((df+x) - qchisq(1/2, df, ncp=x), add=TRUE,col=3) + cat(formatC(df)," ") + }; cat("\n") + curve((0+x) - qchisq(1/2, df=0, ncp=x), 1.386294, 1.386295, col=2) + showProc.time() # doExtras: ~ 0.6 {2019-09} + } # only if(.X.) ------------------------------------------------- > > ff <- function(ncp) (0+ncp)-qchisq(1/2, df=0, ncp=ncp) > str(oo <- optimize(ff, c(1.3,1.4), maximum=TRUE, tol=1e-15),digits=16) List of 2 $ maximum : num 1.386294378437597 $ objective: num 1.386294353453428 > ## $ maximum : num 1.386294373354218 > ## $ objective: num 1.386294355703814 > qchisq(1/2, df=0, ncp = 1.386294373354218)## = 1.765e-8 [1] 1.76504e-08 > > > ## This is the case df -> 0 where the distribution has a point mass at 0 ! > x <- c(0,1e-8,1e-5,1e-3,seq(0.01, 3, length = if(doExtras) 1001 else 125)) > plot (x, pchisq(x, df=1e-4, ncp = 1.4), type ='l', col=2, ylim = 0:1) > lines(x, pchisq(x, df=1e-4, ncp = 1.6), col=1) > lines(x, pchisq(x, df=1e-4, ncp = 1.2), col=3) > lines(x, pchisq(x, df=1e-4, ncp = 1.1), col=4) > lines(x, pchisq(x, df=1e-4, ncp = 0.1), col=5) > > plot (x, pchisq(x, df=1e-2, ncp = 1.4), type ='l', col=2, ylim = 0:1) > lines(x, pchisq(x, df=1e-2, ncp = 1.6), col=1) > lines(x, pchisq(x, df=1e-2, ncp = 1.2), col=3) > lines(x, pchisq(x, df=1e-2, ncp = 1.1), col=4) > lines(x, pchisq(x, df=1e-2, ncp = 0.1), col=5) > > plot (x, pchisq(x, df=0.1, ncp = 1.4), type ='l', col=2, ylim = 0:1) > lines(x, pchisq(x, df=0.1, ncp = 1.6), col=1) > lines(x, pchisq(x, df=0.1, ncp = 1.2), col=3) > lines(x, pchisq(x, df=0.1, ncp = 1.1), col=4) > lines(x, pchisq(x, df=0.1, ncp = 0.1), col=5) > > showProc.time() Time (user system elapsed): 0.31 0.02 0.33 > > ## MM: from something *not* put into ~/R/D/r-devel/R/tests/d-p-q-r-tests.R > ## 1) PR#14216 (r51179, 2010-02-25) > x <- 80:200; lp <- pchisq(x, 4, ncp=1, log.p=TRUE) > stopifnot(is.finite(lp), all.equal(lp[1],-2.5519291e-14), lp < 0, + ## underflowed to 0, in R <= 2.10.x + -.4635 < (dll <- diff(log(-lp))), dll < -.4415, + max(abs(diff(dll))) < 3.75e-4) > ## > showProc.time() Time (user system elapsed): 0 0 0 > > > ###---- again {may repeating from above --- "sorry I can't check that now"} : > > x <- 250; pchisq(x, 1.01, ncp = 80, log=TRUE) [1] -3.279266e-12 > > ## R-2.10.0 and earlier --> quite a noisy picture ! -- > ## note that log P > 0 <==> P > 1 --- of course nonsense! > xy <- curve(pchisq(x, 1.01, ncp = 80, log=TRUE), 250, 600, + n=1001, ylim = c(-1,1)*8e-14); abline(h=0, lty=3) > ## still noisy, and still slightly (5e-14) above 0 ! > > ## bigger picture: for theta = ncp < 80, it works by using the other tail > plot(p1 <- -pchisq(1:400, 1.01, ncp = 80*(1-.Machine$double.eps), log=TRUE), + log="y", type="o", pch=".") > ## However, for ncp >= 80 -- the P = sum_i term_i computation > lines(p2 <- -pchisq(1:400, 1.01, ncp = 80, log=TRUE), + col=adjustcolor(2,0.5),lwd=2)## underflow to 0 .. not good ___ FIXME ___ > ## here, "the other tail", log1p(- pnchisq(....., !lower_tail) ) does not work !! > summary(1 - p1/p2) Min. 1st Qu. Median Mean 3rd Qu. Max. -10.0013 0.0000 0.0000 0.2809 0.9999 3.7192 > > ## From: Prof Brian Ripley > ## To: Martin Maechler > ## cc: R-core@r-project.org > ## Subject: Re: p[n]chisq() warnings [was "d-p-q-r tests failures"] > ## Date: Tue, 24 Nov 2009 15:14:16 +0000 (GMT) > > ## Martin, > > > ## I mistyped 'mendacious": the error message lies. I think it is > ## generally wrongly worded, and should be something like 'full precision > ## may not have been achieved'. > > ## Here is why I added the warning I added: > > ## MM: added 'lower.tail' 'log.p' and 'x' arguments > > ##__ FIXME 2019-09: Compare with my new pnchis1sq() function !! > t1 <- function(p, ncp, lower.tail = FALSE, log.p = FALSE, + x = qchisq(p, df = 1, ncp, lower.tail=lower.tail, log.p=log.p)) + { + + ## X ~ chi^2(df=1, ncp = L^2) <==> X = Z^2 where Z ~ N(L, 1) + ## -------------------------- ------- ----------- + ## P[ X > x ] = P[ |Z| > sqrt(x) ] = P[Z > sx] + P[Z < -sx] , sx := sqrt(x) + + p1 <- pchisq(x, df = 1, ncp = ncp, lower.tail=lower.tail, log.p=log.p) + + sx <- sqrt(x) + sL <- sqrt(ncp) + p2 <- + if(!log.p) { + if(lower.tail) + pnorm(sx, sL) - + pnorm(sx, -sL, lower.tail=FALSE) + else ## lower.tail = FALSE + pnorm(sx, sL, lower.tail=FALSE) + + pnorm(sx, -sL, lower.tail=FALSE) + } else { ## log scale -- MM: use logspace.add() and *.sub() for the above + if(lower.tail) + logspace.sub(pnorm(sx, sL, log.p=TRUE), + pnorm(sx, -sL, log.p=TRUE, lower.tail=FALSE)) + else ## lower.tail = FALSE + logspace.add(pnorm(sx, sL, log.p=TRUE, lower.tail=FALSE), + pnorm(sx, -sL, log.p=TRUE, lower.tail=FALSE)) + } + c(if(!missing(p)) c(p=p), x=x, pnchisq=p1, p.true=p2, relErr=abs(p1-p2)/p2) + } > > t1(1e-12, 85) p x pnchisq p.true relErr 1.000000e-12 2.642192e+02 1.003309e-12 9.943394e-13 9.020204e-03 Warning messages: 1: In qchisq(p, df = 1, ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'qnchisq' 2: In pchisq(x, df = 1, ncp = ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'pnchisq' > ## [1] 1.000000e-12 2.642192e+02 1.003355e-12 9.943394e-13 9.066654e-03 > ## Warning messages: > ## 1: In qchisq(p, df = 1, ncp, lower.tail = FALSE) : > ## full precision was not achieved in 'qnchisq' > ## 2: In pchisq(x, df = 1, ncp = ncp, lower.tail = FALSE) : > ## full precision was not achieved in 'pnchisq' > > ## so the answer is out by about 1%. And > > t1(1e-14, 100) p x pnchisq p.true relErr 1.000000e-14 5.208816e+02 0.000000e+00 6.107835e-38 1.000000e+00 Warning messages: 1: In qchisq(p, df = 1, ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'qnchisq' 2: In pchisq(x, df = 1, ncp = ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'pnchisq' > ## [1] 1.000000e-14 5.208816e+02 0.000000e+00 6.107835e-38 1.000000e+00 > > ## has lost all precision. [MM: still true, Aug.2019] > > ## This sort of thing (because we compute 1 - answer) does not happen in > ## the other tail. So unless someone can show examples of precision > ## loss, I believe that the warning in that tail should not be there (and > ## would need conditional wording). > > ## MM: As soon as you go to log scale, completely inaccurate values around 1 > ## are completely unuseful, too: > t1(x = 500, ncp=80, lower.tail=TRUE, log.p=TRUE) x pnchisq p.true relErr 5.000000e+02 3.996803e-15 -2.423206e-41 -1.649386e+26 > ## x pnchisq p.true relErr > ## 5.000000e+02 3.552714e-15 -2.423206e-41 -1.466121e+26 > > > ## Brian > showProc.time() Time (user system elapsed): 0.1 0 0.1 > > ## On Tue, 24 Nov 2009, Martin Maechler wrote: > > ## >>>>>> Prof Brian Ripley > ## >>>>>> on Tue, 24 Nov 2009 12:22:48 +0000 (GMT) writes: > ## > > ## > > On Tue, 24 Nov 2009, Peter Dalgaard wrote: > ## > >> Prof Brian Ripley wrote: > ## > >>> I only picked up that change this morning, and am seeing the failures > ## > >>> too. I don't see why the warning is being given (isn't the test that > ## > >>> full accuracy was achieved?), so updating the .save file does not look > ## > >>> to me to be the solution. > ## > >> > ## > >> Hmm, I get the warnings, but it doesn't seem to stop the build for me > ## > >> and make check is failing at a different spoot: > ## > > ## > > At an *earlier* spot in the check. > ## > > ## > [.............] > ## > > ## > >> The relevant diff is > ## > >> --- src/nmath/pnchisq.c (revision 50552) > ## > >> +++ src/nmath/pnchisq.c (revision 50553) > ## > >> @@ -40,9 +40,15 @@ > ## > >> if (df < 0. || ncp < 0.) ML_ERR_return_NAN; > ## > >> > ## > >> ans = pnchisq_raw(x, df, ncp, 1e-12, 8*DBL_EPSILON, 1000000, > ## > >> lower_tail); > ## > >> - if(!lower_tail && ncp >= 80) { > ## > >> - if(ans < 1e-10) ML_ERROR(ME_PRECISION, "pnchisq"); > ## > >> - ans = fmax2(ans, 0.0); /* Precaution PR#7099 */ > ## > >> + if(ncp >= 80) { > ## > >> + if(lower_tail) { > ## > >> + if(ans >= 1-1e-10) ML_ERROR(ME_PRECISION, "pnchisq"); > ## > >> + ans = fmin2(ans, 1.0); /* e.g., pchisq(555, 1.01, ncp = 80) */ > ## > >> + } > ## > >> + else { /* !lower_tail */ > ## > >> + if(ans < 1e-10) ML_ERROR(ME_PRECISION, "pnchisq"); > ## > >> + ans = fmax2(ans, 0.0); /* Precaution PR#7099 */ > ## > >> + } > ## > >> } > ## > >> return log_p ? log(ans) : ans; > ## > >> } > ## > >> > ## > >> which warns if you get too close to 1.0 and truncates to 1.0 if you > ## > >> overshoot. All the cases tested should give the result 1.0 and thus > ## > >> trigger the warning. Are you implying that this is unintentional? > ## > > ## > > I don't know nor can I guess Martin's intention, but I am confident > ## > > the warning is medacious here. > ## > > ## > Hmm, I don't understand "medacious". > ## > > ## > But anyway: The new code of `` pmin(ans, 1) '' is indeed necessary; > ## > previously, pchisq(x, df, ncp) *would* return values larger > ## > than one, ... somewhat embarrassingly. > ## > > ## > If you study a bit further, you'll find that currently, > ## > pnchisq() for ncp > 80 use identical code for TRUE or FALSE > ## > lower_case; and the old code > ## > had a check for ncp >= 80 and accuracy warnings for "upper tail" > ## > and P < 1e-10. > ## > The logical extension is to give the same accuracy warning for > ## > "lower tail" and P > 1 - 1e-10. > > ## > Of course, this is all just a workaround for the fact that our > ## > current algorithm(s) are not good enough currently in those > ## > extreme tail cases, and indeed, > ## > I've start investigating better algorithms quite a while in the > ## > past. > ## > The creating of package 'Rmpfr' (for multi-precision arithmetic) > ## > has BTW been influenced by my desire to get tools for exploring > ## > such extreme tail misbehavior of current R algorithms. > ## > > ## > Here an example from one of my R scripts on this : > ## > > ## > ## R-2.10.0 and earlier --> quite a noisy picture ! -- > ## > ## note that log P > 0 <==> P > 1 --- of course nonsense! > ## > curve(pchisq(x, 1.01, ncp = 80, log=TRUE), 250, 600, > ## > n=1001, ylim = c(-1,1)*5e-14) > ## > > ## > So, again: these warning are a *substitute* and "cheap > ## > workaround" for now, but not > ## > only for the new case that I've added, but also already for the > ## > case Brian had added earlier: > ## > if(!lower_tail && ncp >= 80) { > ## > if(ans < 1e-10) ML_ERROR(ME_PRECISION, "pnchisq"); > ## > ans = fmax2(ans, 0.0); /* Precaution PR#7099 */ > ## > } > ## > > ## > Martin > ## > > ## > > ## > > The save file in R-devel (which also gives the warnings) was updated > ## > > in r50552. > ## > > ## > >> > ## > >> -p > ## > >> > ## > >>> Brian > ## > >>> > ## > >>> On Tue, 24 Nov 2009, Kurt Hornik wrote: > ## > >>> > ## > >>>>>>>>> Kurt Hornik writes: > ## > >>>> > ## > >>>>> I can no longer build r-patched. Most likely from > ## > >>>>> r50553 | maechler | 2009-11-23 23:50:13 +0100 (Mon, 23 Nov 2009) | 1 > ## > >>>>> line > ## > >>>> > ## > >>>>> ported r50552 [pchisq(*, ncp > 80) from trunk > ## > >>>> > ## > >>>>> I now get > ## > >>>> > ## >>>>>> ##-- non central Chi^2 : > ## >>>>>> xB <- c(2000,1e6,1e50,Inf) > ## >>>>>> for(df in c(0.1, 1, 10)) > ## > >>>>> + for(ncp in c(0, 1, 10, 100)) stopifnot(pchisq(xB, df=df, > ## > >>>>> ncp=ncp) == 1) > ## > >>>>> There were 12 warnings (use warnings() to see them) > ## > >>>> > ## > >>>>> and as the last line does not show in the .save file, make fails. > ## > >>>> > ## > >>>>> Is anyone seeing this too? > ## > >>>> > ## > >>>> This persists for both GCC 4.3 and 4.4 for me, the warnings coming from > ## > >>>> > ## > R> xB <- c(2000,1e6,1e50,Inf) > ## > R> for(df in c(0.1, 1, 10)) > ## > >>>> + for(ncp in c(0, 1, 10, 100)) stopifnot(pchisq(xB, df=df, ncp=ncp) == 1) > ## > >>>> > ## > >>>> -k > ## > >>>> > ## > >>>>> Best > ## > >>>>> -k > ## > >>>> > > ## Reproducing an "inverse" of Table 29.2 (p.464) of Johnson, Kotz, Balakr.(1995) Vol.2 > > nu. <- c(2,4,7) > lam <- c(1,4,16,25) > (pnl <- expand.grid(ncp=lam, df=nu., KEEP.OUT.ATTRS=FALSE)[,2:1]) df ncp 1 2 1 2 2 4 3 2 16 4 2 25 5 4 1 6 4 4 7 4 16 8 4 25 9 7 1 10 7 4 11 7 16 12 7 25 > nl <- with(pnl, df+ncp) > pars <- rbind(cbind(pnl, q = nl/2), + cbind(pnl, q = nl ), + cbind(pnl, q = nl*2)) > pch <- with(pars, pchisq(q=q, df=df, ncp=ncp)) > pchAA <- with(pars, pnchisqAbdelAty (q=q, df=df, ncp=ncp)) > pchSa <- with(pars, pnchisqSankaran_d(q=q, df=df, ncp=ncp)) > cbind(pars, R = pch, AA = pchAA, San = pchSa) df ncp q R AA San 1 2 1 1.5 0.37576432 0.36611102 0.36928788 2 2 4 3.0 0.29025462 0.28032127 0.28621486 3 2 16 9.0 0.12589612 0.11541246 0.12511813 4 2 25 13.5 0.07449824 0.06518126 0.07410078 5 4 1 2.5 0.25844815 0.25386936 0.25527415 6 4 4 4.0 0.21774820 0.20996787 0.21506246 7 4 16 10.0 0.10301485 0.09386298 0.10239477 8 4 25 14.5 0.06200815 0.05396135 0.06171537 9 7 1 4.0 0.16283301 0.16103101 0.16167772 10 7 4 5.5 0.14536828 0.14074748 0.14426226 11 7 16 11.5 0.07602668 0.06893607 0.07569325 12 7 25 16.0 0.04692285 0.04060875 0.04677881 13 2 1 3.0 0.62064365 0.62334189 0.61894698 14 2 4 6.0 0.58528941 0.59810765 0.58621306 15 2 16 18.0 0.54778325 0.56068557 0.54840342 16 2 25 27.0 0.53880535 0.55009514 0.53918749 17 4 1 5.0 0.59044503 0.59131933 0.58940613 18 4 4 8.0 0.57355935 0.58087176 0.57346056 19 4 16 20.0 0.54558231 0.55623146 0.54597160 20 4 25 29.0 0.53761221 0.54754128 0.53789576 21 7 1 8.0 0.56991794 0.57015810 0.56941978 22 7 4 11.0 0.56209691 0.56591229 0.56179737 23 7 16 23.0 0.54272003 0.55092414 0.54291006 24 7 25 32.0 0.53598571 0.54427888 0.53616726 25 2 1 6.0 0.86769855 0.87313440 0.87036076 26 2 4 12.0 0.89830904 0.90227330 0.89956441 27 2 16 36.0 0.97114892 0.96818694 0.97102679 28 2 25 54.0 0.98827835 0.98575157 0.98819464 29 4 1 10.0 0.91091170 0.91251900 0.91216030 30 4 4 16.0 0.92955673 0.93022543 0.93019333 31 4 16 40.0 0.97868544 0.97611117 0.97857683 32 4 25 58.0 0.99119206 0.98914493 0.99111807 33 7 1 16.0 0.94993962 0.95023251 0.95031480 34 7 4 22.0 0.95887688 0.95836209 0.95906463 35 7 16 46.0 0.98648727 0.98456268 0.98638731 36 7 25 64.0 0.99427782 0.99282196 0.99421501 > showProc.time() Time (user system elapsed): 0 0 0 > > ### Reproducing part of 'Table 29.2' (p.464) of Johnson, Kotz, Balakr.(1995) Vol.2 > ### > ### as in ../man/pnchisqAppr.Rd -- do run over *all* current pnchisq*() approximations! > > pkg <- "package:DPQ" > ## NB: use versions of the functions that return numeric *vector* (of correct length) : > pnchNms <- c(paste0("pchisq", c("", "V", "W", "W.R")), # + R's own, but *not* "W." ! + ls(pkg, pattern = "^pnchisq")) > ## drop some : > pnchNms <- pnchNms[!grepl("Terms$", pnchNms)] > pnchNms <- pnchNms[is.na(match(pnchNms, c("pnchisqIT", paste0("pnchisqT93.", c("a", "b")))))] > pnchF <- sapply(pnchNms, get, envir = as.environment(pkg)) > ## shorten the longer names for nicer tables : > n.n <- nchar(pnNms <- setNames(,pnchNms)) > L8 <- n.n > 8 > pnNms[n.n > 10] <- sub("pnchisq", "pn", pnNms[n.n > 10]) > pnNms[n.n > 8] <- sub("pnchisq","pnch", pnNms[n.n > 8]) > names(pnchF) <- pnNms <- unname(abbreviate(pnNms, 8)) > str(pnchF) List of 14 $ pchisq :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pchisqV :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, Fortran = TRUE, variant = c("s", "f")) $ pchisqW :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, variant = c("s", "f")) $ pchsqW.R:function (x, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, variant = c("s", "f"), verbose = getOption("verbose")) $ pnchisq :function (q, df, ncp = 0, lower.tail = TRUE, cutOffncp = 80, itSimple = 110, errmax = 1e-12, reltol = 1e-11, maxit = 10 * 10000, verbose = 0, xLrg.sigma = 5) $ pnAbdlAt:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pnBolKuz:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pnPatnak:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pnPearsn:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pnchRC :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, no2nd.call = FALSE, cutOffncp = 80, small.ncp.logspace = small.ncp.logspaceR2015, itSimple = 110, errmax = 1e-12, reltol = 8 * .Machine$double.eps, epsS = reltol/2, maxit = 1e+06, verbose = FALSE) $ pnSnkrn_:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) $ pnchT93 :function (q, df, ncp, lower.tail = TRUE, log.p = FALSE, use.a = q > ncp) $ pnchisqV:function (x, ..., verbose = 0) $ pnch_ss :function (x, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, i.max = 10000) > op <- options(warn = 1, digits = 5, width = 110)# warn: immediate .. > ## TODO --- want also "x ~ ncp" and or "df ~ ncp" > ## TODO: write a *function* that computes all this *and* stores in nicely dimnamed array > qq <- c(.001, .005, .01, .05, (1:9)/10, 2^seq(0, 10, by= 0.5)) > nncp <- c(0, 1/8, 1/2, 1, 2, 5, 20, 100, 200, 1000) > ddf <- c(2:4, 7, 20, 50, 100, 1000, 1e4, 1e10) # 1e300: fails for pchisqW.R() << FIXME > AR <- array(NA_real_, # [ncp,df, q] + dim=c(length(nncp), length(ddf), length(qq), length(pnchF)), + dimnames= list(ncp = formatC(nncp, width=1), + df = formatC( ddf, width=1), + q = formatC( qq, width=1), + Fn = pnNms)) > CT <- AR[,,1,1] # (w/ desired dim and dimnames) > > sfil5 <- file.path(sdir, "tests_chisq-nonc-ssAp.rds") > if(!doExtras && file.exists(sfil5)) { + ssAp_l <- readRDS_(sfil5) + str(ssAp_l) + AR <- ssAp_l$AR ## loadList(ssAp_l)# attach it + + } else { ## do run the simulation always if(doExtras) : + + for(incp in seq_along(nncp)) { + cat("\n~~~~~~~~~~~~~\nncp: ", ncp <- nncp[incp], "\n=======\n") + pnF <- if(ncp == 0) pnchF[!grepl("T93", pnNms)] else pnchF # Temme('93) : ncp > 0 + for(idf in seq_along(ddf)) { + df <- ddf[idf] + ct <- system.time( + r <- vapply(pnF, + function(F) Vectorize(F, names(formals(F))[[1]])(qq, df=df, ncp=ncp), + qq) + )[["user.self"]] + AR[incp, idf, , names(pnF)] <- r + CT[incp, idf] <- ct + } + } + showProc.time() + cat("User times in milli-sec.:\n") + print(CT * 1000) + save2RDS(list_(pnchNms, pnchF, qq, nncp, ddf, AR, CT), file=sfil5) + } ## else *do* run .. Reading from D:/RCompile/CRANincoming/R-devel/lib/DPQ/safe/tests_chisq-nonc-ssAp.rds Time (user system elapsed): 0.03 0 0.03 List of 7 $ pnchNms: chr [1:14] "pchisq" "pchisqV" "pchisqW" "pchisqW.R" ... $ pnchF :List of 14 ..$ pchisq :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pchisqV :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, Fortran = TRUE, variant = c("s", "f")) ..$ pchisqW :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, variant = c("s", "f")) ..$ pchsqW.R:function (x, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, variant = c("s", "f"), verbose = getOption("verbose")) ..$ pnchisq :function (q, df, ncp = 0, lower.tail = TRUE, cutOffncp = 80, itSimple = 110, errmax = 1e-12, reltol = 1e-11, maxit = 10 * 10000, verbose = 0, xLrg.sigma = 5) ..$ pnAbdlAt:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pnBolKuz:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pnPatnak:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pnPearsn:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pnchRC :function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, no2nd.call = FALSE, cutOffncp = 80, small.ncp.logspace = small.ncp.logspaceR2015, itSimple = 110, errmax = 1e-12, reltol = 8 * .Machine$double.eps, epsS = reltol/2, maxit = 1e+06, verbose = FALSE) ..$ pnSnkrn_:function (q, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ..$ pnchT93 :function (q, df, ncp, lower.tail = TRUE, log.p = FALSE, use.a = q > ncp) ..$ pnchisqV:function (x, ..., verbose = 0) ..$ pnch_ss :function (x, df, ncp = 0, lower.tail = TRUE, log.p = FALSE, i.max = 10000) $ qq : num [1:34] 0.001 0.005 0.01 0.05 0.1 0.2 0.3 0.4 0.5 0.6 ... $ nncp : num [1:10] 0 0.125 0.5 1 2 5 20 100 200 1000 $ ddf : num [1:10] 2 3 4 7 20 ... $ AR : num [1:10, 1:10, 1:34, 1:14] 0.0005 0.00047 0.000389 0.000303 0.000184 ... ..- attr(*, "dimnames")=List of 4 .. ..$ ncp: chr [1:10] "0" "0.125" "0.5" "1" ... .. ..$ df : chr [1:10] "2" "3" "4" "7" ... .. ..$ q : chr [1:34] "0.001" "0.005" "0.01" "0.05" ... .. ..$ Fn : chr [1:14] "pchisq" "pchisqV" "pchisqW" "pchsqW.R" ... $ CT : num [1:10, 1:10] 0.033 0.033 0.036 0.035 0.04 ... ..- attr(*, "dimnames")=List of 2 .. ..$ ncp: chr [1:10] "0" "0.125" "0.5" "1" ... .. ..$ df : chr [1:10] "2" "3" "4" "7" ... > > ## Rather, show absolute and also relative "errors" .. > stopifnot(dimnames(AR)[[4]][1] == "pchisq") > ## Absolute "error" , i.e., delta to R's pchisq() which is AR[,,,1] : > dAR <- AR[,,,-1] - c(AR[,,,1]) > ## if we were perfect, using same compilers as R etc, then these deltas are all = 0 : > summary(dAR[,,,"pnchRC"]) Min. 1st Qu. Median Mean 3rd Qu. Max. 0 0 0 0 0 0 > if(beStrict) stopifnot(dAR[,,,"pnchRC"] == 0) > > apply(dAR, 4, summary) # quite some NA's for some Fn's $pchisqV Min. 1st Qu. Median Mean 3rd Qu. Max. NA's -0.57 0.00 0.00 0.00 0.00 0.02 618 $pchisqW Min. 1st Qu. Median Mean 3rd Qu. Max. NA's -0.57 0.00 0.00 0.00 0.00 0.40 611 $pchsqW.R Min. 1st Qu. Median Mean 3rd Qu. Max. -0.57349 0.00000 0.00000 -0.00061 0.00000 0.39754 $pnchisq Min. 1st Qu. Median Mean 3rd Qu. Max. -9.62e-13 0.00e+00 0.00e+00 -2.42e-14 0.00e+00 5.60e-16 $pnAbdlAt Min. 1st Qu. Median Mean 3rd Qu. Max. -0.022444 0.000000 0.000000 -0.000146 0.000000 0.014671 $pnBolKuz Min. 1st Qu. Median Mean 3rd Qu. Max. 0.00000 0.00000 0.00000 0.16302 0.00049 1.00000 $pnPatnak Min. 1st Qu. Median Mean 3rd Qu. Max. -0.024386 0.000000 0.000000 -0.000282 0.000000 0.014529 $pnPearsn Min. 1st Qu. Median Mean 3rd Qu. Max. -0.010802 0.000000 0.000000 0.000308 0.000000 0.034440 $pnchRC Min. 1st Qu. Median Mean 3rd Qu. Max. 0 0 0 0 0 0 $pnSnkrn_ Min. 1st Qu. Median Mean 3rd Qu. Max. -0.006441 0.000000 0.000000 0.000173 0.000000 0.015054 $pnchT93 Min. 1st Qu. Median Mean 3rd Qu. Max. NA's -Inf 0.0 0.0 -Inf 0.0 0.5 361 $pnchisqV Min. 1st Qu. Median Mean 3rd Qu. Max. -9.62e-13 0.00e+00 0.00e+00 -2.42e-14 0.00e+00 5.60e-16 $pnch_ss Min. 1st Qu. Median Mean 3rd Qu. Max. -4.91e-14 0.00e+00 0.00e+00 4.03e-16 0.00e+00 6.99e-14 > aperm(apply(dAR, 3:4, function(x) {u <- x[!is.na(x)]; c(min=min(u), max=max(u))}), c(2,3,1L)) , , = min Fn q pchisqV pchisqW pchsqW.R pnchisq pnAbdlAt pnBolKuz pnPatnak pnPearsn 0.001 -1.2978e-06 -1.2978e-06 -1.3621e-06 -5.4210e-20 -2.2746e-08 0.0000e+00 -1.7122e-04 0.0000e+00 0.005 -3.0486e-06 -3.0486e-06 -3.0548e-06 -2.1684e-19 -8.4389e-05 0.0000e+00 -7.5389e-04 0.0000e+00 0.01 -2.0187e-06 -2.0187e-06 -2.0187e-06 -4.3368e-19 -2.3384e-04 0.0000e+00 -1.4220e-03 0.0000e+00 0.05 -4.2060e-48 -4.2060e-48 -4.2060e-48 -3.4694e-18 -1.4666e-03 0.0000e+00 -5.6547e-03 0.0000e+00 0.1 -3.7507e-26 -3.7507e-26 -3.7507e-26 -1.0842e-19 -3.1010e-03 0.0000e+00 -9.5498e-03 0.0000e+00 0.2 -2.3401e-25 -2.3401e-25 -2.3401e-25 -1.3878e-17 -7.9919e-03 0.0000e+00 -1.4900e-02 0.0000e+00 0.3 -5.3810e-25 -5.3810e-25 -5.3810e-25 -1.3878e-17 -1.1870e-02 0.0000e+00 -1.8251e-02 0.0000e+00 0.4 -1.0168e-24 -1.0168e-24 -1.0168e-24 -2.7756e-17 -1.4851e-02 0.0000e+00 -2.0299e-02 0.0000e+00 0.5 -7.6518e-09 -7.6518e-09 -7.6518e-09 -2.7756e-17 -1.7072e-02 0.0000e+00 -2.1421e-02 0.0000e+00 0.6 -2.5646e-08 -2.5646e-08 -2.5646e-08 -2.7756e-17 -1.8651e-02 0.0000e+00 -2.1860e-02 -3.9972e-04 0.7 -4.2445e-08 -4.2445e-08 -4.2445e-08 -2.7756e-17 -1.9692e-02 0.0000e+00 -2.1786e-02 -1.7157e-03 0.8 -5.8113e-08 -5.8113e-08 -5.8113e-08 -5.5511e-17 -2.0280e-02 0.0000e+00 -2.1323e-02 -3.4952e-03 0.9 -7.2763e-08 -7.2763e-08 -7.2763e-08 -2.7756e-17 -2.0488e-02 0.0000e+00 -2.1955e-02 -4.8804e-03 1 -8.6500e-08 -8.6500e-08 -8.6500e-08 -1.3878e-17 -2.0379e-02 0.0000e+00 -2.2865e-02 -5.9383e-03 1.414 -1.3508e-07 -1.1330e-02 -3.3001e-02 -5.5511e-17 -2.2444e-02 0.0000e+00 -2.4386e-02 -9.4246e-03 2 -2.1644e-01 -2.1644e-01 -2.1644e-01 -1.1102e-16 -2.1957e-02 0.0000e+00 -2.2084e-02 -1.0802e-02 2.828 -1.8964e-01 -1.8964e-01 -1.8964e-01 -2.2204e-16 -1.6268e-02 0.0000e+00 -1.4447e-02 -8.4141e-03 4 -1.5339e-01 -1.5339e-01 -1.5339e-01 -1.1102e-16 -9.9335e-03 0.0000e+00 -8.7546e-03 -7.6652e-03 5.657 -9.8346e-02 -9.8346e-02 -9.8346e-02 -1.6653e-16 -5.8030e-03 0.0000e+00 -6.3141e-03 -4.9180e-03 8 -5.6992e-01 -5.7349e-01 -5.7349e-01 -2.2204e-16 -9.8431e-03 0.0000e+00 -1.0375e-02 -2.1852e-03 11.31 -2.0716e-02 -2.0716e-02 -2.0716e-02 -2.2204e-16 -9.7332e-03 0.0000e+00 -9.5426e-03 -1.0600e-03 16 -1.1094e-04 -1.1094e-04 -1.1094e-04 -2.2204e-16 -5.7897e-03 0.0000e+00 -5.4685e-03 -2.0898e-03 22.63 -5.2270e-02 -5.2270e-02 -5.2270e-02 -2.2204e-16 -2.6010e-03 0.0000e+00 -2.7184e-03 -1.2084e-03 32 -3.4931e-05 -3.4931e-05 -3.4931e-05 -2.2204e-16 -8.0327e-04 0.0000e+00 -6.7838e-04 -6.5096e-04 45.25 -1.7499e-05 -1.7499e-05 -1.7499e-05 -1.2100e-15 -2.8077e-03 0.0000e+00 -2.7592e-03 -1.2500e-04 64 -1.5241e-06 -1.5241e-06 -1.5241e-06 -1.1411e-13 -3.1023e-03 0.0000e+00 -3.1813e-03 -1.5570e-04 90.51 -6.2565e-07 -6.2565e-07 -6.2565e-07 -7.0138e-13 -2.6938e-03 0.0000e+00 -2.6645e-03 -3.7391e-04 128 -2.6479e-06 -2.6479e-06 -2.6479e-06 -8.9395e-13 -7.1819e-04 0.0000e+00 -8.3518e-04 -1.7264e-04 181 -2.3028e-07 -2.3028e-07 -2.3028e-07 -7.6761e-13 -1.8901e-03 0.0000e+00 -1.8588e-03 -1.8883e-04 256 -1.2080e-06 -1.2080e-06 -1.2080e-06 -8.9097e-13 -1.6680e-03 -1.1102e-16 -1.6691e-03 -3.0874e-05 362 -1.7380e-08 -1.7380e-08 -1.7380e-08 -9.6234e-13 -8.3691e-04 0.0000e+00 -8.3349e-04 -6.3898e-06 512 -2.4092e-14 -2.4092e-14 -2.4092e-14 -9.4202e-13 -7.2238e-09 0.0000e+00 -6.3547e-09 -5.2556e-10 724.1 0.0000e+00 0.0000e+00 0.0000e+00 -9.1116e-13 -5.1193e-07 0.0000e+00 -5.2437e-07 0.0000e+00 1024 -2.0452e-07 -2.0452e-07 -2.0452e-07 -8.7741e-13 -4.4876e-04 0.0000e+00 -4.3676e-04 -2.5725e-05 Fn q pnchRC pnSnkrn_ pnchT93 pnchisqV pnch_ss 0.001 0 0.0000e+00 -2.2737e-08 -5.4210e-20 -1.6941e-21 0.005 0 0.0000e+00 -1.0289e-05 -2.1684e-19 -3.3881e-20 0.01 0 0.0000e+00 -1.4544e-04 -4.3368e-19 -5.4210e-20 0.05 0 0.0000e+00 -1.3905e-03 -3.4694e-18 -3.4694e-18 0.1 0 0.0000e+00 -3.0107e-03 -1.0842e-19 -3.4694e-18 0.2 0 0.0000e+00 -Inf -1.3878e-17 -4.8572e-17 0.3 0 0.0000e+00 -Inf -1.3878e-17 -1.3878e-17 0.4 0 -4.5227e-04 -Inf -2.7756e-17 -2.7756e-17 0.5 0 -2.5564e-03 -Inf -2.7756e-17 -2.7756e-17 0.6 0 -4.0309e-03 -Inf -2.7756e-17 -8.3267e-17 0.7 0 -5.0011e-03 -Inf -2.7756e-17 -2.7756e-17 0.8 0 -5.5740e-03 -Inf -5.5511e-17 -8.3267e-17 0.9 0 -5.8377e-03 -Inf -2.7756e-17 -8.3267e-17 1 0 -5.8664e-03 -Inf -1.3878e-17 -1.1102e-16 1.414 0 -6.4406e-03 -Inf -5.5511e-17 -1.6653e-16 2 0 -6.1542e-03 -Inf -1.1102e-16 -4.9960e-16 2.828 0 -4.5075e-03 -Inf -2.2204e-16 -2.2204e-16 4 0 -3.3842e-03 -Inf -1.1102e-16 -2.2204e-16 5.657 0 -2.2924e-03 -Inf -1.6653e-16 -3.3307e-16 8 0 -1.7267e-03 -Inf -2.2204e-16 -5.5511e-16 11.31 0 -5.5778e-04 -Inf -2.2204e-16 -5.5511e-16 16 0 -6.0842e-04 -Inf -2.2204e-16 -5.5511e-16 22.63 0 -4.6976e-04 -Inf -2.2204e-16 -4.4409e-16 32 0 -4.2723e-04 -Inf -2.2204e-16 -8.8818e-16 45.25 0 -2.3172e-04 -Inf -1.2100e-15 -1.1102e-15 64 0 -2.0693e-04 -Inf -1.1411e-13 -3.2196e-15 90.51 0 -1.1125e-04 -Inf -7.0138e-13 -1.1102e-15 128 0 -7.2316e-05 -Inf -8.9395e-13 -7.3275e-15 181 0 -7.6834e-05 -Inf -7.6761e-13 -7.4385e-15 256 0 -1.5188e-05 -Inf -8.9097e-13 -2.2538e-14 362 0 -4.7509e-06 -Inf -9.6234e-13 -5.4401e-15 512 0 -2.4168e-10 -Inf -9.4202e-13 -4.2077e-14 724.1 0 -6.2489e-10 -Inf -9.1116e-13 -3.2307e-14 1024 0 -2.5366e-06 -Inf -8.7741e-13 -4.9072e-14 , , = max Fn q pchisqV pchisqW pchsqW.R pnchisq pnAbdlAt pnBolKuz pnPatnak pnPearsn pnchRC 0.001 7.2897e-28 7.2897e-28 7.2897e-28 5.4210e-20 7.0797e-03 1.00000 0.0000e+00 3.4440e-02 0 0.005 7.0684e-10 7.0684e-10 7.0684e-10 4.3368e-19 9.4291e-03 1.00000 0.0000e+00 3.4140e-02 0 0.01 5.1932e-07 5.1932e-07 5.1932e-07 8.6736e-19 1.0645e-02 1.00000 0.0000e+00 3.3767e-02 0 0.05 6.7108e-05 6.7108e-05 7.4057e-05 3.4694e-18 1.2080e-02 1.00000 0.0000e+00 3.0877e-02 0 0.1 2.0534e-04 2.0534e-04 2.2164e-04 6.9389e-18 1.0437e-02 1.00000 0.0000e+00 2.7490e-02 0 0.2 5.7455e-04 5.7455e-04 5.7455e-04 1.3878e-17 6.1960e-03 1.00000 0.0000e+00 2.1402e-02 0 0.3 1.0261e-03 1.0261e-03 1.0261e-03 2.7756e-17 4.9108e-03 1.00000 0.0000e+00 1.6129e-02 0 0.4 1.4928e-03 1.4928e-03 1.4928e-03 2.7756e-17 3.9136e-03 1.00000 0.0000e+00 1.1568e-02 0 0.5 1.9524e-03 1.9524e-03 1.9524e-03 5.5511e-17 3.1742e-03 1.00000 0.0000e+00 1.0003e-02 0 0.6 2.3977e-03 2.3977e-03 2.3977e-03 2.7756e-17 2.8956e-03 1.00000 0.0000e+00 8.8015e-03 0 0.7 2.8292e-03 2.8292e-03 2.8292e-03 1.3878e-17 2.5077e-03 1.00000 0.0000e+00 7.6268e-03 0 0.8 3.3316e-03 3.3316e-03 3.3316e-03 5.5511e-17 2.0326e-03 1.00000 0.0000e+00 6.9445e-03 0 0.9 3.9272e-03 3.9272e-03 3.9272e-03 5.5511e-17 1.5058e-03 1.00000 0.0000e+00 6.5239e-03 0 1 4.6158e-03 4.6158e-03 4.6158e-03 5.5511e-17 1.0322e-03 1.00000 0.0000e+00 6.0616e-03 0 1.414 1.1071e-02 1.1071e-02 1.1071e-02 5.5511e-17 1.2673e-03 1.00000 0.0000e+00 4.3255e-03 0 2 4.0612e-03 5.1364e-03 5.1364e-03 1.1102e-16 9.8981e-04 1.00000 4.3935e-04 2.7096e-03 0 2.828 2.3612e-02 2.3612e-02 2.3612e-02 1.1102e-16 1.6908e-03 1.00000 3.6710e-03 1.7924e-03 0 4 6.6103e-03 3.9754e-01 3.9754e-01 1.6653e-16 7.8819e-03 1.00000 9.1355e-03 1.2006e-03 0 5.657 5.7614e-03 5.7614e-03 5.7614e-03 2.2204e-16 1.0544e-02 1.00000 1.0794e-02 1.2893e-03 0 8 3.2506e-03 3.2506e-03 3.2506e-03 3.3307e-16 1.4671e-02 1.00000 1.4529e-02 2.1329e-03 0 11.31 1.5671e-05 1.5671e-05 1.5671e-05 2.2204e-16 9.1513e-03 1.00000 8.0013e-03 2.2717e-03 0 16 5.7405e-05 5.7405e-05 5.7405e-05 4.4409e-16 4.2205e-03 1.00000 3.4298e-03 1.1808e-03 0 22.63 7.6929e-04 7.6929e-04 7.6929e-04 3.3307e-16 1.2238e-02 1.00000 1.2321e-02 3.1937e-04 0 32 1.3149e-05 1.3149e-05 1.3149e-05 3.3307e-16 6.6061e-03 1.00000 6.1928e-03 9.7448e-04 0 45.25 3.9179e-06 3.9179e-06 4.0384e-06 3.3307e-16 3.3086e-03 1.00000 3.0588e-03 3.2440e-04 0 64 6.6389e-06 6.6389e-06 6.6389e-06 4.4409e-16 5.8933e-04 1.00000 7.6946e-04 1.3739e-04 0 90.51 2.7300e-06 2.7300e-06 2.7300e-06 5.5511e-16 3.0423e-03 1.00000 3.2569e-03 5.3729e-05 0 128 5.2822e-07 5.2822e-07 5.2822e-07 3.3307e-16 4.0129e-03 1.00000 3.9185e-03 2.3710e-04 0 181 4.5471e-07 4.5471e-07 4.5471e-07 3.3307e-16 1.1439e-03 1.00000 1.2532e-03 7.9497e-05 0 256 5.3784e-08 5.3784e-08 5.3784e-08 3.3307e-16 3.0075e-03 1.00000 2.9825e-03 8.8478e-05 0 362 1.5765e-14 1.5765e-14 1.5765e-14 9.1439e-100 2.4425e-15 1.00000 2.6645e-15 2.8866e-15 0 512 1.6653e-14 1.6653e-14 1.6653e-14 2.5489e-57 1.6653e-14 1.00000 1.6653e-14 1.6653e-14 0 724.1 5.3928e-14 5.3928e-14 5.3928e-14 8.0779e-28 1.7707e-13 1.00000 3.5638e-14 3.9231e-08 0 1024 3.6665e-08 3.6665e-08 3.6665e-08 1.1102e-16 2.0212e-03 0.88078 2.0193e-03 2.2323e-05 0 Fn q pnSnkrn_ pnchT93 pnchisqV pnch_ss 0.001 9.3453e-03 9.6565e-02 5.4210e-20 4.3368e-19 0.005 1.1515e-02 1.5175e-01 4.3368e-19 1.3010e-18 0.01 1.2735e-02 1.8675e-01 8.6736e-19 4.3368e-18 0.05 1.5054e-02 3.1644e-01 3.4694e-18 3.4694e-18 0.1 1.4502e-02 4.2071e-01 6.9389e-18 2.0817e-17 0.2 1.1538e-02 4.1309e-01 1.3878e-17 1.1755e-38 0.3 8.2841e-03 3.8087e-01 2.7756e-17 5.5511e-17 0.4 6.1274e-03 3.7352e-01 2.7756e-17 5.5511e-17 0.5 5.3333e-03 5.0000e-01 5.5511e-17 5.5511e-17 0.6 4.6650e-03 4.4085e-01 2.7756e-17 6.9389e-18 0.7 3.9530e-03 4.1104e-01 1.3878e-17 5.5511e-17 0.8 3.5607e-03 3.8780e-01 5.5511e-17 5.5511e-17 0.9 3.3566e-03 3.9984e-01 5.5511e-17 5.5511e-17 1 3.0863e-03 5.0000e-01 5.5511e-17 5.5511e-17 1.414 1.5551e-03 3.8130e-01 5.5511e-17 5.0487e-28 2 1.4754e-03 5.0000e-01 1.1102e-16 1.1102e-16 2.828 1.3777e-03 3.5823e-01 1.1102e-16 1.1102e-16 4 2.5018e-03 3.1035e-01 1.6653e-16 1.1102e-16 5.657 2.6982e-03 3.7514e-01 2.2204e-16 3.3307e-16 8 2.3629e-03 3.3749e-01 3.3307e-16 3.3307e-16 11.31 1.7162e-03 2.9875e-01 2.2204e-16 3.3307e-16 16 9.4747e-04 1.8484e-01 4.4409e-16 8.8818e-16 22.63 5.1737e-04 3.4796e-01 3.3307e-16 1.6653e-15 32 4.3696e-04 3.1871e-01 3.3307e-16 1.3323e-15 45.25 2.7938e-04 2.5948e-01 3.3307e-16 3.2196e-15 64 1.8505e-04 1.9222e-01 4.4409e-16 9.9920e-16 90.51 7.6328e-05 8.1155e-02 5.5511e-16 4.8850e-15 128 8.2807e-05 2.8667e-01 3.3307e-16 7.8826e-15 181 3.0847e-05 8.6990e-02 3.3307e-16 1.8985e-14 256 2.0514e-05 3.2028e-01 3.3307e-16 1.9651e-14 362 2.8866e-15 2.9525e-02 9.1439e-100 2.7978e-14 512 1.6653e-14 4.3869e-09 2.5489e-57 1.8874e-14 724.1 5.2076e-11 3.5638e-14 8.0779e-28 6.9944e-14 1024 8.9617e-06 3.4688e-01 1.1102e-16 5.9064e-14 > ftable(apply(dAR[c("1", "2", "5"), c(1,3,4),,], c(1,2,4), median)) Fn pchisqV pchisqW pchsqW.R pnchisq pnAbdlAt pnBolKuz pnPatnak pnPearsn pnchRC pnSnkrn_ pnchT93 pnchisqV pnch_ss ncp df 1 2 NA 0.0000e+00 0.0000e+00 0.0000e+00 -6.3958e-10 1.4967e-03 -2.4465e-04 0.0000e+00 0.0000e+00 0.0000e+00 3.9187e-02 0.0000e+00 -8.3267e-17 4 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 3.2613e-05 -4.6056e-06 1.6787e-04 0.0000e+00 6.4363e-05 2.1561e-02 0.0000e+00 -6.9389e-18 7 7.2412e-15 7.2412e-15 7.2412e-15 0.0000e+00 4.2375e-07 3.8642e-07 -1.0280e-06 1.0858e-06 0.0000e+00 6.8920e-07 1.2513e-02 0.0000e+00 -3.2526e-19 2 2 0.0000e+00 0.0000e+00 0.0000e+00 1.2197e-19 -3.3277e-05 7.7923e-03 -4.3325e-04 0.0000e+00 0.0000e+00 0.0000e+00 9.6169e-03 1.2197e-19 1.6263e-18 4 0.0000e+00 0.0000e+00 0.0000e+00 0.0000e+00 -5.5511e-17 1.9668e-04 -2.7026e-05 3.4619e-04 0.0000e+00 1.1474e-04 9.6915e-03 0.0000e+00 0.0000e+00 7 9.0291e-12 9.0291e-12 9.0291e-12 6.3109e-30 1.0877e-07 3.0685e-06 -1.1449e-06 1.4745e-05 0.0000e+00 8.7178e-07 4.5331e-03 6.3109e-30 0.0000e+00 5 2 2.5966e-07 2.5966e-07 2.5966e-07 6.7763e-20 -4.5132e-04 6.6305e-02 -7.6241e-04 2.7018e-04 0.0000e+00 0.0000e+00 0.0000e+00 6.7763e-20 -2.2551e-17 4 NA 0.0000e+00 0.0000e+00 8.4703e-21 -3.2514e-05 1.9085e-03 -6.1791e-05 1.0712e-03 0.0000e+00 1.0579e-04 7.8145e-05 8.4703e-21 -1.0842e-18 7 2.1794e-12 2.1794e-12 2.1794e-12 5.0822e-21 -8.7153e-15 1.7980e-05 -4.3775e-06 8.8346e-05 0.0000e+00 2.4645e-06 1.7780e-04 5.0822e-21 -6.7763e-20 > ftable(apply(dAR[c("1", "2", "5"), c(1,3,4),,], c(1,2,4), function(x) max(abs(x[!is.na(x)])))) Fn pchisqV pchisqW pchsqW.R pnchisq pnAbdlAt pnBolKuz pnPatnak pnPearsn pnchRC pnSnkrn_ pnchT93 pnchisqV pnch_ss ncp df 1 2 1.8964e-01 1.8964e-01 1.8964e-01 3.3307e-16 1.3125e-02 4.6167e-02 1.2187e-02 3.2615e-02 0.0000e+00 1.5054e-02 2.3288e-01 3.3307e-16 3.2307e-14 4 6.6103e-03 6.6103e-03 6.6103e-03 1.1102e-16 4.3613e-03 1.0343e-02 2.9238e-03 3.1348e-03 0.0000e+00 3.8460e-03 4.4079e-01 1.1102e-16 3.9080e-14 7 5.6992e-01 5.6992e-01 5.6992e-01 1.1102e-16 1.8379e-03 2.7665e-03 7.9416e-04 5.3448e-04 0.0000e+00 1.9515e-03 4.9669e-01 1.1102e-16 1.3656e-14 2 2 1.0570e-01 2.3612e-02 1.0570e-01 2.2204e-16 2.0488e-02 2.5896e-01 2.1860e-02 3.4440e-02 0.0000e+00 1.1702e-02 1.5425e-01 2.2204e-16 3.2307e-14 4 9.8346e-02 9.8346e-02 9.8346e-02 3.3307e-16 6.9735e-03 7.9300e-02 6.5650e-03 5.3681e-03 0.0000e+00 3.7008e-03 3.6952e-01 3.3307e-16 3.9080e-14 7 3.2506e-03 3.2506e-03 3.2506e-03 2.2204e-16 2.6385e-03 2.2927e-02 2.1267e-03 1.1792e-03 0.0000e+00 1.9807e-03 4.8180e-01 2.2204e-16 1.3656e-14 5 2 5.7614e-03 5.7614e-03 5.7614e-03 2.2204e-16 2.2444e-02 8.2742e-01 2.4386e-02 1.6183e-02 0.0000e+00 3.7589e-03 1.2269e-01 2.2204e-16 3.2307e-14 4 4.3669e-04 5.5626e-03 5.5626e-03 2.2204e-16 1.1343e-02 5.7398e-01 1.1852e-02 4.9536e-03 0.0000e+00 2.2924e-03 2.4007e-01 2.2204e-16 3.9080e-14 7 2.0716e-02 2.0716e-02 2.0716e-02 4.4409e-16 5.4358e-03 2.8395e-01 5.1598e-03 2.1645e-03 0.0000e+00 1.7267e-03 3.7514e-01 4.4409e-16 1.3656e-14 > > ## (Note: for large df=1e10, p*() == 0 everywhere for the small 'q' we have > ## ---- FIXME: qq: should be "realistic" in mu +/- 5 sd > > options(warn = 0, digits = 7)# partial revert > > ###----------- Much testing pnchisqRC() notably during my experiments > (ptol <- if(noLdbl) 8e-13 else if(doExtras) 3e-16 else if(is32) 1e-14 else 1e-15) [1] 1e-15 > set.seed(123) > for(df in c(.1, .2, 1, 2, 5, 10, 20, 50, 1000, + if(doExtras) c(1e10, 1e200))) { ## BUG! (df=1e200, ncp=1000) takes forever + cat("\n============\ndf = ",df,"\n~~~~~~~~~\n") + for(ncp in c(0, .1, .2, 1, 2, 5, 10, 20, 50, + if(df < 1e10) c(1000, 1e4) else c(100,200))) { # BUG: large ncp take forever + cat("\nncp = ",ncp,": qq = ") + qch <- if(ncp+df < 1000) + qchisq((1:15)/16, df=df, ncp=ncp) + else { + qq <- qnchisqPatnaik((1:15)/16, df=df, ncp=ncp) + if(qq[1] < qq[length(qq)]) + qq + else { # they all coincide ==> take mu +/- (1:3) SD + mu <- df+ncp + sigma <- sqrt(2*(df + 2*ncp)) + mu + seq(-4,4, length.out=15)*sigma + } + } + str(qq <- c(0, qch, Inf), digits=4) + for(lower.tail in c(TRUE, FALSE)) { + cat(sprintf("lower.tail = %-5s : ", lower.tail)) + for(log.p in c(FALSE, TRUE)) { + cat("log.p=", log.p, "") + AE <- all.equal( + pchisq (qq, df=df, ncp=ncp, lower.tail=lower.tail, log.p=log.p) , + pnchisqRC(qq, df=df, ncp=ncp, lower.tail=lower.tail, log.p=log.p) , + tol = ptol) + if(is.character(AE)) { + dd <- sub(".*:", "", AE) + cat("pchisq() differ by", dd,"(dd/ptol = ",as.numeric(dd)/ptol," < 100 ?)\n") + ## fails for first df=0.1, ncp=10000 on Windows 64-bit (winbuilder 2019-10) + ## ... also on 'florence' (32-bit Fedora 28, 2019-10) + if(myPlatf || ncp <= 1000) + stopifnot(as.numeric(dd) < 100 * ptol) + else if ( !(as.numeric(dd) < 100 * ptol)) + cat("not stop()ing even though dd < 100 * ptol\n") + } + }; cat("\n") + } + }# for(ncp .) + showProc.time() + }# for(df .) ============ df = 0.1 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0.000 9.669e-25 1.014e-18 3.371e-15 1.063e-12 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0.000 2.628e-24 2.756e-18 9.164e-15 2.890e-12 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE pchisq() differ by 1.023887e-15 (dd/ptol = 1.023887 < 100 ?) lower.tail = FALSE : log.p= FALSE pchisq() differ by 1.037266e-15 (dd/ptol = 1.037266 < 100 ?) log.p= TRUE pchisq() differ by 2.578979e-15 (dd/ptol = 2.578979 < 100 ?) ncp = 0.2 : qq = num [1:17] 0.000 7.145e-24 7.492e-18 2.491e-14 7.856e-12 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0.000 2.130e-20 2.233e-14 7.426e-11 2.342e-08 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0.000 4.691e-16 4.919e-10 1.636e-06 5.134e-04 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 0.004513 0.494777 1.070122 1.639704 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 1.996 3.317 4.398 5.375 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 7.899 10.253 12.04 13.585 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 29.86 34.23 37.4 40.06 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 904.9 927.8 943.7 956.7 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9695 9770 9822 9864 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.25 0.05 0.29 ============ df = 0.2 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0.000 1.105e-12 1.131e-09 6.523e-08 1.158e-06 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0.000 1.821e-12 1.865e-09 1.075e-07 1.910e-06 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE pchisq() differ by 1.072547e-15 (dd/ptol = 1.072547 < 100 ?) lower.tail = FALSE : log.p= FALSE log.p= TRUE pchisq() differ by 2.565801e-15 (dd/ptol = 2.565801 < 100 ?) ncp = 0.2 : qq = num [1:17] 0.000 3.003e-12 3.075e-09 1.773e-07 3.149e-06 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0.000 1.639e-10 1.679e-07 9.681e-06 1.719e-04 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0.000 2.433e-08 2.491e-05 1.428e-03 2.322e-02 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 0.0478 0.5763 1.1555 1.7296 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 2.069 3.398 4.484 5.465 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 7.981 10.34 12.13 13.678 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 29.95 34.32 37.49 40.15 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 905 927.9 943.8 956.8 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9695 9771 9822 9865 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.17 0 0.18 ============ df = 1 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 0.006149 0.024747 0.056265 0.101531 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 0.006795 0.027348 0.062176 0.112189 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE pchisq() differ by 1.012736e-15 (dd/ptol = 1.012736 < 100 ?) lower.tail = FALSE : log.p= FALSE pchisq() differ by 1.071101e-15 (dd/ptol = 1.071101 < 100 ?) log.p= TRUE pchisq() differ by 2.548567e-15 (dd/ptol = 2.548567 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 0.007509 0.03022 0.068693 0.123915 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 0.01668 0.06673 0.15022 0.26747 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 0.04468 0.1718 0.36615 0.61331 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 0.5108 1.1835 1.8213 2.4392 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 2.651 4.048 5.176 6.189 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 8.632 11.034 12.852 14.422 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 30.66 35.05 38.24 40.92 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 905.8 928.7 944.6 957.6 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9696 9771 9823 9865 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.14 0 0.14 ============ df = 2 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 0.1291 0.2671 0.4153 0.5754 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 0.1357 0.2807 0.4365 0.6048 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE pchisq() differ by 1.017805e-15 (dd/ptol = 1.017805 < 100 ?) lower.tail = FALSE : log.p= FALSE log.p= TRUE pchisq() differ by 2.556677e-15 (dd/ptol = 2.556677 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 0.1426 0.295 0.4587 0.6354 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 0.2116 0.4354 0.6732 0.9272 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 0.3406 0.6856 1.039 1.405 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 1.111 1.925 2.642 3.317 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 3.385 4.864 6.043 7.095 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 9.449 11.904 13.756 15.352 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 31.54 35.97 39.18 41.87 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 906.8 929.7 945.6 958.6 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9697 9772 9824 9866 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.14 0 0.14 ============ df = 5 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 1.275 1.808 2.257 2.675 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 1.301 1.845 2.303 2.728 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE pchisq() differ by 1.02352e-15 (dd/ptol = 1.02352 < 100 ?) log.p= TRUE pchisq() differ by 2.529306e-15 (dd/ptol = 2.529306 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 1.327 1.882 2.349 2.783 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 1.551 2.196 2.738 3.241 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 1.869 2.635 3.274 3.862 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 3.062 4.2 5.12 5.949 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 5.631 7.334 8.656 9.818 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 11.91 14.52 16.47 18.15 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 34.21 38.73 42 44.73 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 909.7 932.6 948.6 961.6 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9700 9775 9827 9869 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.12 0.03 0.15 ============ df = 10 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 4.208 5.234 6.033 6.737 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 4.25 5.287 6.093 6.805 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE pchisq() differ by 2.408669e-15 (dd/ptol = 2.408669 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 4.292 5.339 6.154 6.873 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 4.642 5.772 6.65 7.425 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 5.102 6.336 7.294 8.138 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 6.618 8.162 9.35 10.389 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 9.498 11.522 13.055 14.38 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 16.07 18.91 21.02 22.81 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 38.66 43.33 46.69 49.51 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 914.6 937.5 953.5 966.5 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9705 9780 9832 9874 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.13 0 0.13 ============ df = 20 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 11.32 13.06 14.35 15.45 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 11.38 13.12 14.42 15.53 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE pchisq() differ by 2.110627e-15 (dd/ptol = 2.110627 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 11.43 13.19 14.49 15.61 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 11.89 13.71 15.07 16.23 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 12.48 14.39 15.8 17.02 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 14.3 16.46 18.07 19.43 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 17.54 20.1 21.98 23.59 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 24.52 27.79 30.17 32.19 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 47.61 52.56 56.11 59.08 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 924.3 947.4 963.4 976.4 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9715 9790 9842 9884 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.14 0 0.14 ============ df = 50 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 35.64 38.78 41.05 42.94 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 35.71 38.86 41.13 43.03 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE pchisq() differ by 1.550023e-15 (dd/ptol = 1.550023 < 100 ?) ncp = 0.2 : qq = num [1:17] 0 35.78 38.94 41.21 43.11 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 36.35 39.56 41.87 43.8 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 37.07 40.34 42.7 44.67 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 39.25 42.71 45.19 47.27 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 42.96 46.71 49.41 51.66 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 50.61 54.9 57.99 60.56 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 74.71 80.43 84.5 87.87 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 953.6 976.8 993 1006.1 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 9745 9820 9872 9914 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.13 0 0.12 ============ df = 1000 ~~~~~~~~~ ncp = 0 : qq = num [1:17] 0 932.3 948.8 960.2 969.5 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.1 : qq = num [1:17] 0 932.4 948.9 960.3 969.6 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 0.2 : qq = num [1:17] 0 932.5 949 960.4 969.7 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1 : qq = num [1:17] 0 933.2 949.7 961.2 970.5 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 2 : qq = num [1:17] 0 934.2 950.7 962.1 971.4 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 5 : qq = num [1:17] 0 937 953.5 965 974.3 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10 : qq = num [1:17] 0 941.6 958.3 969.8 979.2 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 20 : qq = num [1:17] 0 951 967.8 979.4 988.9 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 50 : qq = num [1:17] 0 979 996.3 1008.3 1018 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 1000 : qq = num [1:17] 0 1883 1911 1931 1947 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE ncp = 10000 : qq = num [1:17] 0 10687 10765 10818 10861 ... lower.tail = TRUE : log.p= FALSE log.p= TRUE lower.tail = FALSE : log.p= FALSE log.p= TRUE Time (user system elapsed): 0.06 0 0.07 > summary(warnings()) Summary of (a total of 2) warning messages: 1x : In qchisq(p, df = 1, ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'qnchisq' 1x : In pchisq(x, df = 1, ncp = ncp, lower.tail = lower.tail, ... : full precision may not have been achieved in 'pnchisq' > > ### L. Emphasis on very large df + ncp =============================================== > > ##=== L 1. very large df, ncp/df << 1 ==================== > > mkPnch <- function(k, df, ncp, lower.tail=TRUE, log.p=FALSE, twoExp = -53) { + stopifnot(is.numeric(k), length(k) > 1, k == (k <- as.integer(k)), + is.numeric(df), length(df) == 1L, length(ncp) == 1L, ncp >= 0, + if((k. <- min(k)) >= 0) TRUE else twoExp < -log2(-k.)) + ones <- 1 + k * 2^twoExp + qs <- ones*(df+ncp) # df+ncp = E[chi'^2] + xtra <- + if(df == 1) { ## use exact formula {incl Taylor for small x = q} + cbind(pnchi1sq = pnchi1sq(qs, ncp, lower.tail=lower.tail, log.p=log.p)) + } else if(df == 3) { + cbind(pnchi3sq = pnchi3sq(qs, ncp, lower.tail=lower.tail, log.p=log.p)) + } else { + array(NA_real_, c(length(qs), 0L)) + } + cbind(pchisq = pchisq (qs,df,ncp, lower.tail=lower.tail, log.p=log.p), + xtra, + pcAbdelA = pnchisqAbdelAty (qs,df,ncp, lower.tail=lower.tail, log.p=log.p), + pcBolKuz = pnchisqBolKuz (qs,df,ncp, lower.tail=lower.tail, log.p=log.p), + pcPatnaik= pnchisqPatnaik (qs,df,ncp, lower.tail=lower.tail, log.p=log.p), + pcPearson= pnchisqPearson (qs,df,ncp, lower.tail=lower.tail, log.p=log.p), + pcSanka_d=pnchisqSankaran_d(qs,df,ncp, lower.tail=lower.tail, log.p=log.p)) + } > > if(doExtras) { ## really slow because pchisq() is slow! + + df <- 1e30; ncp <- 99 + ks <- c(-40, -20, -15, -10, -6:6, 10, 15, 20, 40) + twoExp <- -25 + ## === + system.time(suppressWarnings( + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + )) ## 6.7 sec + + print(Pn., digits=3) # ">>" annotated: shows bug ! + ## pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d + ## 0.00e+00 0.0 0.0 0.0 0.0 0.0 + ## 0.00e+00 0.0 0.0 0.0 0.0 0.0 + ## 0.00e+00 0.0 0.0 0.0 0.0 0.0 + ## 0.00e+00 0.0 0.0 0.0 0.0 0.0 + ## 0.00e+00 0.0 0.0 0.0 0.0 0.0 + ## >> 1.00e+00 0.0 0.0 0.0 0.0 0.0 + ## >> 1.00e+00 0.0 0.0 0.0 0.0 0.0 + ## >> 1.00e+00 0.0 0.0 0.0 0.0 0.0 + ## >> 1.00e+00 0.0 0.0 0.0 0.0 0.0 + ## >> 1.00e+00 0.0 0.0 0.0 0.0 0.0 + ## 4.17e-09 0.5 0.5 0.5 0.5 0.5 + ## 1.00e+00 1.0 1.0 1.0 1.0 1.0 + ## 1.00e+00 1.0 1.0 1.0 1.0 1.0 + ## 1.00e+00 1.0 1.0 1.0 1.0 1.0 + ## 1.00e+00 1.0 1.0 1.0 1.0 1.0 + ## 1.00e+00 1.0 1.0 1.0 1.0 1.0 + ## ..... .... + tExp <- substitute(`pchisq*`(list(q == mu(1 + k * 2^TWOEXP), df==DF, ncp==NCP)), + list(TWOEXP = twoExp, DF=df, NCP=ncp)) + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main = tExp) + + kk <- seq(min(ks), max(ks), length.out=401) + qs <- (1 + kk * 2^twoExp)*df + fq <- dchisq(qs, df, ncp) + par(new=TRUE) + plot(kk, fq, type="l", col=adjustcolor(2, 1/3), lwd=3, lty=3, axes=FALSE, ann=FALSE) + + showProc.time() + + }## only if(doExtras) > ## BUG (FIXME) e.g. here: > pchisq (0.99999989*(df+ncp), df, ncp) ## --> Warning ... : not converged in 1000'000 iter [1] 0.5019134 > pnchisqRC(0.99999989*(df+ncp), df, ncp, + verbose = 1) # The same with more output! ERROR on Winbuilder 64bit Pnchisq_R(x, f, th, ... lower.tail=1, log.p=0, cut_ncp=80, it_simple=110, errmax=1e-12, reltol=1.77636e-15, epsS=8.88178e-16, itrmax=1000000, verbose=1) --> n:= max(length(.),..) = 1 pnchisq(x=11000, f=1000, theta=10000 >= cutoff_ncp = 80): -- v=exp(-th/2)=0, x/2= 5500, f/2= 500 lt= -3805.08 is very small n=2466; nomore underflow in t = exp(lt) ==> change n=2596; nomore underflow in u = exp(lu) ==> change BREAK out of for(n = 1 ..): n=5580; bound= 7.79093e-15 <= errmax; term=8.2159e-16, rel.err= 1.63692e-15 <= reltol == L_End: n=5580; term= 8.2159e-16; bound=7.79093e-15: [dbl]ans=0.501913 [1] 0.5019134 > ## both give '1', but really should give 0 > showProc.time() Time (user system elapsed): 0.01 0 0.01 > > > ### Much less extreme df ==> pchisq() *is* fast too > df <- 1e9 > ncp <- 99 > ks <- c(-40, -20, -15, -10, -6:6, 10, 15, 20, 40) > ks <- if(doExtras) -200:200 else seq(-200, 200, by=5)# more here for plot > twoExp <- -18 # well chosen for this "range" and behavior of pchisq() > ## === > Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) > showProc.time() Time (user system elapsed): 0.41 0 0.41 > > tit <- substitute(`pchisq*`(list(q == mu(1 + k * 2^TWOEXP), df==DF, ncp==NCP)), + list(TWOEXP = twoExp, DF=df, NCP=ncp)) > matplot(ks, Pn., type = "l", xlab = quote(k), ylab = "pchisq*(q, ..)", main = tit) > > cat("'Error' (difference to pchisq(*)):\n") 'Error' (difference to pchisq(*)): > dP <- Pn.[,-1] - Pn.[,1] > print(cbind(ks, q=(1+ks*2^twoExp)*df, pchisq=Pn.[,1], dP), digits = 4) ks q pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] -200 9.992e+08 1.371e-65 6.385e-73 -2.075e-71 -2.075e-71 -2.075e-71 6.385e-73 [2,] -195 9.993e+08 1.866e-62 3.078e-68 4.501e-69 4.501e-69 4.500e-69 3.078e-68 [3,] -190 9.993e+08 2.117e-59 9.708e-66 -1.716e-65 -1.716e-65 -1.716e-65 9.708e-66 [4,] -185 9.993e+08 2.003e-56 3.041e-62 7.570e-63 7.570e-63 7.570e-63 3.041e-62 [5,] -180 9.993e+08 1.581e-53 5.350e-60 -1.080e-59 -1.080e-59 -1.080e-59 5.350e-60 [6,] -175 9.993e+08 1.041e-50 5.921e-58 -8.901e-57 -8.901e-57 -8.902e-57 5.922e-58 [7,] -170 9.994e+08 5.715e-48 -1.657e-56 -4.657e-54 -4.657e-54 -4.657e-54 -1.655e-56 [8,] -165 9.994e+08 2.618e-45 -1.357e-51 -3.242e-51 -3.242e-51 -3.242e-51 -1.357e-51 [9,] -160 9.994e+08 1.001e-42 -2.601e-49 -8.966e-49 -8.966e-49 -8.966e-49 -2.601e-49 [10,] -155 9.994e+08 3.190e-40 3.016e-47 -1.484e-46 -1.484e-46 -1.485e-46 3.017e-47 [11,] -150 9.994e+08 8.486e-38 -1.133e-44 -5.297e-44 -5.297e-44 -5.297e-44 -1.133e-44 [12,] -145 9.994e+08 1.884e-35 5.358e-42 -2.705e-42 -2.705e-42 -2.705e-42 5.358e-42 [13,] -140 9.995e+08 3.489e-33 -4.320e-39 -5.617e-39 -5.617e-39 -5.617e-39 -4.320e-39 [14,] -135 9.995e+08 5.393e-31 -8.447e-37 -1.018e-36 -1.018e-36 -1.018e-36 -8.447e-37 [15,] -130 9.995e+08 6.958e-29 -9.600e-35 -1.152e-34 -1.152e-34 -1.152e-34 -9.600e-35 [16,] -125 9.995e+08 7.493e-27 -1.018e-32 -1.195e-32 -1.195e-32 -1.195e-32 -1.018e-32 [17,] -120 9.995e+08 6.737e-25 -1.867e-31 -3.211e-31 -3.211e-31 -3.211e-31 -1.867e-31 [18,] -115 9.996e+08 5.057e-23 -3.657e-29 -4.506e-29 -4.506e-29 -4.506e-29 -3.657e-29 [19,] -110 9.996e+08 3.169e-21 -4.662e-27 -5.107e-27 -5.107e-27 -5.107e-27 -4.662e-27 [20,] -105 9.996e+08 1.659e-19 -2.149e-25 -2.341e-25 -2.341e-25 -2.342e-25 -2.149e-25 [21,] -100 9.996e+08 7.255e-18 -6.368e-24 -7.060e-24 -7.060e-24 -7.060e-24 -6.368e-24 [22,] -95 9.996e+08 2.651e-16 -2.390e-22 -2.595e-22 -2.595e-22 -2.596e-22 -2.390e-22 [23,] -90 9.997e+08 8.093e-15 -1.156e-21 -1.658e-21 -1.658e-21 -1.658e-21 -1.156e-21 [24,] -85 9.997e+08 2.065e-13 -2.461e-19 -2.563e-19 -2.563e-19 -2.563e-19 -2.461e-19 [25,] -80 9.997e+08 4.408e-12 -4.042e-18 -4.212e-18 -4.212e-18 -4.212e-18 -4.042e-18 [26,] -75 9.997e+08 7.869e-11 -2.833e-19 -2.601e-18 -2.601e-18 -2.602e-18 -2.832e-19 [27,] -70 9.997e+08 1.176e-09 -1.226e-15 -1.252e-15 -1.252e-15 -1.252e-15 -1.226e-15 [28,] -65 9.998e+08 1.471e-08 -1.332e-14 -1.356e-14 -1.356e-14 -1.356e-14 -1.332e-14 [29,] -60 9.998e+08 1.541e-07 -3.367e-13 -3.385e-13 -3.385e-13 -3.385e-13 -3.367e-13 [30,] -55 9.998e+08 1.354e-06 2.132e-13 2.022e-13 2.022e-13 2.022e-13 2.132e-13 [31,] -50 9.998e+08 9.985e-06 -2.193e-11 -2.198e-11 -2.198e-11 -2.198e-11 -2.193e-11 [32,] -45 9.998e+08 6.185e-05 -2.436e-11 -2.457e-11 -2.457e-11 -2.457e-11 -2.436e-11 [33,] -40 9.998e+08 3.223e-04 -2.725e-10 -2.732e-10 -2.732e-10 -2.732e-10 -2.725e-10 [34,] -35 9.999e+08 1.415e-03 -3.299e-09 -3.300e-09 -3.300e-09 -3.300e-09 -3.299e-09 [35,] -30 9.999e+08 5.248e-03 9.686e-10 9.660e-10 9.660e-10 9.660e-10 9.686e-10 [36,] -25 9.999e+08 1.648e-02 -2.664e-08 -2.665e-08 -2.665e-08 -2.665e-08 -2.664e-08 [37,] -20 9.999e+08 4.400e-02 -3.491e-08 -3.491e-08 -3.491e-08 -3.491e-08 -3.491e-08 [38,] -15 9.999e+08 1.004e-01 5.839e-09 5.845e-09 5.845e-09 5.844e-09 5.839e-09 [39,] -10 1.000e+09 1.968e-01 -3.265e-07 -3.264e-07 -3.264e-07 -3.265e-07 -3.265e-07 [40,] -5 1.000e+09 3.349e-01 -3.051e-07 -3.051e-07 -3.051e-07 -3.051e-07 -3.051e-07 [41,] 0 1.000e+09 5.000e-01 -1.483e-07 -1.483e-07 -1.483e-07 -1.483e-07 -1.483e-07 [42,] 5 1.000e+09 6.651e-01 -1.605e-06 -1.605e-06 -1.605e-06 -1.605e-06 -1.605e-06 [43,] 10 1.000e+09 8.032e-01 -2.578e-07 -2.578e-07 -2.578e-07 -2.578e-07 -2.578e-07 [44,] 15 1.000e+09 8.996e-01 -2.107e-06 -2.107e-06 -2.107e-06 -2.107e-06 -2.107e-06 [45,] 20 1.000e+09 9.560e-01 -1.469e-06 -1.469e-06 -1.469e-06 -1.469e-06 -1.469e-06 [46,] 25 1.000e+09 9.835e-01 -4.975e-07 -4.975e-07 -4.975e-07 -4.975e-07 -4.975e-07 [47,] 30 1.000e+09 9.948e-01 -1.839e-06 -1.839e-06 -1.839e-06 -1.839e-06 -1.839e-06 [48,] 35 1.000e+09 9.986e-01 -5.340e-07 -5.340e-07 -5.340e-07 -5.340e-07 -5.340e-07 [49,] 40 1.000e+09 9.997e-01 -1.073e-06 -1.073e-06 -1.073e-06 -1.073e-06 -1.073e-06 [50,] 45 1.000e+09 9.999e-01 -2.249e-06 -2.249e-06 -2.249e-06 -2.249e-06 -2.249e-06 [51,] 50 1.000e+09 1.000e+00 -9.430e-07 -9.430e-07 -9.430e-07 -9.430e-07 -9.430e-07 [52,] 55 1.000e+09 1.000e+00 2.446e-07 2.446e-07 2.446e-07 2.446e-07 2.446e-07 [53,] 60 1.000e+09 1.000e+00 -1.547e-07 -1.547e-07 -1.547e-07 -1.547e-07 -1.547e-07 [54,] 65 1.000e+09 1.000e+00 -1.478e-08 -1.478e-08 -1.478e-08 -1.478e-08 -1.478e-08 [55,] 70 1.000e+09 1.000e+00 -1.183e-09 -1.183e-09 -1.183e-09 -1.183e-09 -1.183e-09 [56,] 75 1.000e+09 1.000e+00 -7.931e-11 -7.931e-11 -7.931e-11 -7.931e-11 -7.931e-11 [57,] 80 1.000e+09 1.000e+00 -4.450e-12 -4.450e-12 -4.450e-12 -4.450e-12 -4.450e-12 [58,] 85 1.000e+09 1.000e+00 -2.089e-13 -2.088e-13 -2.088e-13 -2.088e-13 -2.089e-13 [59,] 90 1.000e+09 1.000e+00 -8.216e-15 -8.216e-15 -8.216e-15 -8.216e-15 -8.216e-15 [60,] 95 1.000e+09 1.000e+00 2.279e-07 2.279e-07 2.279e-07 2.279e-07 2.279e-07 [61,] 100 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [62,] 105 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [63,] 110 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [64,] 115 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [65,] 120 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [66,] 125 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [67,] 130 1.000e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [68,] 135 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [69,] 140 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [70,] 145 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [71,] 150 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [72,] 155 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [73,] 160 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [74,] 165 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [75,] 170 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [76,] 175 1.001e+09 1.000e+00 6.599e-07 6.599e-07 6.599e-07 6.599e-07 6.599e-07 [77,] 180 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [78,] 185 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [79,] 190 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [80,] 195 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 [81,] 200 1.001e+09 1.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 0.000e+00 > matplot(ks, dP, type = "l", xlab = quote(k), main = paste("Difference", tit," - pchisq(..)")) > abline(h=0, lty=3) > ## the difference to all 5 approx. is almost *IDENTICAL* > ## ==> are the approximations all more accurate than pchisq() here ? > options(op) # revert > summary(warnings()) Summary of (a total of 2) warning messages: 1x : In qchisq(p, df = 1, ncp, lower.tail = lower.tail, log.p = log.p) : full precision may not have been achieved in 'qnchisq' 1x : In pchisq(x, df = 1, ncp = ncp, lower.tail = lower.tail, ... : full precision may not have been achieved in 'pnchisq' > > ## Look at "smoothness" via first differences: > matplot(ks[-1], diff(Pn.), type = "l", xlab = quote(k)) > abline(h=0, lty=3) > > nk <- length(ks) > matplot(ks[-c(1,nk)], diff(Pn., differences= 2), type = "l", xlab = quote(k)) > abline(h=0, lty=3) > > matplot(ks[-c(1:2,nk)], diff(Pn., differences= 3), type = "l", xlab = quote(k)) > abline(h=0, lty=3) ##---> start seeing noise > > ## Here, we see a LOT of noise : only in the first curve == pchisq() ! > matplot(ks[-c(1:2,nk-1L,nk)], diff(Pn., differences= 4), type = "l", xlab = quote(k)) > abline(h=0, lty=3) > ## And zooming in to "zero" : log |.| scale > matplot(ks[-c(1:2,nk-1L,nk)], abs(diff(Pn., differences= 4)), log = "y", type = "l", xlab = quote(k)) Warning messages: 1: In xy.coords(x, y, xlabel, ylabel, log = log, recycle = TRUE) : 100 y values <= 0 omitted from logarithmic plot 2: In xy.coords(x, y, xlabel, ylabel, log) : 15 y values <= 0 omitted from logarithmic plot > > showProc.time() Time (user system elapsed): 0.03 0 0.03 > > ##=== L 2. large ncp, df/ncp << 1 ==================== > > pchiTit <- function(twoE, df, ncp, fN = "pchisq*", xtr = "", ncN = "ncp") { + substitute(FUN(list(q == mu(1 + k* 2^TWO_E)*XTR, mu == {nu+lambda == DF+NCP}, df == DF, NCN == NCP)), + list(FUN = fN, TWO_E = twoE, XTR=xtr, DF=df, NCN=ncN, NCP=ncp)) + ## sprintf("%s(q = μ(1 + k* 2^%g)%s, µ = ν+λ = df+ncp; df=%g, %s=%g)", + ## fN, twoE, xtr, df, ncN, ncp) + } > > pchiTit.1 <- function(twoE, df, ncp) + pchiTit(twoE, df, ncp, fN = "pchi*", xtr = " - pchi.1") > pchiTit.n.d <- function(twoE, df, ncp) pchiTit(twoE, df, ncp=ncp/df, ncN="ncp/df") > > ks <- c(-40, -20, -15, -10, -6:6, 10, 15, 20, 40) > > if(okR_Lrg) { ## R <= 3.6.1 gave an (almost ?) infinite loop here !! + + ncp <- 1e20; df <- 99 + twoExp <- -35 + ## === + system.time(suppressWarnings( + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + )) ## ~ 0.3 + + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + ## pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d + ## 0 2.93e-09 1 2.93e-09 2.93e-09 2.93e-09 + ## 0 1.80e-03 1 1.80e-03 1.80e-03 1.80e-03 + ## 0 1.45e-02 1 1.45e-02 1.45e-02 1.45e-02 + ## 0 7.28e-02 1 7.28e-02 7.28e-02 7.28e-02 + ## 0 1.91e-01 1 1.91e-01 1.91e-01 1.91e-01 + ## 0 2.33e-01 1 2.33e-01 2.33e-01 2.33e-01 + ## 0 2.80e-01 1 2.80e-01 2.80e-01 2.80e-01 + ## 0 3.31e-01 1 3.31e-01 3.31e-01 3.31e-01 + ## 0 3.86e-01 1 3.86e-01 3.86e-01 3.86e-01 + ## 0 4.42e-01 1 4.42e-01 4.42e-01 4.42e-01 + ## 0 5.00e-01 1 5.00e-01 5.00e-01 5.00e-01 + ## 0 5.58e-01 1 5.58e-01 5.58e-01 5.58e-01 + ## 0 6.14e-01 1 6.14e-01 6.14e-01 6.14e-01 + ## 0 6.69e-01 1 6.69e-01 6.69e-01 6.69e-01 + ## 0 7.20e-01 1 7.20e-01 7.20e-01 7.20e-01 + ## 0 7.67e-01 1 7.67e-01 7.67e-01 7.67e-01 + ## 0 8.09e-01 1 8.09e-01 8.09e-01 8.09e-01 + ## 0 9.27e-01 1 9.27e-01 9.27e-01 9.27e-01 + ## 0 9.85e-01 1 9.85e-01 9.85e-01 9.85e-01 + ## 0 9.98e-01 1 9.98e-01 9.98e-01 9.98e-01 + ## 1 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 + + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main= pchiTit(twoExp,df,ncp)) + + if(doExtras) { + ## less extreme, same phenomenom: + ncp <- 1e9; df <- 99 ; twoExp <- -17 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main= pchiTit(twoExp,df,ncp)) + + ## less extreme, same phenomenom: still + ncp <- 1e7; df <- 99 ; twoExp <- -14 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main= pchiTit(twoExp,df,ncp)) + + ## even less extreme, same phenomenom: still + ncp <- 4e6; df <- 99 ; twoExp <- -13 + ## --- + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # pchisq = Pearson = Sanka_d ~~ AbdelA, Patnaik + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main= pchiTit(twoExp,df,ncp)) + + } # only if(.X.) + + } # only if(okR..) pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 0 2.93e-09 1 2.93e-09 2.93e-09 2.93e-09 [2,] 0 1.80e-03 1 1.80e-03 1.80e-03 1.80e-03 [3,] 0 1.45e-02 1 1.45e-02 1.45e-02 1.45e-02 [4,] 0 7.28e-02 1 7.28e-02 7.28e-02 7.28e-02 [5,] 0 1.91e-01 1 1.91e-01 1.91e-01 1.91e-01 [6,] 0 2.33e-01 1 2.33e-01 2.33e-01 2.33e-01 [7,] 0 2.80e-01 1 2.80e-01 2.80e-01 2.80e-01 [8,] 0 3.31e-01 1 3.31e-01 3.31e-01 3.31e-01 [9,] 0 3.86e-01 1 3.86e-01 3.86e-01 3.86e-01 [10,] 0 4.42e-01 1 4.42e-01 4.42e-01 4.42e-01 [11,] 0 5.00e-01 1 5.00e-01 5.00e-01 5.00e-01 [12,] 0 5.58e-01 1 5.58e-01 5.58e-01 5.58e-01 [13,] 0 6.14e-01 1 6.14e-01 6.14e-01 6.14e-01 [14,] 0 6.69e-01 1 6.69e-01 6.69e-01 6.69e-01 [15,] 0 7.20e-01 1 7.20e-01 7.20e-01 7.20e-01 [16,] 0 7.67e-01 1 7.67e-01 7.67e-01 7.67e-01 [17,] 0 8.09e-01 1 8.09e-01 8.09e-01 8.09e-01 [18,] 0 9.27e-01 1 9.27e-01 9.27e-01 9.27e-01 [19,] 0 9.85e-01 1 9.85e-01 9.85e-01 9.85e-01 [20,] 0 9.98e-01 1 9.98e-01 9.98e-01 9.98e-01 [21,] 1 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 > > showProc.time() Time (user system elapsed): 3.24 0 3.27 > > ## Here pchisq() seems "perfect" > ncp <- 1e6; df <- 99 ; twoExp <- -12 > ## --- > Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) > print(Pn., digits=3) # pchisq = Pearson = Sanka_d ~~ AbdelA, Patnaik pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 4.92e-07 4.83e-07 1 4.83e-07 4.92e-07 4.92e-07 [2,] 7.26e-03 7.24e-03 1 7.24e-03 7.26e-03 7.26e-03 [3,] 3.34e-02 3.34e-02 1 3.34e-02 3.34e-02 3.34e-02 [4,] 1.11e-01 1.11e-01 1 1.11e-01 1.11e-01 1.11e-01 [5,] 2.32e-01 2.32e-01 1 2.32e-01 2.32e-01 2.32e-01 [6,] 2.71e-01 2.71e-01 1 2.71e-01 2.71e-01 2.71e-01 [7,] 3.13e-01 3.13e-01 1 3.13e-01 3.13e-01 3.13e-01 [8,] 3.57e-01 3.57e-01 1 3.57e-01 3.57e-01 3.57e-01 [9,] 4.04e-01 4.04e-01 1 4.04e-01 4.04e-01 4.04e-01 [10,] 4.52e-01 4.52e-01 1 4.52e-01 4.52e-01 4.52e-01 [11,] 5.00e-01 5.00e-01 1 5.00e-01 5.00e-01 5.00e-01 [12,] 5.49e-01 5.49e-01 1 5.49e-01 5.49e-01 5.49e-01 [13,] 5.97e-01 5.97e-01 1 5.97e-01 5.97e-01 5.97e-01 [14,] 6.43e-01 6.43e-01 1 6.43e-01 6.43e-01 6.43e-01 [15,] 6.87e-01 6.88e-01 1 6.88e-01 6.87e-01 6.87e-01 [16,] 7.29e-01 7.29e-01 1 7.29e-01 7.29e-01 7.29e-01 [17,] 7.68e-01 7.68e-01 1 7.68e-01 7.68e-01 7.68e-01 [18,] 8.89e-01 8.89e-01 1 8.89e-01 8.89e-01 8.89e-01 [19,] 9.66e-01 9.66e-01 1 9.66e-01 9.66e-01 9.66e-01 [20,] 9.93e-01 9.93e-01 1 9.93e-01 9.93e-01 9.93e-01 [21,] 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 > matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", main= pchiTit(twoExp,df,ncp)) > > kk <- seq(min(ks), max(ks), length.out=401) > qs <- (1 + kk * 2^twoExp)*(df+ncp) > fq <- dchisq(qs, df, ncp) > par(new=TRUE) > plot(kk, fq, type="l", col=adjustcolor(2, 1/3), lwd=3, lty=3, axes=FALSE, ann=FALSE) > showProc.time() Time (user system elapsed): 1.48 0 1.48 > > ##=== df=1 and df=3 ==== here we have exact formula ! ================== > > ## 10'000 : "too small" for asymptotic approx: > ncp <- 10000; df <- 1 ; twoExp <- -7 > Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) > print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" pchisq pnchi1sq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 1.04e-65 1.04e-65 1.10e-69 1 7.41e-70 2.00e-65 1.04e-65 [2,] 1.98e-16 1.98e-16 7.73e-17 1 7.60e-17 2.04e-16 1.98e-16 [3,] 7.84e-10 7.84e-10 5.36e-10 1 5.34e-10 7.91e-10 7.84e-10 [4,] 3.43e-05 3.43e-05 3.08e-05 1 3.08e-05 3.44e-05 3.43e-05 [5,] 8.97e-03 8.97e-03 8.78e-03 1 8.78e-03 8.97e-03 8.97e-03 [6,] 2.46e-02 2.46e-02 2.43e-02 1 2.43e-02 2.46e-02 2.46e-02 [7,] 5.82e-02 5.82e-02 5.79e-02 1 5.79e-02 5.82e-02 5.82e-02 [8,] 1.20e-01 1.20e-01 1.20e-01 1 1.20e-01 1.20e-01 1.20e-01 [9,] 2.18e-01 2.18e-01 2.18e-01 1 2.18e-01 2.18e-01 2.18e-01 [10,] 3.50e-01 3.50e-01 3.50e-01 1 3.50e-01 3.50e-01 3.50e-01 [11,] 5.02e-01 5.02e-01 5.03e-01 1 5.03e-01 5.02e-01 5.02e-01 [12,] 6.54e-01 6.54e-01 6.54e-01 1 6.54e-01 6.54e-01 6.54e-01 [13,] 7.83e-01 7.83e-01 7.83e-01 1 7.83e-01 7.83e-01 7.83e-01 [14,] 8.79e-01 8.79e-01 8.79e-01 1 8.79e-01 8.79e-01 8.79e-01 [15,] 9.40e-01 9.40e-01 9.40e-01 1 9.40e-01 9.40e-01 9.40e-01 [16,] 9.74e-01 9.74e-01 9.74e-01 1 9.74e-01 9.74e-01 9.74e-01 [17,] 9.90e-01 9.90e-01 9.90e-01 1 9.90e-01 9.90e-01 9.90e-01 [18,] 1.00e+00 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 [19,] 1.00e+00 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 [20,] 1.00e+00 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 [21,] 1.00e+00 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 > matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.1(twoExp,df,ncp)) > > ## now absolute *difference* to true pchi1sq() : > print(Pn.[,-c(2,4)]-Pn.[,2], digits=3) pchisq pcAbdelA pcPatnaik pcPearson pcSanka_d [1,] 3.26e-77 -1.04e-65 -1.04e-65 9.63e-66 -9.20e-69 [2,] 6.62e-28 -1.21e-16 -1.22e-16 5.93e-18 -1.84e-20 [3,] 2.50e-21 -2.48e-10 -2.50e-10 6.65e-12 -2.95e-14 [4,] 5.69e-17 -3.49e-06 -3.51e-06 4.88e-08 -3.66e-10 [5,] 9.09e-15 -1.89e-04 -1.89e-04 9.77e-07 -1.91e-08 [6,] 1.06e-13 -2.82e-04 -2.83e-04 6.57e-07 -2.85e-08 [7,] 5.20e-14 -2.94e-04 -2.94e-04 -5.96e-07 -2.97e-08 [8,] 1.93e-13 -1.38e-04 -1.37e-04 -2.41e-06 -1.42e-08 [9,] 1.81e-13 1.82e-04 1.84e-04 -3.48e-06 1.78e-08 [10,] 1.08e-12 5.19e-04 5.20e-04 -2.61e-06 5.16e-08 [11,] 2.20e-12 6.65e-04 6.65e-04 -2.24e-08 6.65e-08 [12,] 3.05e-13 5.25e-04 5.24e-04 2.53e-06 5.27e-08 [13,] 6.76e-14 1.99e-04 1.97e-04 3.38e-06 2.03e-08 [14,] 1.85e-12 -1.12e-04 -1.13e-04 2.38e-06 -1.08e-08 [15,] 1.94e-12 -2.71e-04 -2.72e-04 6.83e-07 -2.68e-08 [16,] 2.91e-12 -2.73e-04 -2.73e-04 -5.24e-07 -2.71e-08 [17,] -4.31e-14 -1.94e-04 -1.93e-04 -8.92e-07 -1.92e-08 [18,] 1.50e-12 -5.88e-06 -5.84e-06 -6.74e-08 -5.64e-10 [19,] 5.91e-09 -2.05e-09 -2.02e-09 -3.40e-11 -1.78e-13 [20,] 2.45e-14 -2.40e-14 -2.34e-14 -4.44e-16 0.00e+00 [21,] 0.00e+00 0.00e+00 0.00e+00 0.00e+00 0.00e+00 > > matplot(ks, Pn.[,-c(2,4)]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > legend("topright", colnames(Pn.)[-c(2,4)], lty=1:5, col=1:5, bty="n") > > j.dr <- 2:5 # drop > matplot(ks, Pn.[,-j.dr]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > legend("topright", colnames(Pn.)[-j.dr], lty=1:5, col=1:5, bty="n") > > j.d2 <- 2:6 # drop > matplot(ks, Pn.[,-j.d2]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > legend("topright", colnames(Pn.)[-j.d2], lty=1:5, col=1:5, bty="n") > > showProc.time()# -- Time (user system elapsed): 0.02 0.01 0.03 > > ## 1e6 : ??? > ncp <- 1e6; df <- 1 ; twoExp <- -13 > Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) > showProc.time() Time (user system elapsed): 1.56 0 1.56 > print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" pchisq pnchi1sq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 0.00726 0.00726 0.00725 1 0.00725 0.00726 0.00726 [2,] 0.11105 0.11105 0.11104 1 0.11104 0.11105 0.11105 [3,] 0.17998 0.17998 0.17999 1 0.17999 0.17998 0.17998 [4,] 0.27092 0.27092 0.27095 1 0.27095 0.27092 0.27092 [5,] 0.35727 0.35727 0.35732 1 0.35732 0.35727 0.35727 [6,] 0.38029 0.38029 0.38035 1 0.38035 0.38029 0.38029 [7,] 0.40374 0.40374 0.40380 1 0.40380 0.40374 0.40374 [8,] 0.42755 0.42755 0.42761 1 0.42761 0.42755 0.42755 [9,] 0.45162 0.45162 0.45168 1 0.45168 0.45162 0.45162 [10,] 0.47586 0.47586 0.47593 1 0.47593 0.47586 0.47586 [11,] 0.50020 0.50020 0.50027 1 0.50027 0.50020 0.50020 [12,] 0.52453 0.52453 0.52460 1 0.52460 0.52453 0.52453 [13,] 0.54877 0.54877 0.54884 1 0.54884 0.54877 0.54877 [14,] 0.57283 0.57283 0.57290 1 0.57290 0.57283 0.57283 [15,] 0.59662 0.59662 0.59668 1 0.59668 0.59662 0.59662 [16,] 0.62006 0.62006 0.62011 1 0.62011 0.62006 0.62006 [17,] 0.64306 0.64306 0.64311 1 0.64311 0.64306 0.64306 [18,] 0.72929 0.72929 0.72932 1 0.72932 0.72929 0.72929 [19,] 0.82006 0.82006 0.82007 1 0.82007 0.82006 0.82006 [20,] 0.88885 0.88885 0.88884 1 0.88884 0.88885 0.88885 [21,] 0.99263 0.99263 0.99262 1 0.99262 0.99263 0.99263 > matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.1(twoExp,df,ncp)) > ## now absolute *difference* to true pchi1sq() : > print(Pn.[,-c(2,4)]-Pn.[,2], digits=3) pchisq pcAbdelA pcPatnaik pcPearson pcSanka_d [1,] -2.55e-12 -1.67e-05 -1.67e-05 9.18e-09 -1.67e-11 [2,] -6.51e-12 -1.56e-05 -1.56e-05 -2.18e-08 -1.56e-11 [3,] -2.62e-11 6.97e-06 6.99e-06 -3.25e-08 6.91e-12 [4,] -9.57e-11 3.46e-05 3.46e-05 -3.32e-08 3.46e-11 [5,] -1.02e-11 5.38e-05 5.38e-05 -2.45e-08 5.38e-11 [6,] -1.02e-10 5.75e-05 5.75e-05 -2.11e-08 5.75e-11 [7,] -7.16e-11 6.07e-05 6.07e-05 -1.74e-08 6.07e-11 [8,] -9.82e-12 6.32e-05 6.32e-05 -1.33e-08 6.32e-11 [9,] -1.53e-10 6.50e-05 6.50e-05 -9.04e-09 6.50e-11 [10,] -8.42e-11 6.61e-05 6.61e-05 -4.57e-09 6.61e-11 [11,] -2.38e-10 6.65e-05 6.65e-05 -2.25e-11 6.65e-11 [12,] 5.77e-11 6.61e-05 6.61e-05 4.53e-09 6.61e-11 [13,] -3.43e-10 6.50e-05 6.50e-05 8.99e-09 6.51e-11 [14,] -2.29e-11 6.32e-05 6.32e-05 1.33e-08 6.32e-11 [15,] 7.08e-11 6.07e-05 6.07e-05 1.73e-08 6.07e-11 [16,] -3.57e-10 5.76e-05 5.76e-05 2.11e-08 5.76e-11 [17,] -5.32e-11 5.39e-05 5.39e-05 2.44e-08 5.39e-11 [18,] -4.41e-10 3.47e-05 3.47e-05 3.31e-08 3.48e-11 [19,] -5.69e-10 7.18e-06 7.16e-06 3.24e-08 7.26e-12 [20,] 3.49e-11 -1.53e-05 -1.53e-05 2.18e-08 -1.53e-11 [21,] -1.20e-10 -1.68e-05 -1.68e-05 -9.12e-09 -1.68e-11 > > matplot(ks, Pn.[,-c(2,4)]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > legend("topright", colnames(Pn.)[-c(2,4)], lty=1:5, col=1:5, bty="n") > > j.dr <- 2:5 # drop > matplot(ks, Pn.[,-j.dr]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > legend("topright", colnames(Pn.)[-j.dr], lty=1:5, col=1:5, bty="n") > > ## Convincing: here, Sanka_d is *better* than R's pchisq() ! > j.d2 <- 2:6 # drop > matplot(ks, Pn.[,-j.d2]-Pn.[,2], type = "b", xlab = quote(k), ylab = "pchisq*(q, ..) - pchi1sq()", + main = pchiTit.1(twoExp,df,ncp)) > abline(h=0, lty=3, col=adjustcolor(1, 1/4)) > legend("topright", colnames(Pn.)[-j.d2], lty=1:5, col=1:5, bty="n") > showProc.time() Time (user system elapsed): 0.01 0 0.02 > > if(okR_Lrg) { ## R <= 3.6.1 gave an (almost ?) infinite loop here !! + ## vvvv + ncp <- 1e9; df <- 3 ; twoExp <- -17 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit(twoExp,df,ncp)) + showProc.time() + } # only if(okR..) pchisq pnchi3sq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 0 6.98e-07 6.97e-07 1 6.97e-07 6.98e-07 6.98e-07 [2,] 0 7.92e-03 7.92e-03 1 7.92e-03 7.92e-03 7.92e-03 [3,] 0 3.52e-02 3.52e-02 1 3.52e-02 3.52e-02 3.52e-02 [4,] 0 1.14e-01 1.14e-01 1 1.14e-01 1.14e-01 1.14e-01 [5,] 0 2.35e-01 2.35e-01 1 2.35e-01 2.35e-01 2.35e-01 [6,] 0 2.73e-01 2.73e-01 1 2.73e-01 2.73e-01 2.73e-01 [7,] 0 3.15e-01 3.15e-01 1 3.15e-01 3.15e-01 3.15e-01 [8,] 0 3.59e-01 3.59e-01 1 3.59e-01 3.59e-01 3.59e-01 [9,] 0 4.05e-01 4.05e-01 1 4.05e-01 4.05e-01 4.05e-01 [10,] 0 4.52e-01 4.52e-01 1 4.52e-01 4.52e-01 4.52e-01 [11,] 0 5.00e-01 5.00e-01 1 5.00e-01 5.00e-01 5.00e-01 [12,] 0 5.48e-01 5.48e-01 1 5.48e-01 5.48e-01 5.48e-01 [13,] 0 5.95e-01 5.95e-01 1 5.95e-01 5.95e-01 5.95e-01 [14,] 0 6.41e-01 6.41e-01 1 6.41e-01 6.41e-01 6.41e-01 [15,] 0 6.85e-01 6.85e-01 1 6.85e-01 6.85e-01 6.85e-01 [16,] 0 7.27e-01 7.27e-01 1 7.27e-01 7.27e-01 7.27e-01 [17,] 0 7.65e-01 7.65e-01 1 7.65e-01 7.65e-01 7.65e-01 [18,] 0 8.86e-01 8.86e-01 1 8.86e-01 8.86e-01 8.86e-01 [19,] 0 9.65e-01 9.65e-01 1 9.65e-01 9.65e-01 9.65e-01 [20,] 0 9.92e-01 9.92e-01 1 9.92e-01 9.92e-01 9.92e-01 [21,] 0 1.00e+00 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 Time (user system elapsed): 3.11 0 3.11 There were 21 warnings (use warnings() to see them) > > > ##=== L 3. BOTH large ncp, large df ==================== > > if(okR_Lrg) { ## R <= 3.6.1 gave an (almost ?) infinite loop here !! + + df <- 1e9; ncp <- 1 * df ; twoExp <- -17 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + if(doExtras) { ## because it's a bit costly here : + df <- 1e8; ncp <- 2 * df ; twoExp <- -16 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + df <- 1e7; ncp <- 1/2 * df ; twoExp <- -14 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + ## pnchisq still "broken"; others good + df <- 1e6; ncp <- 10 * df ; twoExp <- -14 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + ## pchisq *NON*-monotone !! + df <- 4e6; ncp <- .5 * df ; twoExp <- -14 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + } # only if(.X.) + showProc.time() + + ## pchisq ok + df <- 2e6; ncp <- .5 * df ; twoExp <- -14 + Pn. <- mkPnch(ks, df=df, ncp=ncp, twoExp=twoExp) + print(Pn., digits=3) # ">>" pcPolKuz is *NOT* for this; R's pchisq is full wrong; other "coincide" + matplot(ks, Pn., type = "b", xlab = quote(k), ylab = "pchisq*(q, ..)", + main = pchiTit.n.d(twoExp,df,ncp)) + + } # only if(okR..) pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 0 1.63e-15 1 1.63e-15 1.63e-15 1.63e-15 [2,] 0 4.07e-05 1 4.07e-05 4.07e-05 4.07e-05 [3,] 0 1.56e-03 1 1.56e-03 1.56e-03 1.56e-03 [4,] 0 2.44e-02 1 2.44e-02 2.44e-02 2.44e-02 [5,] 0 1.19e-01 1 1.19e-01 1.19e-01 1.19e-01 [6,] 0 1.62e-01 1 1.62e-01 1.62e-01 1.62e-01 [7,] 0 2.15e-01 1 2.15e-01 2.15e-01 2.15e-01 [8,] 0 2.77e-01 1 2.77e-01 2.77e-01 2.77e-01 [9,] 0 3.47e-01 1 3.47e-01 3.47e-01 3.47e-01 [10,] 0 4.22e-01 1 4.22e-01 4.22e-01 4.22e-01 [11,] 0 5.00e-01 1 5.00e-01 5.00e-01 5.00e-01 [12,] 0 5.78e-01 1 5.78e-01 5.78e-01 5.78e-01 [13,] 0 6.53e-01 1 6.53e-01 6.53e-01 6.53e-01 [14,] 0 7.23e-01 1 7.23e-01 7.23e-01 7.23e-01 [15,] 0 7.85e-01 1 7.85e-01 7.85e-01 7.85e-01 [16,] 0 8.38e-01 1 8.38e-01 8.38e-01 8.38e-01 [17,] 0 8.81e-01 1 8.81e-01 8.81e-01 8.81e-01 [18,] 0 9.76e-01 1 9.76e-01 9.76e-01 9.76e-01 [19,] 0 9.98e-01 1 9.98e-01 9.98e-01 9.98e-01 [20,] 0 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 [21,] 1 1.00e+00 1 1.00e+00 1.00e+00 1.00e+00 Time (user system elapsed): 2.61 0.02 2.62 pchisq pcAbdelA pcBolKuz pcPatnaik pcPearson pcSanka_d [1,] 0.00478 0.00478 1 0.00478 0.00478 0.00478 [2,] 0.09767 0.09767 1 0.09767 0.09767 0.09767 [3,] 0.16576 0.16576 1 0.16576 0.16576 0.16576 [4,] 0.25875 0.25875 1 0.25875 0.25875 0.25875 [5,] 0.34894 0.34895 1 0.34895 0.34894 0.34894 [6,] 0.37319 0.37319 1 0.37319 0.37319 0.37319 [7,] 0.39794 0.39795 1 0.39795 0.39794 0.39794 [8,] 0.42312 0.42312 1 0.42312 0.42312 0.42312 [9,] 0.44861 0.44861 1 0.44861 0.44861 0.44861 [10,] 0.47431 0.47432 1 0.47432 0.47431 0.47431 [11,] 0.50012 0.50013 1 0.50013 0.50012 0.50012 [12,] 0.52593 0.52593 1 0.52593 0.52593 0.52593 [13,] 0.55162 0.55163 1 0.55163 0.55162 0.55162 [14,] 0.57711 0.57711 1 0.57711 0.57711 0.57711 [15,] 0.60227 0.60228 1 0.60228 0.60227 0.60227 [16,] 0.62701 0.62702 1 0.62702 0.62701 0.62701 [17,] 0.65124 0.65125 1 0.65125 0.65124 0.65124 [18,] 0.74136 0.74136 1 0.74136 0.74136 0.74136 [19,] 0.83425 0.83425 1 0.83425 0.83425 0.83425 [20,] 0.90226 0.90226 1 0.90226 0.90226 0.90226 [21,] 0.99517 0.99517 1 0.99517 0.99517 0.99517 There were 20 warnings (use warnings() to see them) > > showProc.time() Time (user system elapsed): 1.55 0 1.55 > > ### Part 3 : qchisq (non-central!) > ### ------------------------------- > > if(!dev.interactive(orNone=TRUE)) { dev.off(); pdf("chisq-nonc-3.pdf") } > > ### Bug 875 {see also ~/R/r-devel/R/tests/d-p-q-r-tests.R > (q49.7 <- qchisq(0.025, 31, ncp=1, lower.tail=FALSE))## now ok: 49.7766 [1] 49.77662 > pb <- pchisq(q49.7, 31, ncp=1, lower.tail=FALSE) > all.equal(pb, 0.025, tol=0) # 2.058e-13 [Lnx 64b]; 2.0609e-13 [Win 32b] [1] "Mean relative difference: 2.058076e-13" > stopifnot(all.equal(pb, 0.025, tol= 1e-12)) > > ## Ensuing things I tried : > x <- seq(0, 20, len = 101) > plot(x, pnc <- pchisq(x, 5, ncp = 1.1), type = 'l', col = 'red') > xx <- qchisq(pnc, 5, ncp = 1.1) > stopifnot(all.equal(x, xx))#TRUE > all.equal(x, xx, tol = 0) # 1.9012e-13, later 1.835842e-14 (Linux) [1] "Mean relative difference: 1.413163e-14" > > plot(x, pncR <- pchisq(x, 5, ncp = 1.1, lower = FALSE), type = 'l', col = 'red') > (pnc + pncR) - 1 [1] 0.000000e+00 -1.110223e-16 0.000000e+00 0.000000e+00 0.000000e+00 [6] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [11] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [16] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [21] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [26] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [31] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [36] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [41] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [46] -1.110223e-16 0.000000e+00 0.000000e+00 -1.110223e-16 0.000000e+00 [51] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [56] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [61] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [66] -1.110223e-16 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [71] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [76] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [81] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [86] 0.000000e+00 0.000000e+00 0.000000e+00 -1.110223e-16 -1.110223e-16 [91] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [96] 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 0.000000e+00 [101] 0.000000e+00 > stopifnot(all.equal(pnc + pncR, rep(1, length(pnc)))) > xx0 <- qchisq(pncR, 5, ncp = 1.1, lower = FALSE) > all.equal( x, xx0, tol = 0) # 1.877586e-13; then 1.8364e-14 [1] "Mean relative difference: 1.422707e-14" > all.equal(xx, xx0, tol = 0) # 5.942721e-13; then 6.2907e-13, 6.2172e-14 [1] "Mean relative difference: 7.326022e-16" > stopifnot(all.equal(x, xx0)) > > plot(x, LpncR <- pchisq(x, 5, ncp = 1.1, lower = FALSE, log = TRUE), + type = 'l', col = 'red') > Lxx0 <- qchisq(LpncR, 5, ncp = 1.1, lower = FALSE, log = TRUE) > all.equal(x, Lxx0, tol = 0)# 1.8775..e-13; 1.8364e-14 [1] "Mean relative difference: 1.420761e-14" > all.equal(log(pncR), LpncR, tol = 0)# 0, now 2.246e-16 [1] "Mean relative difference: 1.862636e-16" > all.equal(log(1 - pnc), LpncR, tol = 0)# 4.661586e-16; now 2.246e-16 [1] "Mean relative difference: 5.60379e-16" > all.equal(log1p(- pnc), LpncR, tol = 0)# 4.626185e-16; now TRUE [1] "Mean relative difference: 5.618439e-16" > > showProc.time() Time (user system elapsed): 0.12 0 0.13 > ## source("/u/maechler/R/MM/NUMERICS/dpq-functions/qnchisq.R")#-> qnchisq.appr*() > > ## The values from Johnson et al (1995), Table 29.2, p.464 > p. <- c(0.95, 0.05) > nu. <- c(2,4,7) > lam <- c(1,4,16,25) > str(pars <- expand.grid(ncp=lam, df=nu., p= p., KEEP.OUT.ATTRS=FALSE)[,3:1]) 'data.frame': 24 obs. of 3 variables: $ p : num 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 ... $ df : num 2 2 2 2 4 4 4 4 7 7 ... $ ncp: num 1 4 16 25 1 4 16 25 1 4 ... > ## 'data.frame': 24 obs. of 3 variables: > ## $ p : num 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 0.95 ... > ## $ df : num 2 2 2 2 4 4 4 4 7 7 ... > ## $ ncp: num 1 4 16 25 1 4 16 25 1 4 ... > > qch <- with(pars, qchisq(p=p, df=df, ncp=ncp)) > p.q <- with(pars, pchisq(qch, df=df, ncp=ncp)) > > cbind(pars, qch, p.q, relE = signif(1 - p.q / pars$p, 4)) ## very accurate p df ncp qch p.q relE 1 0.95 2 1 8.6422039 0.95 3.331e-16 2 0.95 2 4 14.6402116 0.95 3.442e-15 3 0.95 2 16 33.0542126 0.95 -8.882e-15 4 0.95 2 25 45.3082281 0.95 2.887e-15 5 0.95 4 1 11.7072278 0.95 5.662e-15 6 0.95 4 4 17.3093229 0.95 5.995e-15 7 0.95 4 16 35.4270110 0.95 -1.199e-14 8 0.95 4 25 47.6127674 0.95 8.660e-15 9 0.95 7 1 16.0039003 0.95 -5.551e-15 10 0.95 7 4 21.2280338 0.95 6.661e-15 11 0.95 7 16 38.9700904 0.95 1.132e-14 12 0.95 7 25 51.0605938 0.95 1.488e-14 13 0.05 2 1 0.1683911 0.05 -2.398e-14 14 0.05 2 4 0.6455990 0.05 3.020e-14 15 0.05 2 16 6.3216416 0.05 5.684e-14 16 0.05 2 25 12.0802051 0.05 -1.465e-13 17 0.05 4 1 0.9087447 0.05 5.385e-14 18 0.05 4 4 1.7650116 0.05 6.095e-14 19 0.05 4 16 7.8843284 0.05 -7.105e-15 20 0.05 4 25 13.7329249 0.05 8.293e-14 21 0.05 7 1 2.4937057 0.05 -6.128e-14 22 0.05 7 4 3.6642526 0.05 -2.465e-14 23 0.05 7 16 10.2573190 0.05 9.326e-15 24 0.05 7 25 16.2267524 0.05 3.952e-14 > ## p df ncp qch p.q relE > ## 1 0.95 2 1 8.6422039 0.95 3.331e-16 > ## 2 0.95 2 4 14.6402116 0.95 3.442e-15 > ## 3 0.95 2 16 33.0542126 0.95 -8.882e-15 > ## 4 0.95 2 25 45.3082281 0.95 2.887e-15 > ## 5 0.95 4 1 11.7072278 0.95 5.662e-15 > ## 6 0.95 4 4 17.3093229 0.95 5.995e-15 > ## 7 0.95 4 16 35.4270110 0.95 -1.199e-14 > ## 8 0.95 4 25 47.6127674 0.95 8.771e-15 > ## 9 0.95 7 1 16.0039003 0.95 -5.551e-15 > ## 10 0.95 7 4 21.2280338 0.95 6.661e-15 > ## 11 0.95 7 16 38.9700904 0.95 1.110e-14 > ## 12 0.95 7 25 51.0605938 0.95 -1.488e-14 > ## 13 0.05 2 1 0.1683911 0.05 -2.398e-14 > ## 14 0.05 2 4 0.6455990 0.05 3.020e-14 > ## 15 0.05 2 16 6.3216416 0.05 5.673e-14 > ## 16 0.05 2 25 12.0802051 0.05 -1.477e-13 > ## 17 0.05 4 1 0.9087447 0.05 5.385e-14 > ## 18 0.05 4 4 1.7650116 0.05 6.106e-14 > ## 19 0.05 4 16 7.8843284 0.05 -7.105e-15 > ## 20 0.05 4 25 13.7329249 0.05 8.271e-14 > ## 21 0.05 7 1 2.4937057 0.05 -6.128e-14 > ## 22 0.05 7 4 3.6642526 0.05 -2.420e-14 > ## 23 0.05 7 16 10.2573190 0.05 1.066e-14 > ## 24 0.05 7 25 16.2267524 0.05 3.775e-14 > all.equal(pars$p, p.q, tol=0)# Lnx 64b: 9.2987e-15; Win 32b: 9.25e-15 [1] "Mean relative difference: 9.30737e-15" > stopifnot(all.equal(pars$p, p.q, tol=1e-14)) > showProc.time() Time (user system elapsed): 0.02 0 0.01 > > ## now works fine : > str(n.s3 <- newton(1, G= function(x,...) x^2 -3 , g = function(x,...) 2*x, + eps = 8e-16)) List of 4 $ x : num 1.73 $ G : num -4.44e-16 $ it : int 5 $ converged: logi TRUE > with(n.s3, stopifnot(converged, all.equal(x^2, 3, tol = 1e-15))) > > > ### New comparison -- particularly for right tail: > ## upper tail "1 - p" > > p.qappr <- function(p, df, ncp, main = NULL, + kind = c("raw", "diff", "abs.Err", "rel.Err"), + nF = NULL, do.title= is.null(main), do.legend = TRUE, + ylim.range = 0.4, ...) + { + ## Purpose: Plot comparison of different qchisq() approximations + ## ---------------------------------------------------------------------- + ## Arguments: + ## ---------------------------------------------------------------------- + ## Author: Dr. Martin Maechler, Date: 27 Feb 2004, 18:19 + kind <- match.arg(kind) + d.arg <- (l.d <- length(df)) > 1 + n.arg <- (l.n <- length(ncp)) > 1 + p.arg <- (l.p <- length(p)) > 1 + if((p.arg && (d.arg || n.arg)) || (d.arg && n.arg)) + stop("only one of the three argument should have length > 1") + if(!(d.arg || n.arg || p.arg)) p.arg <- TRUE + n <- max(l.d, l.n, l.p) + Fns <- c("qchisq", "qnchisqPearson", + "qchisqApprCF1", "qchisqApprCF2", + "qnchisqPatnaik", "qchisqCappr.2", + "qchisqAppr.0", "qchisqAppr.1", "qchisqAppr.2", "qchisqAppr.3" + ) + if(is.null(nF)) + nF <- length(Fns) + else if(is.numeric(nF) & nF > 1) Fns <- Fns[1:nF] + else stop("invalid 'nF' argument") + qmat <- matrix(NA, n, length(Fns), dimnames=list(NULL,Fns)) + for(i.f in 1:nF) { + fn <- Fns[i.f] + F <- get(fn) + qmat[,i.f] <- do.call(F, list(p=p, df=df, ncp=ncp, lower.tail=FALSE)) + } + cols <- 1:nF + lwds <- c(2, rep(1,nF-1)) + ltys <- rep(1:3, length = nF) + if(kind != "raw") { + cols <- cols[-1] + lwds <- lwds[-1] + ltys <- ltys[-1] + Fns <- Fns[-1] + ## Inf - Inf = 0 in the following : + "%-%" <- function(x,y) + ifelse(is.infinite(x) & is.infinite(y) & x==y, 0, x-y) + qm <- qmat[,-1, drop=FALSE] %-% qmat[,1] + if(kind != "diff") { + qm <- abs(qm) + if(kind == "rel.Err") qm <- qm / abs(qmat[,1]) + } + yl <- rrange(qm, r = ylim.range) + } else { + qm <- qmat + yl <- range(qmat[,"qchisq"], rrange(qmat, r = ylim.range)) + } + if(do.title && is.null(main)) main <- deparse(match.call()) + matplot(if(p.arg) p else if(d.arg) df else ncp, qm, type = 'l', + xlab = if(p.arg) "1 - p" else if(d.arg) "df" else "ncp", + ylim = yl, main = main, col = cols, lwd= lwds, lty= ltys, ...) + if(do.title) + mtext("different approximations to qchisq()", line = 0.4, cex = 1.25) + ## drop "qn?chisq" from names, since have it above: + if(do.legend) { + Fns <- sub("^qn?chisq.","*",Fns) + pu <- par("usr") + legend(par("xaxp")[2], par("yaxp")[2], + Fns, xjust = 1.02, yjust = 1.02, ncol = 3, + col = cols, lwd=lwds, lty= ltys) + } + invisible(qmat) + } ## end{ p.qappr() } > > pU <- seq(.5, 1, length= 201) > pU <- seq( 0, 1, length= 501)[-c(1,501)] > ## (I've lost the original 'pU' I had used ...) > > mystats <- function(x) c(M=mean(x), quantile(x)) > sum.qappr <- function(r) { + m <- t(apply(abs(r[,-1] - r[,1]), 2,mystats)) + m[order(m[,"50%"]),] + } > op <- options(digits = 6, width = 110)# warn: immediate .. > showProc.time() Time (user system elapsed): 0.02 0 0.02 > > sum.qappr(p.qappr (pU, df= 1, ncp= 1)) M 0% 25% 50% 75% 100% qchisqCappr.2 0.1263165 1.37148e-06 0.00954449 0.0193052 0.1525622 6.365893 qchisqApprCF2 0.0777562 1.77620e-05 0.02407599 0.0445612 0.1007318 1.816319 qnchisqPatnaik 0.0714720 2.13083e-04 0.03583402 0.0656940 0.0854991 0.866775 qnchisqPearson 0.0729407 2.11406e-04 0.03884969 0.0717846 0.0910334 0.248441 qchisqAppr.2 0.0883003 2.84536e-04 0.03560021 0.0749916 0.1021176 1.160153 qchisqAppr.3 0.6691961 1.18161e-03 0.03752266 0.3320384 1.0212289 4.240163 qchisqApprCF1 0.3332806 1.21005e-03 0.17326143 0.3412841 0.4967221 1.424457 qchisqAppr.1 0.5175693 5.67260e-03 0.12536442 0.3978820 0.8573725 1.393179 qchisqAppr.0 0.8826879 1.14206e-05 0.45717455 0.7953466 0.9636673 5.990766 > > sum.qappr(r <- p.qappr (pU, df=10, ncp= 10)) M 0% 25% 50% 75% 100% qchisqApprCF2 0.00359456 1.50814e-06 0.00181203 0.00320844 0.00387257 0.0496466 qnchisqPearson 0.02201822 4.43149e-05 0.01127431 0.02101230 0.02756944 0.2864658 qchisqApprCF1 0.09174091 2.72183e-04 0.04360964 0.08892117 0.13945385 0.1901201 qnchisqPatnaik 0.10325376 2.15112e-04 0.05272911 0.09373301 0.11497175 0.9554069 qchisqAppr.2 0.10475822 4.00962e-04 0.05332568 0.09705215 0.12198611 1.1165659 qchisqCappr.2 0.71474849 1.65403e-04 0.36311137 0.54498356 0.62495228 11.3452495 qchisqAppr.0 0.84994943 1.01519e-03 0.43481335 0.74080205 0.88581604 6.5487729 qchisqAppr.1 5.00228074 1.77629e+00 4.25789921 5.08532709 5.83899158 6.9218203 qchisqAppr.3 6.66195447 1.20188e+00 4.78773779 6.42966866 8.28830016 15.4652768 > ## just different pictures: > p.qappr (pU, df=10, ncp= 10, kind = "diff", ylim.r = 1) > p.qappr (pU, df=10, ncp= 10, kind = "abs", ylim.r = 0.01) > p.qappr (pU, df=10, ncp= 10, kind = "rel", log = 'y') > showProc.time() Time (user system elapsed): 1.35 0.02 1.37 > > sum.qappr(p.qappr (pU, df= 1, ncp= 10)) M 0% 25% 50% 75% 100% qchisqApprCF2 0.0152163 1.86616e-06 0.00758439 0.0130019 0.0156233 0.193484 qnchisqPearson 0.0586433 1.13157e-04 0.02865225 0.0536824 0.0692955 0.968821 qchisqApprCF1 0.1245384 2.66235e-05 0.05091925 0.1064525 0.1779323 0.587542 qnchisqPatnaik 0.2703339 3.41314e-04 0.14074504 0.2516636 0.3107495 2.363362 qchisqAppr.2 0.2705090 3.98002e-04 0.13967908 0.2554837 0.3212698 2.653250 qchisqAppr.0 0.9544442 1.64021e-03 0.48838188 0.8292286 0.9920684 7.755741 qchisqAppr.3 5.2339763 1.90488e-02 2.91503941 4.8793808 7.1673798 15.984920 qchisqAppr.1 9.1117419 4.71524e-01 6.01732328 9.1017583 12.1952989 17.919580 qchisqCappr.2 25.4463783 3.28244e-02 2.42732968 12.5513952 30.9429061 973.859100 > sum.qappr(p.qappr (pU, df= 1, ncp= 10, kind="rel")) M 0% 25% 50% 75% 100% qchisqApprCF2 0.0152163 1.86616e-06 0.00758439 0.0130019 0.0156233 0.193484 qnchisqPearson 0.0586433 1.13157e-04 0.02865225 0.0536824 0.0692955 0.968821 qchisqApprCF1 0.1245384 2.66235e-05 0.05091925 0.1064525 0.1779323 0.587542 qnchisqPatnaik 0.2703339 3.41314e-04 0.14074504 0.2516636 0.3107495 2.363362 qchisqAppr.2 0.2705090 3.98002e-04 0.13967908 0.2554837 0.3212698 2.653250 qchisqAppr.0 0.9544442 1.64021e-03 0.48838188 0.8292286 0.9920684 7.755741 qchisqAppr.3 5.2339763 1.90488e-02 2.91503941 4.8793808 7.1673798 15.984920 qchisqAppr.1 9.1117419 4.71524e-01 6.01732328 9.1017583 12.1952989 17.919580 qchisqCappr.2 25.4463783 3.28244e-02 2.42732968 12.5513952 30.9429061 973.859100 > showProc.time() Time (user system elapsed): 0.68 0 0.67 > > if(doExtras) ## this takes CPU ! + sum.qappr(p.qappr (pU, df= 10, ncp= 1e4, kind="rel")) > showProc.time() # 2.9 sec Time (user system elapsed): 0 0 0 > > ##--> CF2, Pea, CF1 and Patn are the four best ones overall > ## --- --- --- ---- > > ### Now look at upper tail only: ----- even a more clear picture > summary(pU <- 2^-seq(7,40, length=200)) Min. 1st Qu. Median Mean 3rd Qu. Max. 0.00e+00 0.00e+00 8.00e-08 3.60e-04 2.57e-05 7.81e-03 > sum.qappr(r <- p.qappr (pU, df= 1, ncp= 10)) M 0% 25% 50% 75% 100% qchisqApprCF2 6.02692e-02 6.15336e-04 4.08353e-02 6.70061e-02 8.50526e-02 9.11402e-02 qchisqApprCF1 3.72876e-01 3.00689e-01 3.55027e-01 3.80057e-01 3.94990e-01 4.00076e-01 qnchisqPearson 3.23783e+00 1.18712e-01 1.27948e+00 2.99699e+00 5.05928e+00 7.36911e+00 qnchisqPatnaik 1.22852e+01 1.36527e+00 6.13859e+00 1.18970e+01 1.82031e+01 2.48799e+01 qchisqAppr.1 1.23997e+01 1.31631e-01 7.03170e+00 1.32071e+01 1.75316e+01 2.73420e+01 qchisqAppr.2 1.72223e+01 1.45241e+00 7.62305e+00 1.60735e+01 2.61946e+01 3.76950e+01 qchisqAppr.3 2.41196e+01 1.40652e+01 2.07736e+01 2.51268e+01 2.80455e+01 2.98949e+01 qchisqAppr.0 2.56846e+01 4.46700e+00 1.47661e+01 2.55465e+01 3.65091e+01 4.75693e+01 qchisqCappr.2 1.48735e+04 4.33988e+02 4.20180e+03 1.20524e+04 2.41003e+04 4.03930e+04 > p.qappr (pU, df= 1, ncp= 10, kind="rel") > sum.qappr(r <- p.qappr (pU, df= 1, ncp= 100)) M 0% 25% 50% 75% 100% qchisqApprCF2 3.23532e-02 6.91729e-03 2.01425e-02 3.20245e-02 4.24972e-02 8.38734e-02 qchisqApprCF1 2.08485e-01 1.12693e-01 1.76686e-01 2.17503e-01 2.44878e-01 2.74911e-01 qnchisqPearson 1.48651e+00 6.82522e-02 5.81153e-01 1.35922e+00 2.32347e+00 3.40332e+00 qnchisqPatnaik 1.10504e+01 1.62002e+00 5.91241e+00 1.07987e+01 1.60452e+01 2.15258e+01 qchisqAppr.2 1.24254e+01 1.66540e+00 6.37784e+00 1.19942e+01 1.82351e+01 2.49488e+01 qchisqAppr.0 2.62254e+01 4.72386e+00 1.51963e+01 2.61022e+01 3.71683e+01 4.83500e+01 qchisqAppr.3 1.07709e+02 7.58775e+01 9.49985e+01 1.09388e+02 1.21454e+02 1.32068e+02 qchisqAppr.1 1.58584e+02 1.40167e+02 1.55816e+02 1.60451e+02 1.63192e+02 1.64118e+02 qchisqCappr.2 1.50940e+06 4.75084e+04 4.32874e+05 1.22711e+06 2.44131e+06 4.08014e+06 There were 41 warnings (use warnings() to see them) > ## very small ncp: > sum.qappr(r <- p.qappr (pU, df= 1, ncp= .01)) M 0% 25% 50% 75% 100% qchisqCappr.2 0.00128022 3.05402e-06 1.56799e-04 7.70708e-04 0.00214478 0.00455009 qnchisqPearson 0.00939577 1.74458e-06 1.80027e-03 7.13308e-03 0.01583074 0.02770453 qnchisqPatnaik 0.01142568 8.20301e-05 2.83346e-03 9.13469e-03 0.01884586 0.03175665 qchisqApprCF1 3.08508151 5.55616e-03 7.27580e-01 2.75104e+00 5.10726406 7.66338528 qchisqAppr.3 6.32839535 6.92832e-03 1.50701e+00 5.14881e+00 10.52498695 17.42112202 qchisqAppr.1 6.67484515 1.75065e-03 1.69869e+00 5.48651e+00 11.02731001 18.10391299 qchisqAppr.2 6.67497690 1.42660e-03 1.69904e+00 5.48673e+00 11.02728611 18.10355233 qchisqApprCF2 6.55250515 3.56074e-01 2.28797e+00 5.69040e+00 10.36715005 16.16991756 qchisqAppr.0 20.81860756 2.68328e+00 1.10939e+01 2.04990e+01 30.33749708 40.42820965 > p.qappr (pU, df= 1, ncp= .01, kind="dif", log="x", nF =6) > p.qappr (pU, df= 1, ncp= .01, kind="rel", log="xy",nF =6) > # here, CF2 is "off" and the top is "Cappr.2", "Pea", "Patn" ("CF1", "appr.3") > > sum.qappr(r <- p.qappr (pU, df= 10, ncp= .01)) M 0% 25% 50% 75% 100% qchisqCappr.2 5.18205e-07 1.85374e-08 1.35427e-07 3.94832e-07 8.37651e-07 1.50319e-06 qnchisqPearson 4.54139e-05 4.98226e-07 1.24410e-05 3.71657e-05 7.41141e-05 1.22953e-04 qnchisqPatnaik 6.60766e-05 3.43732e-06 2.36028e-05 5.74955e-05 1.04072e-04 1.62826e-04 qchisqApprCF2 1.07453e+00 5.08970e-02 3.48220e-01 9.07141e-01 1.71471e+00 2.75713e+00 qchisqAppr.3 1.80597e+00 1.73644e-02 5.39024e-01 1.52998e+00 2.92822e+00 4.69431e+00 qchisqAppr.1 1.86004e+00 4.12874e-02 5.78517e-01 1.58420e+00 2.99699e+00 4.77766e+00 qchisqAppr.2 1.86006e+00 4.13029e-02 5.78536e-01 1.58422e+00 2.99701e+00 4.77769e+00 qchisqApprCF1 1.92985e+00 4.08573e-03 5.98334e-01 1.74204e+00 3.14135e+00 4.72184e+00 qchisqAppr.0 1.95908e+01 3.11258e+00 1.08743e+01 1.93352e+01 2.81516e+01 3.72009e+01 > # shows noise in qchisq() itself !? > p.qappr (pU, df= 10, ncp= .01, kind="rel", log="xy") > # "CF2" +-ok; top is "Cappr.2", "Pea", "Patn" ("CF2", "appr.3") > sum.qappr(r <- p.qappr (pU, df= 100, ncp= .01)) M 0% 25% 50% 75% 100% qchisqCappr.2 1.88575e-10 3.02123e-11 9.37987e-11 1.76712e-10 2.80679e-10 3.94493e-10 qnchisqPearson 1.21485e-07 3.86842e-09 4.10167e-08 1.05515e-07 1.93518e-07 3.03075e-07 qnchisqPatnaik 3.13048e-07 3.55460e-08 1.48420e-07 2.94765e-07 4.67848e-07 6.64697e-07 qchisqApprCF2 1.31810e-01 5.84576e-03 4.12114e-02 1.09550e-01 2.10998e-01 3.45234e-01 qchisqAppr.3 4.42572e-01 3.10820e-03 1.43997e-01 3.85392e-01 7.10835e-01 1.11158e+00 qchisqAppr.1 4.61644e-01 1.68465e-02 1.60790e-01 4.04657e-01 7.32308e-01 1.13510e+00 qchisqAppr.2 4.61645e-01 1.68476e-02 1.60791e-01 4.04659e-01 7.32310e-01 1.13511e+00 qchisqApprCF1 8.15982e-01 1.01904e-03 2.57851e-01 7.27452e-01 1.32326e+00 2.01773e+00 qchisqAppr.0 1.84683e+01 3.20226e+00 1.05246e+01 1.83049e+01 2.63110e+01 3.44677e+01 > # shows noise in qchisq() itself !!! > p.qappr (pU, df= 100, ncp= .01, kind="rel", log="xy") > showProc.time() Time (user system elapsed): 0.54 0.01 0.57 > > ## even smaller ncp: > sum.qappr(r <- p.qappr (pU, df= 100, ncp= .001)) M 0% 25% 50% 75% 100% qchisqCappr.2 3.32179e-12 5.68434e-14 1.47793e-12 2.79954e-12 3.95772e-12 3.65219e-11 qnchisqPearson 1.21643e-09 3.68630e-11 4.11823e-10 1.05173e-09 1.93673e-09 3.05863e-09 qnchisqPatnaik 3.13262e-09 3.53737e-10 1.48619e-09 2.94476e-09 4.68082e-09 6.67589e-09 qchisqApprCF2 1.31798e-01 5.84523e-03 4.12077e-02 1.09541e-01 2.10979e-01 3.45202e-01 qchisqAppr.3 4.59696e-01 1.54720e-02 1.59097e-01 4.02695e-01 7.30096e-01 1.13265e+00 qchisqAppr.1 4.61603e-01 1.68461e-02 1.60776e-01 4.04622e-01 7.32243e-01 1.13500e+00 qchisqAppr.2 4.61603e-01 1.68461e-02 1.60776e-01 4.04622e-01 7.32243e-01 1.13500e+00 qchisqApprCF1 8.15909e-01 1.01895e-03 2.57828e-01 7.27387e-01 1.32314e+00 2.01755e+00 qchisqAppr.0 1.84667e+01 3.20197e+00 1.05236e+01 1.83032e+01 2.63087e+01 3.44646e+01 > # shows noise in qchisq() itself !!! > p.qappr (pU, df= 100, ncp= .001, kind="rel", log="xy") > > sum.qappr(r <- p.qappr (pU, df= 1, ncp= .1)) M 0% 25% 50% 75% 100% qnchisqPearson 0.439546 0.000337978 0.112144 0.373198 0.730124 1.15459 qchisqCappr.2 0.692048 0.003247339 0.117169 0.480553 1.161802 2.19689 qnchisqPatnaik 0.598226 0.008444746 0.192868 0.529484 0.965491 1.47087 qchisqApprCF1 2.877109 0.007328296 0.674358 2.581980 4.753963 7.07639 qchisqAppr.3 4.759317 0.004332369 0.668465 3.321414 8.199290 14.65052 qchisqApprCF2 6.730314 0.339458372 2.286121 5.813105 10.695276 16.76240 qchisqAppr.1 7.757087 0.001410465 1.988570 6.405488 12.813184 20.94655 qchisqAppr.2 7.769343 0.004435378 2.020658 6.425732 12.811141 20.91377 qchisqAppr.0 21.901094 2.893466984 11.795548 21.622258 31.821349 42.22700 > p.qappr (pU, df= 1, ncp= .1, kind="rel", log="y") > summary(warnings()) 41 identical warnings: In (function (p, df, ncp = 0, lower.tail = TRUE, log.p = FALSE) ... : full precision may not have been achieved in 'qnchisq' > showProc.time() Time (user system elapsed): 0.27 0 0.26 > > sum.qappr(r <- p.qappr (pU, df= 20, ncp= 200)) M 0% 25% 50% 75% 100% qchisqApprCF2 6.67428e-03 1.39181e-05 3.15435e-03 4.83870e-03 5.75556e-03 1.28635e-01 qchisqApprCF1 9.53398e-02 6.74688e-02 8.82559e-02 9.65167e-02 1.02067e-01 1.89725e-01 qnchisqPearson 9.97990e-01 4.63948e-02 3.86452e-01 9.06380e-01 1.55635e+00 2.42976e+00 qnchisqPatnaik 9.20017e+00 1.42369e+00 5.00796e+00 9.01679e+00 1.32837e+01 1.78618e+01 qchisqAppr.2 1.00112e+01 1.45382e+00 5.29196e+00 9.72881e+00 1.45692e+01 1.98510e+01 qchisqAppr.0 2.59621e+01 4.69340e+00 1.50534e+01 2.58425e+01 3.67919e+01 4.77078e+01 qchisqAppr.3 1.81968e+02 1.39601e+02 1.65047e+02 1.84166e+02 2.00261e+02 2.14349e+02 qchisqAppr.1 2.54701e+02 2.21305e+02 2.44073e+02 2.57924e+02 2.67307e+02 2.73669e+02 qchisqCappr.2 8.32109e+03 1.30860e+03 4.13351e+03 7.79802e+03 1.22359e+04 1.74114e+04 There were 41 warnings (use warnings() to see them) > p.qappr (pU, df= 20, ncp= 200, kind='rel', log='y') There were 41 warnings (use warnings() to see them) > > sum.qappr(r <- p.qappr (pU, df= .1, ncp= 500)) M 0% 25% 50% 75% 100% qchisqApprCF2 1.19625e-02 1.51966e-03 4.62524e-03 7.66078e-03 1.07074e-02 1.92928e-01 qchisqApprCF1 1.03042e-01 1.55725e-03 8.41830e-02 1.06513e-01 1.23308e-01 2.62649e-01 qnchisqPearson 7.29217e-01 3.48657e-02 2.84034e-01 6.65688e-01 1.14337e+00 1.82053e+00 qnchisqPatnaik 1.00136e+01 1.63436e+00 5.56132e+00 9.86204e+00 1.43809e+01 1.91821e+01 qchisqAppr.2 1.05578e+01 1.65628e+00 5.75688e+00 1.03436e+01 1.52404e+01 2.05010e+01 qchisqAppr.0 2.63742e+01 4.79190e+00 1.53122e+01 2.62536e+01 3.73498e+01 4.84058e+01 qchisqAppr.3 3.71480e+02 3.05648e+02 3.45347e+02 3.74941e+02 3.99775e+02 4.21557e+02 qchisqAppr.1 6.88598e+02 6.10312e+02 6.74203e+02 7.03441e+02 7.09515e+02 7.11535e+02 qchisqCappr.2 3.53805e+09 5.77707e+06 6.55274e+08 2.58981e+09 5.94199e+09 1.07586e+10 There were 41 warnings (use warnings() to see them) > ## drop the appr. : they are bad > p.qappr (pU, df= .1, ncp= 500, kind='dif', nF = 6) There were 41 warnings (use warnings() to see them) > p.qappr (pU, df= .1, ncp= 500, kind='rel', nF = 6, log='y') There were 41 warnings (use warnings() to see them) > sum.qappr(r <- p.qappr (pU, df= .1, ncp= 500, kind='dif', nF = 6)) M 0% 25% 50% 75% 100% qchisqApprCF2 1.19625e-02 1.51966e-03 4.62524e-03 7.66078e-03 1.07074e-02 1.92928e-01 qchisqApprCF1 1.03042e-01 1.55725e-03 8.41830e-02 1.06513e-01 1.23308e-01 2.62649e-01 qnchisqPearson 7.29217e-01 3.48657e-02 2.84034e-01 6.65688e-01 1.14337e+00 1.82053e+00 qnchisqPatnaik 1.00136e+01 1.63436e+00 5.56132e+00 9.86204e+00 1.43809e+01 1.91821e+01 qchisqCappr.2 3.53805e+09 5.77707e+06 6.55274e+08 2.58981e+09 5.94199e+09 1.07586e+10 There were 41 warnings (use warnings() to see them) > p.qappr (pU, df= .1, ncp= 500, kind='rel', log='y', nF = 6) There were 41 warnings (use warnings() to see them) > # order: CF2, CF1, Pea, Patn > showProc.time() Time (user system elapsed): 0.72 0.03 0.75 > > > ### Very large ncp, df --- Sankaran_d and Pearson had failed ! > > op <- options(warn = 1)# immediate .. > pp <- c(.001, .005, .01, .05, (1:9)/10, .95, .99, .995, .999) > for(DF in 10^c(50, 100,150,200, 250, 300)) + stopifnot(exprs = { + qnchisqPearson (pp, df=DF, ncp=100) == DF + qnchisqSankaran_d(pp, df=DF, ncp=100) == DF + qnchisqPatnaik (pp, df=DF, ncp=100) == DF + }) > > qtol <- if(doExtras) 3e-16 else 1e-15 > ## Both large df & large ncp > for(NCP in 10^c(50, 100,150,200, 250, 300)) + stopifnot(exprs = { + abs(1 - qnchisqPearson (pp, df=2*NCP, ncp=NCP) / (3*NCP)) < qtol + abs(1 - qnchisqSankaran_d(pp, df=2*NCP, ncp=NCP) / (3*NCP)) < qtol + abs(1 - qnchisqPatnaik (pp, df=2*NCP, ncp=NCP) / (3*NCP)) < qtol + + abs(1 - qnchisqPearson (pp, df=NCP, ncp=NCP) / (2*NCP)) < qtol + abs(1 - qnchisqSankaran_d(pp, df=NCP, ncp=NCP) / (2*NCP)) < qtol + abs(1 - qnchisqPatnaik (pp, df=NCP, ncp=NCP) / (2*NCP)) < qtol + + abs(1 - qnchisqPearson (pp, df=NCP/2, ncp=NCP) / (1.5*NCP)) < qtol + abs(1 - qnchisqSankaran_d(pp, df=NCP/2, ncp=NCP) / (1.5*NCP)) < qtol + abs(1 - qnchisqPatnaik (pp, df=NCP/2, ncp=NCP) / (1.5*NCP)) < qtol + }) > showProc.time() Time (user system elapsed): 0.03 0.02 0.05 > options(op) # revert > > > DF <- 1e200 > if(FALSE)## BUG (2019-08-31): + system.time( + qch <- qchisq(pp, df=DF, ncp=100) + )## gives these warnings (immediately "warn = 1"), and then takes "forever" !! > ## Warning in qchisq(pp, df = DF, ncp = 100) : > ## pnchisq(x=1e+200, ..): not converged in 10000 iter. > ## Warning in qchisq(pp, df = DF, ncp = 100) : > ## pnchisq(x=1e+200, ..): not converged in 10000 iter. > > ## "forever": Timing stopped at: 3871 0.184 3878 > 1 hour > > showProc.time() Time (user system elapsed): 0 0 0 > > proc.time() user system elapsed 35.59 1.06 36.70