├── .github ├── .gitignore └── workflows │ └── R-CMD-check.yaml ├── data ├── grid2ip.ld.rdata ├── grid2ip.p.rdata ├── mvnlookup.rdata ├── grid2ip.geno.rdata └── grid2ip.pheno.rdata ├── docs ├── pkgdown.yml ├── link.svg ├── sitemap.xml ├── bootstrap-toc.css ├── docsearch.js ├── pkgdown.js ├── 404.html ├── bootstrap-toc.js ├── authors.html ├── reference │ ├── print.poolr.html │ ├── grid2ip.html │ ├── mvnlookup.html │ ├── index.html │ └── poolr-package.html ├── news │ └── index.html ├── pkgdown.css └── index.html ├── .Rbuildignore ├── NAMESPACE ├── tests ├── testthat.r └── testthat │ ├── tolerances.r │ ├── test_mvnconv.r │ ├── test_empirical.r │ ├── test_meff.r │ ├── test_binomtest.r │ ├── test_tippett.r │ ├── test_bonferroni.r │ ├── test_stouffer.r │ ├── test_fisher.r │ ├── test_invchisq.r │ └── test_misc_funs.r ├── man ├── print.poolr.Rd ├── grid2ip.Rd ├── poolr-package.Rd ├── mvnlookup.Rd ├── empirical.Rd ├── mvnconv.Rd └── meff.Rd ├── inst └── CITATION ├── DESCRIPTION ├── _pkgdown.yml ├── NEWS.md ├── README.md ├── R ├── empirical.r ├── tippett.r ├── print.poolr.r ├── bonferroni.r ├── binomtest.r ├── stouffer.r ├── mvnconv.r ├── fisher.r ├── invchisq.r └── meff.r ├── quick_start.md └── misc └── create_mvnlookup.r /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | 3 | -------------------------------------------------------------------------------- /data/grid2ip.ld.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozancinar/poolr/HEAD/data/grid2ip.ld.rdata -------------------------------------------------------------------------------- /data/grid2ip.p.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozancinar/poolr/HEAD/data/grid2ip.p.rdata -------------------------------------------------------------------------------- /data/mvnlookup.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozancinar/poolr/HEAD/data/mvnlookup.rdata -------------------------------------------------------------------------------- /data/grid2ip.geno.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozancinar/poolr/HEAD/data/grid2ip.geno.rdata -------------------------------------------------------------------------------- /data/grid2ip.pheno.rdata: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ozancinar/poolr/HEAD/data/grid2ip.pheno.rdata -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: '2.5' 2 | pkgdown: 2.2.0 3 | pkgdown_sha: ~ 4 | articles: {} 5 | last_built: 2025-12-01T13:03Z 6 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.git$ 2 | ^\.github$ 3 | ^_pkgdown\.yml$ 4 | ^docs$ 5 | ^vignettes/pkgdown$ 6 | ^misc$ 7 | ^quick_start.md 8 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | exportPattern("^[^\\.]") 2 | 3 | import(methods) 4 | import(stats) 5 | import(utils) 6 | import(mathjaxr) 7 | 8 | S3method(print, poolr) 9 | -------------------------------------------------------------------------------- /tests/testthat.r: -------------------------------------------------------------------------------- 1 | ### to also run skip_on_cran() tests, uncomment: 2 | #Sys.setenv(NOT_CRAN="true") 3 | 4 | library(testthat) 5 | library(poolr) 6 | test_check("poolr", reporter = "summary") 7 | -------------------------------------------------------------------------------- /tests/testthat/tolerances.r: -------------------------------------------------------------------------------- 1 | p_tol <- 1e-04 # user-defined tolerance (for p-values and and ci bounds) 2 | stat_tol <- 1e-04 # user-defined tolerance (for test statistics) 3 | df_tol <- 1e-01 # user-defined tolerance (for df) 4 | m_tol <- 0 # user-defined tolerance (for m) 5 | emp_sca <- 50 # scaling factor for p_tol when using 'empirical' methods 6 | 7 | # p_tol <- 0.1 8 | # stat_tol <- 0.1 9 | # df_tol <- 0.1 10 | # df_m <- 0 11 | -------------------------------------------------------------------------------- /docs/link.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 5 | 8 | 12 | 13 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: 4 | - master 5 | pull_request: 6 | branches: 7 | - master 8 | 9 | name: R-CMD-check 10 | 11 | jobs: 12 | R-CMD-check: 13 | if: "!contains(github.event.head_commit.message, '[ci skip]')" 14 | runs-on: ubuntu-24.04 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | steps: 18 | - uses: actions/checkout@v4 19 | - uses: r-lib/actions/setup-r@v2 20 | with: 21 | r-version: 'release' 22 | - uses: r-lib/actions/setup-r-dependencies@v2 23 | with: 24 | extra-packages: any::rcmdcheck 25 | needs: check 26 | - uses: r-lib/actions/check-r-package@v2 27 | with: 28 | args: 'c("--no-manual", "--as-cran", "--no-tests")' 29 | error-on: '"warning"' 30 | check-dir: '"check"' 31 | -------------------------------------------------------------------------------- /man/print.poolr.Rd: -------------------------------------------------------------------------------- 1 | \name{print.poolr} 2 | \alias{print.poolr} 3 | \title{Print Method for 'poolr' Objects} 4 | \description{ 5 | Print method for objects of class \code{"poolr"}. 6 | } 7 | \usage{ 8 | \method{print}{poolr}(x, digits=3, \dots) 9 | } 10 | \arguments{ 11 | \item{x}{an object of class \code{"poolr"}.} 12 | \item{digits}{integer specifying the number of (significant) digits for rounding/presenting the results.} 13 | \item{\dots}{other arguments.} 14 | } 15 | \details{ 16 | The output shows the combined \mjseqn{p}-value (with the specified number of significant digits), the test statistic (and its assumed null distribution), and the adjustment method that was applied. 17 | } 18 | \value{ 19 | The function does not return an object. 20 | } 21 | \author{ 22 | Ozan Cinar \email{ozancinar86@gmail.com} \cr 23 | Wolfgang Viechtbauer \email{wvb@wvbauer.com} \cr 24 | } 25 | \keyword{print} 26 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite the poolr package in publications, please use:") 2 | 3 | bibentry(bibtype = "Article", 4 | title = "The {poolr} Package for Combining Independent and Dependent $p$ Values", 5 | author = c(person(given = "Ozan", family = "Cinar", email = "ozan.cinar@maastrichtuniversity.nl"), 6 | person(given = "Wolfgang", family = "Viechtbauer")), 7 | journal = "Journal of Statistical Software", 8 | year = "2022", 9 | volume = "101", 10 | number = "1", 11 | pages = "1--42", 12 | doi = "10.18637/jss.v101.i01", 13 | textVersion = paste("Cinar, O., & Viechtbauer, W. (2022)", 14 | "The poolr package for combining independent and dependent p values.", 15 | "Journal of Statistical Software, 101(1), 1-42.", 16 | "https://doi.org/10.18637/jss.v101.i01") 17 | ) 18 | -------------------------------------------------------------------------------- /docs/sitemap.xml: -------------------------------------------------------------------------------- 1 | 2 | /404.html 3 | /authors.html 4 | /index.html 5 | /news/index.html 6 | /quick_start.html 7 | /reference/binomtest.html 8 | /reference/bonferroni.html 9 | /reference/empirical.html 10 | /reference/fisher.html 11 | /reference/grid2ip.html 12 | /reference/index.html 13 | /reference/invchisq.html 14 | /reference/meff.html 15 | /reference/mvnconv.html 16 | /reference/mvnlookup.html 17 | /reference/poolr-package.html 18 | /reference/print.poolr.html 19 | /reference/stouffer.html 20 | /reference/tippett.html 21 | 22 | 23 | -------------------------------------------------------------------------------- /tests/testthat/test_mvnconv.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking mvnconv() function") 6 | 7 | test_that("mvnconv() works correctly.", { 8 | 9 | mvnconv_vec_ex1 <- mvnconv(c(0.1, 0.2, 0.3), target = "m2lp") 10 | mvnconv_vec_ex2 <- mvnconv(c(0.1, 0.2, 0.3), target = "m2lp", cov2cor = TRUE) 11 | 12 | expect_equivalent(mvnconv_vec_ex1, c(0.0390, 0.1563, 0.3519), tolerance = stat_tol) 13 | expect_equivalent(mvnconv_vec_ex2, c(0.00975, 0.039075, 0.087975), tolerance = stat_tol) 14 | 15 | }) 16 | 17 | test_that("The arguments of mvnconv() are checked correctly.", { 18 | 19 | expect_error(mvnconv(target = "m2lp"), "Argument 'R' must be specified.") 20 | expect_error(mvnconv(grid2ip.ld), "Argument 'target' must be specified.") 21 | 22 | # skipped now, since mvnconv() does not check or require that 'R' is PD 23 | # R <- matrix(c( 1, 0.8, 0.5, -0.3, 24 | # 0.8, 1, 0.2, 0.4, 25 | # 0.5, 0.2, 1, -0.7, 26 | # -0.3, 0.4, -0.7, 1), nrow = 4, ncol = 4) 27 | # expect_error(mvnconv(R, side = 2, target = "m2lp"), "Matrix 'R' cannot be negative definite.") 28 | 29 | }) 30 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: poolr 2 | Version: 1.3-0 3 | Date: 2025-12-01 4 | Title: Methods for Pooling P-Values from (Dependent) Tests 5 | Authors@R: c(person("Ozan", "Cinar", email = "ozancinar86@gmail.com", role = c("aut","cre"), comment = c(ORCID = "0000-0003-0329-1977")), person("Wolfgang", "Viechtbauer", email = "wvb@wvbauer.com", role = "aut", comment = c(ORCID = "0000-0003-3463-4063"))) 6 | Depends: R (>= 3.5.0) 7 | Imports: methods, stats, utils, mathjaxr 8 | Suggests: testthat 9 | RdMacros: mathjaxr 10 | Description: Functions for pooling/combining the results (i.e., p-values) from (dependent) hypothesis tests. Included are Fisher's method, Stouffer's method, the inverse chi-square method, the Bonferroni method, Tippett's method, and the binomial test. Each method can be adjusted based on an estimate of the effective number of tests or using empirically derived null distribution using pseudo replicates. For Fisher's, Stouffer's, and the inverse chi-square method, direct generalizations based on multivariate theory are also available (leading to Brown's method, Strube's method, and the generalized inverse chi-square method). An introduction can be found in Cinar and Viechtbauer (2022) . 11 | License: GPL (>=2) 12 | ByteCompile: TRUE 13 | LazyData: TRUE 14 | Encoding: UTF-8 15 | BuildManual: TRUE 16 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | template: 2 | params: 3 | bootswatch: cosmo 4 | 5 | home: 6 | links: 7 | - text: GitHub Repo 8 | href: https://github.com/ozancinar/poolr 9 | 10 | navbar: 11 | title: "poolr" 12 | left: 13 | - icon: fa-home fa-lg 14 | href: index.html 15 | - text: Quick Start 16 | href: quick_start.html 17 | - text: "Functions" 18 | href: reference/index.html 19 | - text: "Changelog" 20 | href: news/index.html 21 | 22 | reference: 23 | - title: "Package Introduction" 24 | desc: > 25 | Introduction to the package. 26 | contents: 27 | - poolr-package 28 | - title: "Base Methods" 29 | desc: > 30 | Functions to combine independent and dependent p-values. 31 | contents: 32 | - fisher 33 | - stouffer 34 | - invchisq 35 | - binomtest 36 | - bonferroni 37 | - tippett 38 | - title: "Support Functions" 39 | desc: > 40 | Functions to support the functionality of the base methods.. 41 | contents: 42 | - empirical 43 | - meff 44 | - mvnconv 45 | - print.poolr 46 | - title: "Datasets" 47 | desc: > 48 | Functions for creating various types of plots. 49 | contents: 50 | - grid2ip.p 51 | - grid2ip.ld 52 | - grid2ip.geno 53 | - grid2ip.pheno 54 | - mvnlookup 55 | -------------------------------------------------------------------------------- /tests/testthat/test_empirical.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking mvnconv() function") 6 | 7 | test_that("empirical() works correctly.", { 8 | 9 | set.seed(1234) 10 | emp_test_alpha <- binomtest(grid2ip.p, adjust = "empirical", R = grid2ip.ld, alpha = 0.1) 11 | 12 | set.seed(1234) 13 | emp_test_batch <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000, batchsize = 300) 14 | 15 | set.seed(1234) 16 | emp_test_side1 <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000, side = 1) 17 | 18 | expect_equivalent(emp_test_alpha$p, 0.00149985, tolerance = p_tol * emp_sca) 19 | expect_equivalent(emp_test_batch$p, 0.001998002, tolerance = p_tol * emp_sca) 20 | expect_equivalent(emp_test_side1$p, 0.000999001, tolerance = p_tol * emp_sca) 21 | 22 | }) 23 | 24 | test_that("The arguments of empirical() are checked correctly.", { 25 | 26 | expect_error(empirical(method = "fisher"), "Argument 'R' must be specified.") 27 | expect_error(fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100, batchsize = 1000)) 28 | # expect_error(fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000000, side = 1), "Matrix to be generated is too large. Try setting 'batchsize' \\(or to a lower number if it was set\\).") 29 | 30 | }) 31 | -------------------------------------------------------------------------------- /man/grid2ip.Rd: -------------------------------------------------------------------------------- 1 | \name{grid2ip} 2 | \docType{data} 3 | \alias{grid2ip.p} 4 | \alias{grid2ip.ld} 5 | \alias{grid2ip.geno} 6 | \alias{grid2ip.pheno} 7 | \alias{grid2ip} 8 | \title{Results from testing the association between depressive symptoms and 23 SNPs in the GRID2IP gene} 9 | \description{Results from testing the association between depressive symptoms (as measured with the CES-D scale) and 23 single-nucleotide polymorphisms (SNPs) in the GRID2IP gene based on a sample of 886 adolescents (Van Assche et al., 2017).} 10 | \usage{grid2ip.p 11 | grid2ip.ld 12 | grid2ip.geno 13 | grid2ip.pheno} 14 | \format{Object \code{grid2ip.p} is a vector with the 23 \eqn{p}-values of the tests (two-sided). Object \code{grid2ip.ld} contains a matrix with the linkage disequilibrium (LD) correlations among the 23 SNPs. \code{grid2ip.geno} is a matrix that contains the genotypes of the adoloscents for the 23 SNPs. \code{grid2ip.pheno} is a vector with the phenotype for the adoloscents (the log-transformed CES-D scale values).} 15 | \references{ 16 | Van Assche, E., Moons, T., Cinar, O., Viechtbauer, W., Oldehinkel, A. J., Van Leeuwen, K., Verschueren, K., Colpin, H., Lambrechts, D., Van den Noortgate, W., Goossens, L., Claes, S., & van Winkel, R. (2017). Gene-based interaction analysis shows GABAergic genes interacting with parenting in adolescent depressive symptoms. \emph{Journal of Child Psychology and Psychiatry, 58}(12), 1301--1309. \verb{https://doi.org/10.1111/jcpp.12766} 17 | } 18 | \keyword{datasets} 19 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # poolr 1.3-0 (2025-12-01) 2 | 3 | - version bump for development version 4 | 5 | # poolr 1.2-0 (2025-12-01) 6 | 7 | - added the reference to the publication in the Journal of Statistical Software 8 | 9 | - fixed an issue where the Bonferroni and Tippett methods were not identical with `adjust = "empirical"` when the observed Bonferroni-adjusted p-value is equal to 1 10 | 11 | - added the method by Chen & Liu (2011) for estimating the effective number of tests via `adjust = "chen"` 12 | 13 | # poolr 1.0-0 (2021-06-02) 14 | 15 | - changed name of `binotest()` function to `binomtest()` 16 | 17 | - the HTML help files now show rendered equations with the help of the `mathjaxr` package 18 | 19 | - increased resolution of `mvnlookup` table (now in steps of .001) 20 | 21 | - `meff()` function now issues a warning if there are negative eigenvalues (and if they were set to 0 for `method="galway"`) 22 | 23 | - added `nearpd` argument to all base functions; if `TRUE`, a negative definite `R` matrix will be turned into the nearest positive semi-definite matrix (only for `adjust="empirical"` and `adjust="generalized"`) 24 | 25 | - implemented a simplified version of `Matrix::nearPD()`; hence, dependence on the package `Matrix` was removed 26 | 27 | - added a more specific test on `p` and `eigen` that they are `numeric` vectors 28 | 29 | - improved the `pkgdown` docs and added a quick start guide 30 | 31 | - changed the way the pseudo replicates are generated in `empirical()` to a more stable method 32 | 33 | - slight improvements to the output of `print.poolr()` when using the effective number of tests or empirical distribution adjustments 34 | 35 | - `mvnconv()` now uses the variances from the lookup table instead of `cov2cor()` for the transformation when `cov2cor=TRUE` 36 | 37 | - added a check on `R` (where appropriate) that its diagonal values are all equal to 1 38 | 39 | - added a check on `p` to convert it into a `numeric` vector if it is a `matrix` with 1 row 40 | 41 | # poolr 0.8-2 (2020-02-12) 42 | 43 | - first version for CRAN 44 | -------------------------------------------------------------------------------- /docs/bootstrap-toc.css: -------------------------------------------------------------------------------- 1 | /*! 2 | * Bootstrap Table of Contents v0.4.1 (http://afeld.github.io/bootstrap-toc/) 3 | * Copyright 2015 Aidan Feldman 4 | * Licensed under MIT (https://github.com/afeld/bootstrap-toc/blob/gh-pages/LICENSE.md) */ 5 | 6 | /* modified from https://github.com/twbs/bootstrap/blob/94b4076dd2efba9af71f0b18d4ee4b163aa9e0dd/docs/assets/css/src/docs.css#L548-L601 */ 7 | 8 | /* All levels of nav */ 9 | nav[data-toggle='toc'] .nav > li > a { 10 | display: block; 11 | padding: 4px 20px; 12 | font-size: 13px; 13 | font-weight: 500; 14 | color: #767676; 15 | } 16 | nav[data-toggle='toc'] .nav > li > a:hover, 17 | nav[data-toggle='toc'] .nav > li > a:focus { 18 | padding-left: 19px; 19 | color: #563d7c; 20 | text-decoration: none; 21 | background-color: transparent; 22 | border-left: 1px solid #563d7c; 23 | } 24 | nav[data-toggle='toc'] .nav > .active > a, 25 | nav[data-toggle='toc'] .nav > .active:hover > a, 26 | nav[data-toggle='toc'] .nav > .active:focus > a { 27 | padding-left: 18px; 28 | font-weight: bold; 29 | color: #563d7c; 30 | background-color: transparent; 31 | border-left: 2px solid #563d7c; 32 | } 33 | 34 | /* Nav: second level (shown on .active) */ 35 | nav[data-toggle='toc'] .nav .nav { 36 | display: none; /* Hide by default, but at >768px, show it */ 37 | padding-bottom: 10px; 38 | } 39 | nav[data-toggle='toc'] .nav .nav > li > a { 40 | padding-top: 1px; 41 | padding-bottom: 1px; 42 | padding-left: 30px; 43 | font-size: 12px; 44 | font-weight: normal; 45 | } 46 | nav[data-toggle='toc'] .nav .nav > li > a:hover, 47 | nav[data-toggle='toc'] .nav .nav > li > a:focus { 48 | padding-left: 29px; 49 | } 50 | nav[data-toggle='toc'] .nav .nav > .active > a, 51 | nav[data-toggle='toc'] .nav .nav > .active:hover > a, 52 | nav[data-toggle='toc'] .nav .nav > .active:focus > a { 53 | padding-left: 28px; 54 | font-weight: 500; 55 | } 56 | 57 | /* from https://github.com/twbs/bootstrap/blob/e38f066d8c203c3e032da0ff23cd2d6098ee2dd6/docs/assets/css/src/docs.css#L631-L634 */ 58 | nav[data-toggle='toc'] .nav > .active > ul { 59 | display: block; 60 | } 61 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # poolr: Package for Pooling the Results from (Dependent) Tests 2 | 3 | [![R build status](https://github.com/ozancinar/poolr/workflows/R-CMD-check/badge.svg)](https://github.com/ozancinar/poolr/actions) 4 | [![CRAN Version](https://www.r-pkg.org/badges/version/poolr)](https://cran.r-project.org/package=poolr) 5 | [![devel Version](https://img.shields.io/badge/devel-1.3--0-brightgreen.svg)](https://github.com/ozancinar/poolr) 6 | [![Code Coverage](https://codecov.io/gh/ozancinar/poolr/branch/master/graph/badge.svg)](https://app.codecov.io/gh/ozancinar/poolr/) 7 | 8 | ## Description 9 | 10 | The `poolr` package contains functions for pooling/combining the results (i.e., p-values) from (dependent) hypothesis tests. Included are Fisher's method, Stouffer's method, the inverse chi-square method, the Bonferroni method, Tippett's method, and the binomial test. Each method can be adjusted based on an estimate of the effective number of tests or using empirically derived null distribution using pseudo replicates. For Fisher's, Stouffer's, and the inverse chi-square method, direct generalizations based on multivariate theory are also available (leading to Brown's method, Strube's method, and the generalized inverse chi-square method). 11 | 12 | ## Documentation 13 | 14 | You can read the documentation of the `poolr` package online at [https://ozancinar.github.io/poolr/](https://ozancinar.github.io/poolr/) (where it is nicely formatted, equations are shown correctly, and the output from all examples is provided). 15 | 16 | ## Installation 17 | 18 | The current official (i.e., [CRAN](https://cran.r-project.org/package=poolr)) release can be installed directly within R with: 19 | ```r 20 | install.packages("poolr") 21 | ``` 22 | 23 | After installing the [remotes](https://cran.r-project.org/package=remotes) package with ```install.packages("remotes")```, the development version of the `poolr` package can be installed with: 24 | ```r 25 | remotes::install_github("ozancinar/poolr") 26 | ``` 27 | 28 | ## Meta 29 | 30 | The `poolr` package was written by Ozan Cinar and [Wolfgang Viechtbauer](https://www.wvbauer.com/). It is licensed under the [GNU General Public License Version 2](https://www.gnu.org/licenses/old-licenses/gpl-2.0.txt). To report any issues or bugs, please go [here](https://github.com/ozancinar/poolr/issues). 31 | -------------------------------------------------------------------------------- /docs/docsearch.js: -------------------------------------------------------------------------------- 1 | $(function() { 2 | 3 | // register a handler to move the focus to the search bar 4 | // upon pressing shift + "/" (i.e. "?") 5 | $(document).on('keydown', function(e) { 6 | if (e.shiftKey && e.keyCode == 191) { 7 | e.preventDefault(); 8 | $("#search-input").focus(); 9 | } 10 | }); 11 | 12 | $(document).ready(function() { 13 | // do keyword highlighting 14 | /* modified from https://jsfiddle.net/julmot/bL6bb5oo/ */ 15 | var mark = function() { 16 | 17 | var referrer = document.URL ; 18 | var paramKey = "q" ; 19 | 20 | if (referrer.indexOf("?") !== -1) { 21 | var qs = referrer.substr(referrer.indexOf('?') + 1); 22 | var qs_noanchor = qs.split('#')[0]; 23 | var qsa = qs_noanchor.split('&'); 24 | var keyword = ""; 25 | 26 | for (var i = 0; i < qsa.length; i++) { 27 | var currentParam = qsa[i].split('='); 28 | 29 | if (currentParam.length !== 2) { 30 | continue; 31 | } 32 | 33 | if (currentParam[0] == paramKey) { 34 | keyword = decodeURIComponent(currentParam[1].replace(/\+/g, "%20")); 35 | } 36 | } 37 | 38 | if (keyword !== "") { 39 | $(".contents").unmark({ 40 | done: function() { 41 | $(".contents").mark(keyword); 42 | } 43 | }); 44 | } 45 | } 46 | }; 47 | 48 | mark(); 49 | }); 50 | }); 51 | 52 | /* Search term highlighting ------------------------------*/ 53 | 54 | function matchedWords(hit) { 55 | var words = []; 56 | 57 | var hierarchy = hit._highlightResult.hierarchy; 58 | // loop to fetch from lvl0, lvl1, etc. 59 | for (var idx in hierarchy) { 60 | words = words.concat(hierarchy[idx].matchedWords); 61 | } 62 | 63 | var content = hit._highlightResult.content; 64 | if (content) { 65 | words = words.concat(content.matchedWords); 66 | } 67 | 68 | // return unique words 69 | var words_uniq = [...new Set(words)]; 70 | return words_uniq; 71 | } 72 | 73 | function updateHitURL(hit) { 74 | 75 | var words = matchedWords(hit); 76 | var url = ""; 77 | 78 | if (hit.anchor) { 79 | url = hit.url_without_anchor + '?q=' + escape(words.join(" ")) + '#' + hit.anchor; 80 | } else { 81 | url = hit.url + '?q=' + escape(words.join(" ")); 82 | } 83 | 84 | return url; 85 | } 86 | -------------------------------------------------------------------------------- /tests/testthat/test_meff.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking meff() function") 6 | 7 | test_that("meff() works correctly.", { 8 | 9 | m_nyh1 <- meff(R = mvnconv(grid2ip.ld, side = 1, target = "p", cov2cor = TRUE), method = "nyholt") 10 | m_lj1 <- meff(R = mvnconv(grid2ip.ld, side = 1, target = "p", cov2cor = TRUE), method = "liji") 11 | m_gao1 <- meff(R = mvnconv(grid2ip.ld, side = 1, target = "p", cov2cor = TRUE), method = "gao") 12 | m_gal1 <- meff(R = mvnconv(grid2ip.ld, side = 1, target = "p", cov2cor = TRUE), method = "galwey") 13 | m_che1 <- meff(R = mvnconv(grid2ip.ld, side = 1, target = "p", cov2cor = TRUE), method = "chen") 14 | 15 | expect_equivalent(m_nyh1, 21, tolerance = m_tol) 16 | expect_equivalent(m_lj1, 15, tolerance = m_tol) 17 | expect_equivalent(m_gao1, 20, tolerance = m_tol) 18 | expect_equivalent(m_gal1, 14, tolerance = m_tol) 19 | expect_equivalent(m_che1, 18, tolerance = m_tol) 20 | 21 | m_nyh2 <- meff(R = mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "nyholt") 22 | m_lj2 <- meff(R = mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "liji") 23 | m_gao2 <- meff(R = mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "gao") 24 | m_gal2 <- meff(R = mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "galwey") 25 | m_che2 <- meff(R = mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "chen") 26 | 27 | expect_equivalent(m_nyh2, 22, tolerance = m_tol) 28 | expect_equivalent(m_lj2, 21, tolerance = m_tol) 29 | expect_equivalent(m_gao2, 23, tolerance = m_tol) 30 | expect_equivalent(m_gal2, 20, tolerance = m_tol) 31 | expect_equivalent(m_che2, 22, tolerance = m_tol) 32 | 33 | m_lj_eigen <- meff(eigen = eigen(mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE))$values, method = "liji") 34 | expect_equivalent(m_lj_eigen, 21, tolerance = m_tol) 35 | 36 | }) 37 | 38 | test_that("The arguments of meff() are checked correctly.", { 39 | 40 | expect_error(meff(method = "liji"), "Argument 'R' must be specified.") 41 | expect_error(meff(eigen = c("a"), method = "liji"), "Argument 'eigen' must be a numeric vector.") 42 | expect_warning(meff(mvnconv(grid2ip.ld, side = 2, target = "p", cov2cor = TRUE), method = "gao", C = "a")) 43 | 44 | }) 45 | -------------------------------------------------------------------------------- /R/empirical.r: -------------------------------------------------------------------------------- 1 | empirical <- function(R, method, side = 2, size = 10000, batchsize, ...) { 2 | 3 | # check if 'R' is specified 4 | if (missing(R)) 5 | stop("Argument 'R' must be specified.", call.=FALSE) 6 | 7 | # match 'method' argument 8 | method <- match.arg(method, c("fisher", "stouffer", "invchisq", "binomtest", "bonferroni", "tippett")) 9 | 10 | # checks for 'side' argument 11 | .check.side(side) 12 | 13 | # checks for 'R' argument 14 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = TRUE, nearpd = TRUE, checkcor = TRUE, checkdiag = TRUE, isbase = FALSE) 15 | 16 | ddd <- list(...) 17 | 18 | if (is.null(ddd$alpha)) { 19 | alpha <- .05 20 | } else { 21 | alpha <- ddd$alpha 22 | } 23 | 24 | k <- nrow(R) 25 | mu <- rep(0, k) 26 | 27 | if (missing(batchsize) || is.null(batchsize)) 28 | batchsize <- size 29 | 30 | if (batchsize < 1 || batchsize > size) 31 | stop("Argument 'batchsize' must be between 1 and the value of the 'size' argument.") 32 | 33 | emp.dist <- rep(NA_real_, size) 34 | 35 | fcall <- parse(text=paste0("apply(p, 1, function(x) .", method, "(x, k, alpha))")) 36 | 37 | if (size %% batchsize == 0) { 38 | batches <- size / batchsize 39 | batchsizes <- rep(batchsize, batches) 40 | } else { 41 | batches <- floor(size / batchsize) + 1 42 | batchsizes <- c(rep(batchsize, batches - 1), size %% batchsize) 43 | } 44 | 45 | batchpos <- c(0, cumsum(batchsizes)) 46 | 47 | #return(list(batches=batches, batchsize=batchsize, batchsizes=batchsizes, batchpos=batchpos)) 48 | 49 | if (isTRUE(ddd$verbose)) 50 | pbar <- txtProgressBar(min=0, max=length(batchsizes), style=3) 51 | 52 | for (i in seq_along(batchsizes)) { 53 | 54 | if (isTRUE(ddd$verbose)) 55 | setTxtProgressBar(pbar, i) 56 | 57 | if (is.null(ddd$mvnmethod)) { 58 | mvnmethod <- "mvt_eigen" 59 | } else { 60 | mvnmethod <- ddd$mvnmethod 61 | } 62 | 63 | z <- try(.simmvn(batchsizes[i], Sigma = R, mvnmethod = mvnmethod)) 64 | 65 | if (inherits(z, "try-error")) 66 | stop("Matrix to be generated is too large. Try setting 'batchsize' (or to a lower number if it was set).", call.=FALSE) 67 | 68 | if (side == 1) 69 | p <- pnorm(z, lower.tail = FALSE) 70 | 71 | if (side == 2) 72 | p <- 2 * pnorm(abs(z), lower.tail = FALSE) 73 | 74 | emp.dist[(batchpos[i]+1):batchpos[i+1]] <- eval(fcall) 75 | 76 | } 77 | 78 | if (isTRUE(ddd$verbose)) 79 | close(pbar) 80 | 81 | return(emp.dist) 82 | 83 | } 84 | -------------------------------------------------------------------------------- /man/poolr-package.Rd: -------------------------------------------------------------------------------- 1 | \name{poolr-package} 2 | \alias{poolr-package} 3 | \alias{poolr} 4 | \docType{package} 5 | \title{Methods for Pooling P-Values from (Dependent) Tests} 6 | \description{ 7 | \loadmathjax The \pkg{poolr} package contains functions for pooling/combining the results (i.e., \mjseqn{p}-values) from (dependent) hypothesis tests. Included are Fisher's method, Stouffer's method, the inverse chi-square method, the Bonferroni method, Tippett's method, and the binomial test. Each method can be adjusted based on an estimate of the effective number of tests or using empirically-derived null distribution using pseudo replicates. For Fisher's, Stouffer's, and the inverse chi-square method, direct generalizations based on multivariate theory are also available (leading to Brown's method, Strube's method, and the generalized inverse chi-square method). For more details, see: 8 | 9 | \itemize{ 10 | \item \code{\link{fisher}}: for Fisher's method (and Brown's method) 11 | \item \code{\link{stouffer}}: for Stouffer's method (and Strube's method) 12 | \item \code{\link{invchisq}}: for the inverse chi-square method 13 | \item \code{\link{bonferroni}}: for the Bonferroni method 14 | \item \code{\link{tippett}}: for Tippett's method 15 | \item \code{\link{binomtest}}: for the binomial test 16 | } 17 | 18 | Note that you can also read the documentation of the package online at \url{https://ozancinar.github.io/poolr/} (where it is nicely formatted and the output from all examples is provided). 19 | } 20 | \author{ 21 | Ozan Cinar \email{ozancinar86@gmail.com} \cr 22 | Wolfgang Viechtbauer \email{wvb@wvbauer.com} \cr 23 | } 24 | \references{ 25 | Brown, M. B. (1975). 400: A method for combining non-independent, one-sided tests of significance. \emph{Biometrics, 31}(4), 987--992. \verb{https://doi.org/10.2307/2529826} 26 | 27 | Cinar, O. & Viechtbauer, W. (2022). The poolr package for combining independent and dependent p values. \emph{Journal of Statistical Software}, \bold{101}(1), 1--42. \verb{https://doi.org/10.18637/jss.v101.i01} 28 | 29 | Fisher, R. A. (1932). \emph{Statistical Methods for Research Workers} (4th ed.). Edinburgh: Oliver and Boyd. 30 | 31 | Lancaster, H. O. (1961). The combination of probabilities: An application of orthonormal functions. \emph{Australian Journal of Statistics, 3}(1), 20--33. \verb{https://doi.org/10.1111/j.1467-842X.1961.tb00058.x} 32 | 33 | Strube, M. J. (1985). Combining and comparing significance levels from nonindependent hypothesis tests. \emph{Psychological Bulletin, 97}(2), 334--341. \verb{https://doi.org/10.1037/0033-2909.97.2.334} 34 | 35 | Tippett, L. H. C. (1931). \emph{Methods of Statistics}. London: Williams Norgate. 36 | 37 | Wilkinson, B. (1951). A statistical consideration in psychological research. \emph{Psychological Bulletin, 48}(2), 156--158. \verb{https://doi.org/10.1037/h0059111} 38 | } 39 | \keyword{package} 40 | -------------------------------------------------------------------------------- /R/tippett.r: -------------------------------------------------------------------------------- 1 | tippett <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | # compute test statistic 37 | statistic <- min(p) 38 | 39 | # set some defaults 40 | ci <- NULL 41 | size_used <- NULL 42 | if (adjust != "user") 43 | m <- NULL 44 | 45 | if (adjust == "none") { 46 | 47 | pval <- 1 - (1 - statistic)^k 48 | 49 | } 50 | 51 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 52 | 53 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 54 | 55 | pval <- 1 - (1 - statistic)^m 56 | 57 | } 58 | 59 | if (adjust == "empirical") { 60 | 61 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 62 | 63 | # setting 'batchsize' to NULL if it is missing 64 | if (missing(batchsize)) 65 | batchsize <- NULL 66 | 67 | # setting 'threshold' to NULL if it is missing for further checks 68 | if (missing(threshold)) 69 | threshold <- NULL 70 | 71 | # checks/fixes for 'size' and 'threshold' arguments 72 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 73 | 74 | # observed pooled p-value 75 | pval.obs <- 1 - (1 - statistic)^k 76 | 77 | # get empirically derived p-value 78 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 79 | R = R, method = fun, side = side, batchsize = batchsize) 80 | 81 | pval <- tmp$pval 82 | ci <- tmp$ci 83 | size_used <- tmp$size 84 | 85 | } 86 | 87 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun) 88 | 89 | class(res) <- "poolr" 90 | return(res) 91 | 92 | } 93 | -------------------------------------------------------------------------------- /R/print.poolr.r: -------------------------------------------------------------------------------- 1 | print.poolr <- function(x, digits=3, ...) { 2 | 3 | cat("combined p-values with: ") 4 | 5 | if (x$fun == "fisher") 6 | cat("Fisher's method\n") 7 | if (x$fun == "stouffer") 8 | cat("Stouffer's method\n") 9 | if (x$fun == "invchisq") 10 | cat("inverse chi-square method\n") 11 | if (x$fun == "bonferroni") 12 | cat("Bonferroni method\n") 13 | if (x$fun == "tippett") 14 | cat("Tippett's method\n") 15 | if (x$fun == "binomtest") 16 | cat("binomial test\n") 17 | 18 | cat("number of p-values combined:", x$k, "\n") 19 | 20 | if (x$fun %in% c("fisher", "invchisq")) 21 | testinfo <- paste0("test statistic: ", round(x$statistic, digits), " ~ chi-square(df = ", round(attr(x$statistic, "df"), digits), ")") 22 | 23 | if (x$fun == "stouffer") 24 | testinfo <- paste0("test statistic: ", round(x$statistic, digits), " ~ N(0,1)") 25 | 26 | if (x$fun %in% c("bonferroni", "tippett")) 27 | testinfo <- paste0("minimum p-value: ", round(x$statistic, digits)) 28 | 29 | if (x$fun == "binomtest") { 30 | if (x$adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 31 | testinfo <- paste0("number of significant tests: ", round(x$statistic * x$m / x$k), " (adjusted based on m; at alpha = ", x$alpha, ")") 32 | } else { 33 | testinfo <- paste0("number of significant tests: ", x$statistic, " (at alpha = ", x$alpha, ")") 34 | } 35 | } 36 | 37 | cat(testinfo, "\n") 38 | 39 | if (x$adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 40 | 41 | if (x$adjust == "nyholt") 42 | x$adjust <- "Nyholt, 2004" 43 | 44 | if (x$adjust == "liji") 45 | x$adjust <- "Li & Ji, 2005" 46 | 47 | if (x$adjust == "gao") 48 | x$adjust <- "Gao, 2008" 49 | 50 | if (x$adjust == "galwey") 51 | x$adjust <- "Galwey, 2009" 52 | 53 | if (x$adjust == "chen") 54 | x$adjust <- "Chen & Liu, 2011" 55 | 56 | if (x$adjust == "user") 57 | x$adjust <- "user-defined" 58 | 59 | x$adjust <- paste0("effective number of tests (m = ", x$m, "; ", x$adjust, ")") 60 | x$p <- format.pval(x$p, digits) 61 | 62 | } 63 | 64 | if (x$adjust == "generalized") { 65 | 66 | if (x$fun == "fisher") 67 | x$adjust <- "Brown's method" 68 | if (x$fun == "invchisq") 69 | x$adjust <- "Satterthwaite approximation" 70 | if (x$fun == "stouffer") 71 | x$adjust <- "Strube's method" 72 | 73 | x$p <- format.pval(x$p, digits) 74 | 75 | } 76 | 77 | if (x$adjust == "empirical") { 78 | 79 | x$adjust <- paste0("empirical distribution (size = ", as.integer(x$size), ")") 80 | x$p <- paste0(format.pval(x$p, digits), " (95% CI: ", format.pval(x$ci[1], digits), ", ", format.pval(x$ci[2], digits), ")") 81 | 82 | } 83 | 84 | cat("adjustment: ", x$adjust, "\n") 85 | cat("combined p-value: ", x$p, "\n") 86 | 87 | invisible() 88 | 89 | } 90 | -------------------------------------------------------------------------------- /R/bonferroni.r: -------------------------------------------------------------------------------- 1 | bonferroni <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | # compute test statistic 37 | statistic <- min(p) 38 | 39 | # set some defaults 40 | ci <- NULL 41 | size_used <- NULL 42 | if (adjust != "user") 43 | m <- NULL 44 | 45 | if (adjust == "none") { 46 | 47 | pval <- min(1, statistic * k) 48 | 49 | } 50 | 51 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 52 | 53 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 54 | 55 | pval <- min(1, statistic * m) 56 | 57 | } 58 | 59 | if (adjust == "empirical") { 60 | 61 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 62 | 63 | # setting 'batchsize' to NULL if it is missing 64 | if (missing(batchsize)) 65 | batchsize <- NULL 66 | 67 | # setting 'threshold' to NULL if it is missing for further checks 68 | if (missing(threshold)) 69 | threshold <- NULL 70 | 71 | # checks/fixes for 'size' and 'threshold' arguments 72 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 73 | 74 | # observed pooled p-value 75 | #pval.obs <- min(1, statistic * k) 76 | pval.obs <- statistic * k 77 | 78 | # get empirically derived p-value 79 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 80 | R = R, method = fun, side = side, batchsize = batchsize) 81 | 82 | pval <- tmp$pval 83 | ci <- tmp$ci 84 | size_used <- tmp$size 85 | 86 | } 87 | 88 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun) 89 | 90 | class(res) <- "poolr" 91 | return(res) 92 | 93 | } 94 | -------------------------------------------------------------------------------- /R/binomtest.r: -------------------------------------------------------------------------------- 1 | binomtest <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | if (is.null(ddd$alpha)) { 37 | alpha <- .05 38 | } else { 39 | alpha <- ddd$alpha 40 | } 41 | 42 | # compute test statistic 43 | statistic <- sum(p <= alpha) 44 | 45 | # set some defaults 46 | ci <- NULL 47 | size_used <- NULL 48 | if (adjust != "user") 49 | m <- NULL 50 | 51 | if (adjust == "none") { 52 | 53 | pval <- sum(dbinom(statistic:k, k, alpha)) 54 | 55 | } 56 | 57 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 58 | 59 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 60 | 61 | pval <- sum(dbinom(round(statistic * m / k):m, m, alpha)) 62 | 63 | } 64 | 65 | if (adjust == "empirical") { 66 | 67 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 68 | 69 | # setting 'batchsize' to NULL if it is missing 70 | if (missing(batchsize)) 71 | batchsize <- NULL 72 | 73 | # setting 'threshold' to NULL if it is missing for further checks 74 | if (missing(threshold)) 75 | threshold <- NULL 76 | 77 | # checks/fixes for 'size' and 'threshold' arguments 78 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 79 | 80 | # observed pooled p-value 81 | pval.obs <- sum(dbinom(statistic:k, k, alpha)) 82 | 83 | # get empirically derived p-value 84 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 85 | R = R, method = fun, side = side, batchsize = batchsize) 86 | 87 | pval <- tmp$pval 88 | ci <- tmp$ci 89 | size_used <- tmp$size 90 | 91 | } 92 | 93 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun, alpha = alpha) 94 | 95 | class(res) <- "poolr" 96 | return(res) 97 | 98 | } 99 | -------------------------------------------------------------------------------- /R/stouffer.r: -------------------------------------------------------------------------------- 1 | stouffer <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | # compute test statistic 37 | statistic <- sum(qnorm(p, lower.tail = FALSE)) / sqrt(k) 38 | 39 | # set some defaults 40 | ci <- NULL 41 | size_used <- NULL 42 | if (adjust != "user") 43 | m <- NULL 44 | 45 | if (adjust == "none") { 46 | 47 | pval <- pnorm(statistic, lower.tail = FALSE) 48 | 49 | } 50 | 51 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 52 | 53 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 54 | 55 | statistic <- statistic * sqrt(m / k) 56 | pval <- pnorm(statistic, lower.tail = FALSE) 57 | 58 | } 59 | 60 | if (adjust == "generalized") { 61 | 62 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 63 | 64 | statistic <- statistic * sqrt(k) / sqrt(sum(R)) 65 | pval <- pnorm(statistic, lower.tail = FALSE) 66 | 67 | } 68 | 69 | if (adjust == "empirical") { 70 | 71 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 72 | 73 | # setting 'batchsize' to NULL if it is missing 74 | if (missing(batchsize)) 75 | batchsize <- NULL 76 | 77 | # setting 'threshold' to NULL if it is missing for further checks 78 | if (missing(threshold)) 79 | threshold <- NULL 80 | 81 | # checks/fixes for 'size' and 'threshold' arguments 82 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 83 | 84 | # observed pooled p-value 85 | pval.obs <- pnorm(statistic, lower.tail = FALSE) 86 | 87 | # get empirically derived p-value 88 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 89 | R = R, method = fun, side = side, batchsize = batchsize) 90 | 91 | pval <- tmp$pval 92 | ci <- tmp$ci 93 | size_used <- tmp$size 94 | 95 | } 96 | 97 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun) 98 | 99 | class(res) <- "poolr" 100 | return(res) 101 | 102 | } 103 | -------------------------------------------------------------------------------- /man/mvnlookup.Rd: -------------------------------------------------------------------------------- 1 | \name{mvnlookup} 2 | \docType{data} 3 | \alias{mvnlookup} 4 | \title{Lookup Table for the mvnconv() Function} 5 | \description{Lookup table for the \code{\link{mvnconv}} function.\loadmathjax} 6 | \usage{mvnlookup} 7 | \format{The data frame contains the following columns: 8 | \tabular{lll}{ 9 | \bold{rhos} \tab \code{numeric} \tab correlations among the test statistics \cr 10 | \bold{m2lp_1} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]}{Cov[-2 ln(p_i), -2 ln(p_j)]} (for one-sided tests) \cr 11 | \bold{m2lp_2} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]}{Cov[-2 ln(p_i), -2 ln(p_j)]} (for two-sided tests) \cr 12 | \bold{z_1} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]}{Cov[Phi^{-1}(1 - p_i), Phi^{-1}(1 - p_j)]} (for one-sided tests) \cr 13 | \bold{z_2} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]}{Cov[Phi^{-1}(1 - p_i), Phi^{-1}(1 - p_j)]} (for two-sided tests) \cr 14 | \bold{chisq1_1} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}{Cov[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]} (for one-sided tests) \cr 15 | \bold{chisq1_2} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}{Cov[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]} (for two-sided tests) \cr 16 | \bold{p_1} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[p_i, p_j]}{Cov[p_i, p_j]} (for one-sided tests) \cr 17 | \bold{p_2} \tab \code{numeric} \tab \mjeqn{\mbox{Cov}[p_i, p_j]}{Cov[p_i, p_j]} (for two-sided tests) \cr 18 | } 19 | } 20 | \details{ 21 | Assume \mjtdeqn{\left[\begin{array}{c} t_i \\\\ t_j \end{array}\right] \sim \mbox{MVN} \left(\left[\begin{array}{c} 0 \\\\ 0 \end{array}\right], \left[\begin{array}{cc} 1 & \rho_{ij} \\\\ \rho_{ij} & 1 \end{array}\right] \right)}{\begin{bmatrix} t_i \\\\\ t_j \end{bmatrix} \sim \mbox{MVN} \left(\begin{bmatrix} 0 \\\\\ 0 \end{bmatrix}, \begin{bmatrix} 1 & \rho_{ij} \\\\\ \rho_{ij} & 1 \end{bmatrix} \right)}{[t_i, t_j]' ~ MVN([0,0]', [1, rho_ij | rho_ij, 1])} is the joint distribution for test statistics \mjseqn{t_i} and \mjseqn{t_j}. For one-sided tests, let \mjeqn{p_i = 1 - \Phi(t_i)}{p_i = 1 - Phi(t_i)} and \mjeqn{p_j = 1 - \Phi(t_j)}{p_j = 1 - Phi(t_j)} where \mjeqn{\Phi(\cdot)}{Phi(.)} denotes the cumulative distribution function of a standard normal distribution. For two-sided tests, let \mjeqn{p_i = 2(1 - \Phi(|t_i|))}{p_i = 2(1 - Phi(|t_i|))} and \mjeqn{p_j = 2(1 - \Phi(|t_j|))}{p_j = 2(1 - Phi(|t_j|))}. These are simply the one- and two-sided \mjseqn{p}-values corresponding to \mjseqn{t_i} and \mjseqn{t_j}. 22 | 23 | Columns \code{p_1} and \code{p_2} contain the values for \mjeqn{\mbox{Cov}[p_i, p_j]}{Cov[p_i, p_j]}. 24 | 25 | Columns \code{m2lp_1} and \code{m2lp_2} contain the values for \mjeqn{\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]}{Cov[-2 ln(p_i), -2 ln(p_j)]}. 26 | 27 | Columns \code{chisq1_1} and \code{chisq1_2} contain the values for \mjeqn{\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}{Cov[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}, where \mjeqn{F^{-1}(\cdot,1)}{F^{-1}(.,1)} denotes the inverse of the cumulative distribution function of a chi-square distribution with one degree of freedom. 28 | 29 | Columns \code{z_1} and \code{z_2} contain the values for \mjeqn{\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]}{Cov[Phi^{-1}(1 - p_i), Phi^{-1}(1 - p_j)]}, where \mjeqn{\Phi^{-1}(\cdot)}{Phi^{-1}(.)} denotes the inverse of the cumulative distribution function of a standard normal distribution. 30 | 31 | Computation of these covariances required numerical integration. The values in this table were precomputed. 32 | 33 | } 34 | \keyword{datasets} 35 | -------------------------------------------------------------------------------- /docs/pkgdown.js: -------------------------------------------------------------------------------- 1 | /* http://gregfranko.com/blog/jquery-best-practices/ */ 2 | (function($) { 3 | $(function() { 4 | 5 | $('.navbar-fixed-top').headroom(); 6 | 7 | $('body').css('padding-top', $('.navbar').height() + 10); 8 | $(window).resize(function(){ 9 | $('body').css('padding-top', $('.navbar').height() + 10); 10 | }); 11 | 12 | $('[data-toggle="tooltip"]').tooltip(); 13 | 14 | var cur_path = paths(location.pathname); 15 | var links = $("#navbar ul li a"); 16 | var max_length = -1; 17 | var pos = -1; 18 | for (var i = 0; i < links.length; i++) { 19 | if (links[i].getAttribute("href") === "#") 20 | continue; 21 | // Ignore external links 22 | if (links[i].host !== location.host) 23 | continue; 24 | 25 | var nav_path = paths(links[i].pathname); 26 | 27 | var length = prefix_length(nav_path, cur_path); 28 | if (length > max_length) { 29 | max_length = length; 30 | pos = i; 31 | } 32 | } 33 | 34 | // Add class to parent
  • , and enclosing
  • if in dropdown 35 | if (pos >= 0) { 36 | var menu_anchor = $(links[pos]); 37 | menu_anchor.parent().addClass("active"); 38 | menu_anchor.closest("li.dropdown").addClass("active"); 39 | } 40 | }); 41 | 42 | function paths(pathname) { 43 | var pieces = pathname.split("/"); 44 | pieces.shift(); // always starts with / 45 | 46 | var end = pieces[pieces.length - 1]; 47 | if (end === "index.html" || end === "") 48 | pieces.pop(); 49 | return(pieces); 50 | } 51 | 52 | // Returns -1 if not found 53 | function prefix_length(needle, haystack) { 54 | if (needle.length > haystack.length) 55 | return(-1); 56 | 57 | // Special case for length-0 haystack, since for loop won't run 58 | if (haystack.length === 0) { 59 | return(needle.length === 0 ? 0 : -1); 60 | } 61 | 62 | for (var i = 0; i < haystack.length; i++) { 63 | if (needle[i] != haystack[i]) 64 | return(i); 65 | } 66 | 67 | return(haystack.length); 68 | } 69 | 70 | /* Clipboard --------------------------*/ 71 | 72 | function changeTooltipMessage(element, msg) { 73 | var tooltipOriginalTitle=element.getAttribute('data-original-title'); 74 | element.setAttribute('data-original-title', msg); 75 | $(element).tooltip('show'); 76 | element.setAttribute('data-original-title', tooltipOriginalTitle); 77 | } 78 | 79 | if(ClipboardJS.isSupported()) { 80 | $(document).ready(function() { 81 | var copyButton = ""; 82 | 83 | $("div.sourceCode").addClass("hasCopyButton"); 84 | 85 | // Insert copy buttons: 86 | $(copyButton).prependTo(".hasCopyButton"); 87 | 88 | // Initialize tooltips: 89 | $('.btn-copy-ex').tooltip({container: 'body'}); 90 | 91 | // Initialize clipboard: 92 | var clipboardBtnCopies = new ClipboardJS('[data-clipboard-copy]', { 93 | text: function(trigger) { 94 | return trigger.parentNode.textContent.replace(/\n#>[^\n]*/g, ""); 95 | } 96 | }); 97 | 98 | clipboardBtnCopies.on('success', function(e) { 99 | changeTooltipMessage(e.trigger, 'Copied!'); 100 | e.clearSelection(); 101 | }); 102 | 103 | clipboardBtnCopies.on('error', function() { 104 | changeTooltipMessage(e.trigger,'Press Ctrl+C or Command+C to copy'); 105 | }); 106 | }); 107 | } 108 | })(window.jQuery || window.$) 109 | -------------------------------------------------------------------------------- /R/mvnconv.r: -------------------------------------------------------------------------------- 1 | mvnconv <- function(R, side = 2, target, cov2cor = FALSE) { 2 | 3 | # check if 'R' is specified 4 | if (missing(R)) 5 | stop("Argument 'R' must be specified.", call.=FALSE) 6 | 7 | # get name of calling function (character(0) if called from global environment) 8 | call.fun <- as.character(sys.call(-1)[1]) 9 | call.fun <- gsub("^poolr::", "", call.fun) 10 | 11 | # checks for 'R' argument 12 | if (isTRUE(call.fun %in% c("fisher", "stouffer", "invchisq", "binomtest", "bonferroni", "tippett"))) { 13 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = TRUE, checkdiag = TRUE, isbase = FALSE) 14 | } else { 15 | R <- .check.R(R, checksym = !is.vector(R), checkna = FALSE, checkpd = FALSE, nearpd = FALSE, checkcor = TRUE, checkdiag = !is.vector(R), isbase = FALSE) 16 | } 17 | 18 | if (isTRUE(call.fun %in% c("fisher", "stouffer", "invchisq"))) { 19 | 20 | if (missing(target)) { 21 | 22 | # for fisher(), stouffer(), and invchisq(), set the default 'target' if it is not specified 23 | 24 | if (call.fun == "fisher") 25 | target <- "m2lp" 26 | if (call.fun == "stouffer") 27 | target <- "z" 28 | if (call.fun == "invchisq") 29 | target <- "chisq1" 30 | 31 | } 32 | 33 | } else { 34 | 35 | # when calling mvnconv() from the global environment or some other function besides fisher(), stouffer(), or invchisq(), must specify 'target' 36 | 37 | if (missing(target)) 38 | stop("Argument 'target' must be specified.") 39 | 40 | } 41 | 42 | target <- match.arg(target, c("m2lp", "z", "chisq1", "p")) 43 | 44 | # check for incompatibility between poolr base function and the specified target (only when adjust = "generalized") 45 | 46 | if (isTRUE(call.fun %in% c("fisher", "stouffer", "invchisq"))) { 47 | # figure out what the 'adjust' argument was (this also handles the case where 'adjust' argument is abbreviated) 48 | call.fun.args <- as.list(match.call(definition = sys.function(-1), call = sys.call(-1), expand.dots = FALSE)) 49 | adjust <- match.arg(call.fun.args$adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 50 | if (adjust == "generalized" && ((call.fun == "fisher" && target != "m2lp") || (call.fun == "stouffer" && target != "z") || (call.fun == "invchisq" && target != "chisq1"))) 51 | warning(paste0("Using mvnconv(..., target=\"", target, "\") is not compatible with ", call.fun, "().")) 52 | } 53 | 54 | # checks for 'side' argument 55 | 56 | .check.side(side) 57 | 58 | # set correct column of 'mvnlookup' for converting values in R to target values 59 | 60 | column <- pmatch(target, c("m2lp", "z", "chisq1", "p")) 61 | column <- column * 2 62 | 63 | if (side == 2) 64 | column <- column + 1 65 | 66 | # round elements in 'R' to 3 decimals (since mvnlookup[,1] values are in .001 steps) 67 | R <- round(R, 3L) 68 | 69 | # replace elements < -0.99 in 'R' with -0.99 70 | R[R < -0.99] <- -0.99 71 | 72 | mvnlookup <- get(data(mvnlookup, package="poolr", envir = environment())) 73 | 74 | if (is.matrix(R)) { 75 | 76 | # get lower triangular part of R 77 | r <- R[lower.tri(R, diag=TRUE)] 78 | 79 | # convert correlations to covariances for the chosen target 80 | covs <- matrix(NA, nrow = nrow(R), ncol = ncol(R)) 81 | covs[lower.tri(covs, diag=TRUE)] <- mvnlookup[match(r, mvnlookup[,1]), column] 82 | covs[upper.tri(covs)] <- t(covs)[upper.tri(covs)] 83 | 84 | } else { 85 | 86 | covs <- mvnlookup[match(R, mvnlookup[,1]), column] 87 | 88 | } 89 | 90 | if (cov2cor) { 91 | var <- mvnlookup[1,column] 92 | covs <- covs / var 93 | } 94 | 95 | return(covs) 96 | 97 | } 98 | -------------------------------------------------------------------------------- /R/fisher.r: -------------------------------------------------------------------------------- 1 | fisher <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | # compute test statistic 37 | statistic <- -2 * sum(log(p)) 38 | attr(statistic, "df") <- 2 * k 39 | 40 | # set some defaults 41 | ci <- NULL 42 | size_used <- NULL 43 | if (adjust != "user") 44 | m <- NULL 45 | 46 | if (adjust == "none") { 47 | 48 | pval <- pchisq(statistic, df = 2 * k, lower.tail = FALSE) 49 | 50 | } 51 | 52 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 53 | 54 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 55 | 56 | statistic <- statistic * (m / k) 57 | pval <- pchisq(statistic, df = 2 * m, lower.tail = FALSE) 58 | attr(statistic, "df") <- 2 * m 59 | 60 | } 61 | 62 | if (adjust == "generalized") { 63 | 64 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = nearpd, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 65 | 66 | covs <- R 67 | expx2 <- 2 * k 68 | varx2 <- sum(covs) 69 | fval <- 2 * expx2^2 / varx2 70 | cval <- varx2 / (2 * expx2) 71 | 72 | statistic <- statistic / cval 73 | pval <- pchisq(statistic, df = fval, lower.tail = FALSE) 74 | attr(statistic, "df") <- fval 75 | 76 | } 77 | 78 | if (adjust == "empirical") { 79 | 80 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = nearpd, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 81 | 82 | # setting 'batchsize' to NULL if it is missing 83 | if (missing(batchsize)) 84 | batchsize <- NULL 85 | 86 | # setting 'threshold' to NULL if it is missing for further checks 87 | if (missing(threshold)) 88 | threshold <- NULL 89 | 90 | # checks/fixes for 'size' and 'threshold' arguments 91 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 92 | 93 | # observed pooled p-value 94 | pval.obs <- pchisq(statistic, df = 2 * k, lower.tail = FALSE) 95 | 96 | # get empirically derived p-value 97 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 98 | R = R, method = fun, side = side, batchsize = batchsize) 99 | 100 | pval <- tmp$pval 101 | ci <- tmp$ci 102 | size_used <- tmp$size 103 | 104 | } 105 | 106 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun) 107 | 108 | class(res) <- "poolr" 109 | return(res) 110 | 111 | } 112 | -------------------------------------------------------------------------------- /R/invchisq.r: -------------------------------------------------------------------------------- 1 | invchisq <- function(p, adjust = "none", R, m, size = 10000, threshold, side = 2, batchsize, nearpd = TRUE, ...) { 2 | 3 | # checks for 'p' argument 4 | p <- .check.p(p) 5 | 6 | k <- length(p) 7 | 8 | # match 'adjust' argument 9 | adjust <- match.arg(adjust, c("none", "nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 10 | 11 | # if m is specified, apply effective number of test adjustment with user-defined m 12 | if (!missing(m)) 13 | adjust <- "user" 14 | 15 | # get name of function 16 | fun <- as.character(sys.call()[1]) 17 | fun <- gsub("^poolr::", "", fun) 18 | 19 | ddd <- list(...) 20 | 21 | if (missing(R)) { 22 | 23 | # check if 'R' is specified when using an adjustment method (does not apply to "user") 24 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "empirical", "generalized")) 25 | stop("Argument 'R' must be specified when using an adjustment method.") 26 | 27 | } else { 28 | 29 | R # force evaluation of 'R' argument, so that R=mvnconv(R) works 30 | 31 | # checks for 'R' argument 32 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = FALSE, checkdiag = FALSE, isbase = TRUE, k = k, adjust = adjust, fun = fun) 33 | 34 | } 35 | 36 | # compute test statistic 37 | statistic <- sum(qchisq(p, df = 1, lower.tail = FALSE)) 38 | attr(statistic, "df") <- k 39 | 40 | # set some defaults 41 | ci <- NULL 42 | size_used <- NULL 43 | if (adjust != "user") 44 | m <- NULL 45 | 46 | if (adjust == "none") { 47 | 48 | pval <- pchisq(statistic, df = k, lower.tail = FALSE) 49 | 50 | } 51 | 52 | if (adjust %in% c("nyholt", "liji", "gao", "galwey", "chen", "user")) { 53 | 54 | m <- .check.m(R = R, adjust = adjust, m = m, k = k, ...) 55 | 56 | statistic <- statistic * (m / k) 57 | pval <- pchisq(statistic, df = m, lower.tail = FALSE) 58 | attr(statistic, "df") <- m 59 | 60 | } 61 | 62 | if (adjust == "generalized") { 63 | 64 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 65 | 66 | covs <- R 67 | expx2 <- k 68 | varx2 <- sum(covs) 69 | fval <- 2 * expx2^2 / varx2 70 | cval <- varx2 / (2 * expx2) 71 | 72 | statistic <- statistic / cval 73 | pval <- pchisq(statistic, df = fval, lower.tail = FALSE) 74 | attr(statistic, "df") <- fval 75 | 76 | } 77 | 78 | if (adjust == "empirical") { 79 | 80 | R <- .check.R(R, checksym = FALSE, checkna = FALSE, checkpd = TRUE, nearpd = TRUE, checkcor = FALSE, checkdiag = FALSE, isbase = FALSE) 81 | 82 | # setting 'batchsize' to NULL if it is missing 83 | if (missing(batchsize)) 84 | batchsize <- NULL 85 | 86 | # setting 'threshold' to NULL if it is missing for further checks 87 | if (missing(threshold)) 88 | threshold <- NULL 89 | 90 | # checks/fixes for 'size' and 'threshold' arguments 91 | emp.setup <- .check.emp.setup(size = size, threshold = threshold, ddd = ddd) 92 | 93 | # observed pooled p-value 94 | pval.obs <- pchisq(statistic, df = k, lower.tail = FALSE) 95 | 96 | # get empirically derived p-value 97 | tmp <- .do.emp(pval.obs = pval.obs, emp.setup = emp.setup, ddd = ddd, 98 | R = R, method = fun, side = side, batchsize = batchsize) 99 | 100 | pval <- tmp$pval 101 | ci <- tmp$ci 102 | size_used <- tmp$size 103 | 104 | } 105 | 106 | res <- list(p = c(pval), ci = ci, k = k, m = m, adjust = adjust, statistic = statistic, size = size_used, fun = fun) 107 | 108 | class(res) <- "poolr" 109 | return(res) 110 | 111 | } 112 | -------------------------------------------------------------------------------- /R/meff.r: -------------------------------------------------------------------------------- 1 | meff <- function(R, eigen, method, ...) { 2 | 3 | # match 'method' argument 4 | method <- match.arg(method, c("nyholt", "liji", "gao", "galwey", "chen")) 5 | 6 | if (method %in% c("nyholt", "liji", "gao", "galwey")) { 7 | 8 | if (missing(eigen)) { 9 | 10 | # check if 'R' is specified 11 | if (missing(R)) 12 | stop("Argument 'R' must be specified.", call.=FALSE) 13 | 14 | # checks for 'R' argument 15 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = TRUE, checkdiag = TRUE, isbase = FALSE) 16 | 17 | # get eigenvalues of 'R' matrix 18 | evs <- base::eigen(R)$values 19 | 20 | } else { 21 | 22 | # can pass eigenvalues directly to function via 'eigen' 23 | 24 | if (!.is.numeric.vector(eigen)) 25 | stop("Argument 'eigen' must be a numeric vector.", call.=FALSE) 26 | 27 | evs <- eigen 28 | 29 | } 30 | 31 | # check if there are negative eigenvalues 32 | if (any(evs < 0)) 33 | warning(paste0("One or more eigenvalues ", ifelse(missing(eigen), "derived from the 'R' matrix ", ""), "are negative."), call.=FALSE) 34 | 35 | } else { 36 | 37 | # check if 'R' is specified 38 | if (missing(R)) 39 | stop("Argument 'R' must be specified.", call.=FALSE) 40 | 41 | # checks for 'R' argument 42 | R <- .check.R(R, checksym = TRUE, checkna = TRUE, checkpd = FALSE, nearpd = FALSE, checkcor = TRUE, checkdiag = TRUE, isbase = FALSE) 43 | 44 | } 45 | 46 | if (method == "nyholt") { 47 | 48 | # effective number of tests (based on Nyholt, 2004) 49 | k <- length(evs) 50 | m <- 1 + (k - 1) * (1 - var(evs) / k) 51 | 52 | } 53 | 54 | if (method == "liji") { 55 | 56 | # effective number of tests (based on Li & Ji, 2005) 57 | # adding a small value to the absolute eigenvalues to overcome numerical imprecisions 58 | abs.evs <- abs(evs) + sqrt(.Machine$double.eps) 59 | m <- sum(ifelse(abs.evs >= 1, 1, 0) + (abs.evs - floor(abs.evs))) 60 | 61 | } 62 | 63 | if (method == "gao") { 64 | 65 | # effective number of tests (based on Gao, 2008) 66 | 67 | ddd <- list(...) 68 | 69 | # allow user to specify value of C via ... but otherwise use 0.995 70 | if (!is.null(ddd$C)) { 71 | C <- ddd$C 72 | } else { 73 | C <- 0.995 74 | } 75 | 76 | if (C < 0 || C >= 1) 77 | warning("Value of 'C' should be >= 0 and < 1.", call.=FALSE) 78 | 79 | m <- which(cumsum(sort(evs, decreasing = TRUE)) / sum(evs) > C)[1] 80 | 81 | } 82 | 83 | if (method == "galwey") { 84 | 85 | # if there are negative eigenvalues, inform user that they were set to 0 86 | if (any(evs < 0)) { 87 | warning(paste0("Negative eigenvalues ", ifelse(missing(eigen), "derived from the 'R' matrix ", ""), "were set to 0."), call.=FALSE) 88 | evs[evs < 0] <- 0 89 | } 90 | 91 | # effective number of tests (based on Galwey, 2009) 92 | m <- sum(sqrt(evs))^2 / sum(evs) 93 | 94 | } 95 | 96 | if (method == "chen") { 97 | 98 | # effective number of tests (based on Chen & Liu, 2011) 99 | 100 | ddd <- list(...) 101 | 102 | # allow user to specify the power value via ... but otherwise use 7 103 | # (note: in the paper, this value is called k, but we cannot use this 104 | # since k is already used to define the number of p-values) 105 | 106 | if (!is.null(ddd$C)) { 107 | C <- ddd$C 108 | } else { 109 | C <- 7 110 | } 111 | 112 | if (C < 1) 113 | warning("Value of 'C' should be >= 1.", call.=FALSE) 114 | 115 | # effective number of tests (based on Chen & Liu, 2011) 116 | m <- sum(1 / apply(R, 1, function(r) sum(abs(r)^C))) 117 | 118 | } 119 | 120 | # always round down the estimated value 121 | m <- floor(m) 122 | 123 | return(m) 124 | 125 | } 126 | -------------------------------------------------------------------------------- /quick_start.md: -------------------------------------------------------------------------------- 1 | # Quick Start Guide 2 | 3 | The package contains six 'base methods' for pooling p-values: 4 | 5 | * `fisher()`: for Fisher's method, 6 | * `stouffer()`: for Stouffer's method, 7 | * `invchisq()`: for the inverse chi-square method, 8 | * `binomtest()`: for the binomial test, 9 | * `bonferroni()`: for the Bonferroni method, 10 | * `tippett()`: for Tippett's method. 11 | 12 | For example, we can combine a set of independent p-values using [Fisher's method](https://en.wikipedia.org/wiki/Fisher's_method) as follows: 13 | 14 | ```r 15 | library(poolr) 16 | pvals <- c(0.02, 0.03, 0.08, 0.20) 17 | fisher(pvals) 18 | ``` 19 | ``` 20 | combined p-values with: Fisher's method 21 | number of p-values combined: 4 22 | test statistic: 23.107 ~ chi-square(df = 8) 23 | adjustment: none 24 | combined p-value: 0.003228942 25 | ``` 26 | 27 | More interesting are cases where the p-values are not independent. For example, 28 | 29 | ```r 30 | round(grid2ip.p[1:5], digits = 5) 31 | ``` 32 | ``` 33 | rs10267908 rs112305062 rs117541653 rs11761490 rs11773436 34 | 0.01137 0.50636 0.12303 0.09992 0.00169 35 | ``` 36 | 37 | shows the first 5 p-values from (two-sided) tests of the association between 23 [single-nucleotide polymorphisms](https://en.wikipedia.org/wiki/Single-nucleotide_polymorphism) (SNPs) in the *GRID2IP* gene and depressive symptoms. Due to [linkage disequilibrium](https://en.wikipedia.org/wiki/Linkage_disequilibrium) (LD), the SNPs are not independent and hence neither are the p-values. The following shows the first 5 rows and columns of the LD correlation matrix: 38 | 39 | ```r 40 | round(grid2ip.ld[1:5,1:5], digits = 3) 41 | ``` 42 | ``` 43 | rs10267908 rs112305062 rs117541653 rs11761490 rs11773436 44 | rs10267908 1.000 0.187 -0.192 -0.130 -0.389 45 | rs112305062 0.187 1.000 0.145 -0.010 -0.260 46 | rs117541653 -0.192 0.145 1.000 -0.097 0.099 47 | rs11761490 -0.130 -0.010 -0.097 1.000 -0.019 48 | rs11773436 -0.389 -0.260 0.099 -0.019 1.000 49 | ``` 50 | 51 | We can adjust the various base methods to account for the dependence using this correlation matrix. For example, we can use an estimate of the effective number of tests based on Li and Ji (2005) to adjust the test statistic of Fisher's method as a way to account for the dependence: 52 | 53 | ```{r} 54 | fisher(grid2ip.p, adjust = "liji", R = grid2ip.ld) 55 | ``` 56 | ``` 57 | combined p-values with: Fisher's method 58 | number of p-values combined: 23 59 | test statistic: 83.14 ~ chi-square(df = 30) 60 | adjustment: effective number of tests (m = 15; Li & Ji, 2005) 61 | combined p-value: 6.92e-07 62 | ``` 63 | 64 | Alternatively, we can use the generalization of Fisher's method described by Brown (1975) to combine the p-values: 65 | 66 | ```{r} 67 | fisher(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld)) 68 | ``` 69 | ``` 70 | combined p-values with: Fisher's method 71 | number of p-values combined: 23 72 | test statistic: 41.554 ~ chi-square(df = 14.994) 73 | adjustment: Brown's method 74 | combined p-value: 0.000262 75 | ``` 76 | 77 | Finally, one can empirically obtain the null distribution of Fisher's method using pseudo replicates and compute the combined p-value based on that (which closely approximates a 'proper' permutation test, but runs in a fraction of the time): 78 | 79 | ```{r} 80 | set.seed(123) 81 | fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 82 | ``` 83 | ``` 84 | combined p-values with: Fisher's method 85 | number of p-values combined: 23 86 | test statistic: 127.482 ~ chi-square(df = 46) 87 | adjustment: empirical distribution (size = 10000) 88 | combined p-value: 0.0012 (95% CI: 0.00062, 0.0021) 89 | ``` 90 | 91 | Since this method is stochastic, we manually specify the seed for the random number generator for reproducibility. 92 | 93 | The examples above cover only part of the functionality of the package. You can read the documentation of all functions [here](https://ozancinar.github.io/poolr/reference/index.html). 94 | -------------------------------------------------------------------------------- /tests/testthat/test_binomtest.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking binomtest() function") 6 | 7 | test_that("binomtest() works correctly under independence.", { 8 | 9 | res <- binomtest(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 3.763872e-09, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 11, tolerance = stat_tol) 14 | 15 | }) 16 | 17 | test_that("binomtest() works correctly with effective number of tests.", { 18 | 19 | res_nyh <- binomtest(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 20 | res_lj <- binomtest(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_gao <- binomtest(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gal <- binomtest(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_che <- binomtest(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_user <- binomtest(grid2ip.p, m = 18) 25 | 26 | out <- capture.output(print(res_nyh)) 27 | out <- capture.output(print(res_lj)) 28 | out <- capture.output(print(res_gao)) 29 | out <- capture.output(print(res_gal)) 30 | out <- capture.output(print(res_che)) 31 | out <- capture.output(print(res_user)) 32 | 33 | expect_equivalent(c(res_nyh$p), 2.057712e-09, tolerance = p_tol) 34 | expect_equivalent(c(res_nyh$statistic), 11, tolerance = stat_tol) 35 | 36 | expect_equivalent(c(res_lj$p), 2.067037e-08, tolerance = p_tol) 37 | expect_equivalent(c(res_lj$statistic), 11, tolerance = stat_tol) 38 | 39 | expect_equivalent(c(res_gao$p), 3.763872e-09, tolerance = p_tol) 40 | expect_equivalent(c(res_gao$statistic), 11, tolerance = stat_tol) 41 | 42 | expect_equivalent(c(res_gal$p), 1.134072e-08, tolerance = p_tol) 43 | expect_equivalent(c(res_gal$statistic), 11, tolerance = stat_tol) 44 | 45 | expect_equivalent(c(res_che$p), 2.057712e-09, tolerance = p_tol) 46 | expect_equivalent(c(res_che$statistic), 11, tolerance = stat_tol) 47 | 48 | expect_equivalent(c(res_user$p), 6.279596e-08, tolerance = p_tol) 49 | expect_equivalent(c(res_user$statistic), 11, tolerance = stat_tol) 50 | 51 | }) 52 | 53 | test_that("binomtest() works correctly with empirically-derived null distributions.", { 54 | 55 | set.seed(1234) 56 | res <- binomtest(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 57 | out <- capture.output(print(res)) 58 | 59 | expect_equivalent(c(res$p), 0.00059994, tolerance = p_tol * emp_sca) 60 | expect_equivalent(c(res$statistic), 11, tolerance = stat_tol * emp_sca) 61 | expect_equivalent(c(res$ci[1]), 0.0002201982, tolerance = p_tol * emp_sca) 62 | expect_equivalent(c(res$ci[2]), 0.001305356, tolerance = p_tol * emp_sca) 63 | 64 | set.seed(1234) 65 | res <- binomtest(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 66 | out <- capture.output(print(res)) 67 | 68 | expect_equivalent(c(res$p), 0.0005099949, tolerance = p_tol * emp_sca) 69 | expect_equivalent(c(res$statistic), 11, tolerance = stat_tol * emp_sca) 70 | expect_equivalent(c(res$ci[1]), 0.0003797475, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$ci[2]), 0.0006704953, tolerance = p_tol * emp_sca) 72 | 73 | set.seed(1234) 74 | res <- binomtest(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 75 | out <- capture.output(print(res)) 76 | 77 | expect_equivalent(c(res$p), 0.0004199996, tolerance = p_tol * emp_sca) 78 | expect_equivalent(c(res$statistic), 11, tolerance = stat_tol * emp_sca) 79 | expect_equivalent(c(res$ci[1]), 0.000380795, tolerance = p_tol * emp_sca) 80 | expect_equivalent(c(res$ci[2]), 0.0004621435, tolerance = p_tol * emp_sca) 81 | 82 | set.seed(1234) 83 | res <- binomtest(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 84 | out <- capture.output(print(res)) 85 | 86 | expect_equivalent(c(res$p), 0.0005099949, tolerance = p_tol * emp_sca) 87 | expect_equivalent(c(res$statistic), 11, tolerance = stat_tol * emp_sca) 88 | expect_equivalent(c(res$ci[1]), 0.0003797475, tolerance = p_tol * emp_sca) 89 | expect_equivalent(c(res$ci[2]), 0.0006704953, tolerance = p_tol * emp_sca) 90 | 91 | }) 92 | -------------------------------------------------------------------------------- /tests/testthat/test_tippett.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking tippett() function") 6 | 7 | test_that("tippett() works correctly under independence.", { 8 | 9 | res <- tippett(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 0.03810371, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol) 14 | 15 | }) 16 | 17 | test_that("tippett() works correctly with effective number of tests.", { 18 | 19 | res_nyh <- tippett(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 20 | res_lj <- tippett(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_gao <- tippett(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gal <- tippett(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_che <- tippett(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_user <- tippett(grid2ip.p, m = 18) 25 | 26 | out <- capture.output(print(res_nyh)) 27 | out <- capture.output(print(res_lj)) 28 | out <- capture.output(print(res_gao)) 29 | out <- capture.output(print(res_gal)) 30 | out <- capture.output(print(res_che)) 31 | out <- capture.output(print(res_user)) 32 | 33 | expect_equivalent(c(res_nyh$p), 0.03647763, tolerance = p_tol) 34 | expect_equivalent(c(res_nyh$statistic), 0.001687646, tolerance = stat_tol) 35 | 36 | expect_equivalent(c(res_lj$p), 0.03484879, tolerance = p_tol) 37 | expect_equivalent(c(res_lj$statistic), 0.001687646, tolerance = stat_tol) 38 | 39 | expect_equivalent(c(res_gao$p), 0.03810371, tolerance = p_tol) 40 | expect_equivalent(c(res_gao$statistic), 0.001687646, tolerance = stat_tol) 41 | 42 | expect_equivalent(c(res_gal$p), 0.03321721, tolerance = p_tol) 43 | expect_equivalent(c(res_gal$statistic), 0.001687646, tolerance = stat_tol) 44 | 45 | expect_equivalent(c(res_che$p), 0.03647763, tolerance = p_tol) 46 | expect_equivalent(c(res_che$statistic), 0.001687646, tolerance = stat_tol) 47 | 48 | expect_equivalent(c(res_user$p), 0.02994575, tolerance = p_tol) 49 | expect_equivalent(c(res_user$statistic), 0.001687646, tolerance = stat_tol) 50 | 51 | }) 52 | 53 | test_that("tippett() works correctly with empirically-derived null distributions.", { 54 | 55 | set.seed(1234) 56 | res <- tippett(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 57 | out <- capture.output(print(res)) 58 | 59 | expect_equivalent(c(res$p), 0.03229677, tolerance = p_tol * emp_sca) 60 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 61 | expect_equivalent(c(res$ci[1]), 0.02891875, tolerance = p_tol * emp_sca) 62 | expect_equivalent(c(res$ci[2]), 0.0359506, tolerance = p_tol * emp_sca) 63 | 64 | set.seed(1234) 65 | res <- tippett(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 66 | out <- capture.output(print(res)) 67 | 68 | expect_equivalent(c(res$p), 0.03065969, tolerance = p_tol * emp_sca) 69 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 70 | expect_equivalent(c(res$ci[1]), 0.02959984, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$ci[2]), 0.03174688, tolerance = p_tol * emp_sca) 72 | 73 | set.seed(1234) 74 | res <- tippett(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 75 | out <- capture.output(print(res)) 76 | 77 | expect_equivalent(c(res$p), 0.03024897, tolerance = p_tol * emp_sca) 78 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 79 | expect_equivalent(c(res$ci[1]), 0.02991414, tolerance = p_tol * emp_sca) 80 | expect_equivalent(c(res$ci[2]), 0.03058652, tolerance = p_tol * emp_sca) 81 | 82 | set.seed(1234) 83 | res <- tippett(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 84 | out <- capture.output(print(res)) 85 | 86 | expect_equivalent(c(res$p), 0.03139686, tolerance = p_tol * emp_sca) 87 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 88 | expect_equivalent(c(res$ci[1]), 0.02806613, tolerance = p_tol * emp_sca) 89 | expect_equivalent(c(res$ci[2]), 0.035004, tolerance = p_tol * emp_sca) 90 | 91 | }) 92 | -------------------------------------------------------------------------------- /tests/testthat/test_bonferroni.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking bonferroni() function") 6 | 7 | test_that("bonferroni() works correctly under independence.", { 8 | 9 | res <- bonferroni(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 0.03881585, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol) 14 | 15 | }) 16 | 17 | test_that("bonferroni() works correctly with effective number of tests.", { 18 | 19 | res_nyh <- bonferroni(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 20 | res_lj <- bonferroni(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_gao <- bonferroni(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gal <- bonferroni(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_che <- bonferroni(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_user <- bonferroni(grid2ip.p, m = 18) 25 | 26 | out <- capture.output(print(res_nyh)) 27 | out <- capture.output(print(res_lj)) 28 | out <- capture.output(print(res_gao)) 29 | out <- capture.output(print(res_gal)) 30 | out <- capture.output(print(res_che)) 31 | out <- capture.output(print(res_user)) 32 | 33 | expect_equivalent(c(res_nyh$p), 0.0371282, tolerance = p_tol) 34 | expect_equivalent(c(res_nyh$statistic), 0.001687646, tolerance = stat_tol) 35 | 36 | expect_equivalent(c(res_lj$p), 0.03544056, tolerance = p_tol) 37 | expect_equivalent(c(res_lj$statistic), 0.001687646, tolerance = stat_tol) 38 | 39 | expect_equivalent(c(res_gao$p), 0.03881585, tolerance = p_tol) 40 | expect_equivalent(c(res_gao$statistic), 0.001687646, tolerance = stat_tol) 41 | 42 | expect_equivalent(c(res_gal$p), 0.03375291, tolerance = p_tol) 43 | expect_equivalent(c(res_gal$statistic), 0.001687646, tolerance = stat_tol) 44 | 45 | expect_equivalent(c(res_che$p), 0.0371282, tolerance = p_tol) 46 | expect_equivalent(c(res_che$statistic), 0.001687646, tolerance = stat_tol) 47 | 48 | expect_equivalent(c(res_user$p), 0.03037762, tolerance = p_tol) 49 | expect_equivalent(c(res_user$statistic), 0.001687646, tolerance = stat_tol) 50 | 51 | }) 52 | 53 | test_that("bonferroni() works correctly with empirically-derived null distributions.", { 54 | 55 | set.seed(1234) 56 | res <- bonferroni(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 57 | out <- capture.output(print(res)) 58 | 59 | expect_equivalent(c(res$p), 0.03229677, tolerance = p_tol * emp_sca) 60 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 61 | expect_equivalent(c(res$ci[1]), 0.02891875, tolerance = p_tol * emp_sca) 62 | expect_equivalent(c(res$ci[2]), 0.0359506, tolerance = p_tol * emp_sca) 63 | 64 | set.seed(1234) 65 | res <- bonferroni(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 66 | out <- capture.output(print(res)) 67 | 68 | expect_equivalent(c(res$p), 0.03065969, tolerance = p_tol * emp_sca) 69 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 70 | expect_equivalent(c(res$ci[1]), 0.02959984, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$ci[2]), 0.03174688, tolerance = p_tol * emp_sca) 72 | 73 | set.seed(1234) 74 | res <- bonferroni(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 75 | out <- capture.output(print(res)) 76 | 77 | expect_equivalent(c(res$p), 0.03024897, tolerance = p_tol * emp_sca) 78 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 79 | expect_equivalent(c(res$ci[1]), 0.02991414, tolerance = p_tol * emp_sca) 80 | expect_equivalent(c(res$ci[2]), 0.03058652, tolerance = p_tol * emp_sca) 81 | 82 | set.seed(1234) 83 | res <- bonferroni(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 84 | out <- capture.output(print(res)) 85 | 86 | expect_equivalent(c(res$p), 0.03139686, tolerance = p_tol * emp_sca) 87 | expect_equivalent(c(res$statistic), 0.001687646, tolerance = stat_tol * emp_sca) 88 | expect_equivalent(c(res$ci[1]), 0.02806613, tolerance = p_tol * emp_sca) 89 | expect_equivalent(c(res$ci[2]), 0.035004, tolerance = p_tol * emp_sca) 90 | 91 | }) 92 | -------------------------------------------------------------------------------- /man/empirical.Rd: -------------------------------------------------------------------------------- 1 | \name{empirical} 2 | \alias{empirical} 3 | \title{Simulate Empirically-Derived Null Distributions} 4 | \description{Function to simulate empirically-derived null distributions of various methods for combining \mjseqn{p}-values using pseudo replicates.\loadmathjax} 5 | \usage{ 6 | empirical(R, method, side = 2, size = 10000, batchsize, \dots) 7 | } 8 | \arguments{ 9 | \item{R}{a \mjeqn{k \times k}{k * k} symmetric matrix that contains the correlations among the test statistics.} 10 | \item{method}{character string to specify for which method to simulate the null distribution (either \code{"fisher"}, \code{"stouffer"}, \code{"invchisq"}, \code{"binomtest"}, \code{"bonferroni"}, or \code{"tippett"}).} 11 | \item{side}{scalar to specify the sidedness of the \mjseqn{p}-values that are used to simulate the null distribution (2, by default, for two-sided tests; 1 for one-sided tests).} 12 | \item{size}{size of the empirically-derived null distribution that should be generated.} 13 | \item{batchsize}{optional scalar to specify the batch size for generating the null distribution. When unspecified (the default), this is done in a single batch.} 14 | \item{\dots}{other arguments.} 15 | } 16 | \details{ 17 | 18 | This function simulates the null distribution of a particular method for combining \mjseqn{p}-values when the test statistics that generate the \mjseqn{p}-values to be combined can be assumed to follow a multivariate normal distribution and a matrix is available that reflects the correlations among the test statistics (which is specified via the \code{R} argument). In this case, test statistics are repeatedly simulated from a multivariate normal distribution under the joint null hypothesis, converted into one- or two-sided \mjseqn{p}-values (depending on the \code{side} argument), and the chosen method is applied. Repeating this process \code{size} times yields the null distribution. 19 | 20 | If \code{batchsize} is unspecified, the null distribution is simulated in a single batch, which requires temporarily storing a matrix with dimensions \code{[size,k]}. When \code{size*k} is large, allocating the memory for this matrix might not be possible. Instead, one can specify a \code{batchsize} value, in which case a matrix with dimensions \code{[batchsize,k]} is repeatedly simulated until the desired size of the null distribution has been obtained. 21 | 22 | } 23 | \value{ 24 | A vector of combined \mjseqn{p}-values as simulated under the joint null hypothesis for a given method. 25 | } 26 | \note{ 27 | The \code{R} matrix must be positive definite. If it is not, the function uses \code{\link[Matrix]{nearPD}} to find the nearest positive definite matrix (Higham, 2002) before simulating the null distribution. 28 | } 29 | \author{ 30 | Ozan Cinar \email{ozancinar86@gmail.com} \cr 31 | Wolfgang Viechtbauer \email{wvb@wvbauer.com} \cr 32 | } 33 | \references{ 34 | Cinar, O. & Viechtbauer, W. (2022). The poolr package for combining independent and dependent p values. \emph{Journal of Statistical Software}, \bold{101}(1), 1--42. \verb{https://doi.org/10.18637/jss.v101.i01} 35 | 36 | Higham, N. J. (2002). Computing the nearest correlation matrix: A problem from finance. \emph{IMA Journal of Numerical Analysis, 22}(3), 329--343. \verb{https://doi.org/10.1093/imanum/22.3.329} 37 | } 38 | \examples{ 39 | # create an example correlation matrix with constant positive correlations 40 | R <- matrix(0.6, nrow = 10, ncol = 10) 41 | diag(R) <- 1 42 | 43 | # generate null distribution for Fisher's method (setting the seed for reproducibility) 44 | set.seed(1234) 45 | psim <- empirical(R, method = "fisher") 46 | 47 | # Fisher's method is liberal in this scenario (i.e., its actual Type I error 48 | # rate is around .14 instead of the nominal significance level of .05) 49 | mean(psim <= .05) 50 | 51 | # estimate the actual Type I error rate of the other methods in this scenario 52 | psim <- empirical(R, method = "stouffer") 53 | mean(psim <= .05) 54 | psim <- empirical(R, method = "invchisq") 55 | mean(psim <= .05) 56 | psim <- empirical(R, method = "binomtest") 57 | mean(psim <= .05) 58 | psim <- empirical(R, method = "bonferroni") 59 | mean(psim <= .05) 60 | psim <- empirical(R, method = "tippett") 61 | mean(psim <= .05) 62 | 63 | # Stouffer's and the inverse chi-square method also have clearly inflated 64 | # Type I error rates and the binomial test just barely. As expected, the 65 | # Bonferroni method is overly conservative and so is Tippett's method. 66 | } 67 | \keyword{htest} 68 | -------------------------------------------------------------------------------- /man/mvnconv.Rd: -------------------------------------------------------------------------------- 1 | \name{mvnconv} 2 | \alias{mvnconv} 3 | \title{Convert Correlations Among Multivariate Normal Test Statistics to Covariances for Various Target Statistics} 4 | \description{Function to convert a matrix with the correlations among multivariate normal test statistics to a matrix with the covariances among various target statistics.\loadmathjax} 5 | \usage{ 6 | mvnconv(R, side = 2, target, cov2cor = FALSE) 7 | } 8 | \arguments{ 9 | \item{R}{a \mjeqn{k \times k}{k * k} symmetric matrix that contains the correlations among the test statistics.} 10 | \item{side}{scalar to specify the sidedness of the \mjseqn{p}-values that are obtained from the test statistics (2, by default, for two-sided tests; 1 for one-sided tests).} 11 | \item{target}{the target statistic for which the covariances are calculated (either \code{"p"}, \code{"m2lp"}, \code{"chisq1"}, or \code{"z"}). See \sQuote{Details}.} 12 | \item{cov2cor}{logical to indicate whether to convert the covariance matrix to a correlation matrix (default is \code{FALSE}).} 13 | } 14 | \details{ 15 | 16 | The function converts a matrix with the correlations among multivariate normal test statistics to a matrix with the covariances among various target statistics. In particular, assume \mjtdeqn{\left[\begin{array}{c} t_i \\\\ t_j \end{array}\right] \sim \mbox{MVN} \left(\left[\begin{array}{c} 0 \\\\ 0 \end{array}\right], \left[\begin{array}{cc} 1 & \rho_{ij} \\\\ \rho_{ij} & 1 \end{array}\right] \right)}{\begin{bmatrix} t_i \\\\\ t_j \end{bmatrix} \sim \mbox{MVN} \left(\begin{bmatrix} 0 \\\\\ 0 \end{bmatrix}, \begin{bmatrix} 1 & \rho_{ij} \\\\\ \rho_{ij} & 1 \end{bmatrix} \right)}{[t_i, t_j]' ~ MVN([0,0]', [1, rho_ij | rho_ij, 1])} is the joint distribution for test statistics \mjseqn{t_i} and \mjseqn{t_j}. For \code{side = 1}, let \mjeqn{p_i = 1 - \Phi(t_i)}{p_i = 1 - Phi(t_i)} and \mjeqn{p_j = 1 - \Phi(t_j)}{p_j = 1 - Phi(t_j)} where \mjeqn{\Phi(\cdot)}{Phi(.)} denotes the cumulative distribution function of a standard normal distribution. For \code{side = 2}, let \mjeqn{p_i = 2(1 - \Phi(|t_i|))}{p_i = 2(1 - Phi(|t_i|))} and \mjeqn{p_j = 2(1 - \Phi(|t_j|))}{p_j = 2(1 - Phi(|t_j|))}. These are simply the one- and two-sided \mjseqn{p}-values corresponding to \mjseqn{t_i} and \mjseqn{t_j}. 17 | 18 | If \code{target = "p"}, the function computes \mjeqn{\mbox{Cov}[p_i, p_j]}{Cov[p_i, p_j]}. 19 | 20 | If \code{target = "m2lp"}, the function computes \mjeqn{\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]}{Cov[-2 ln(p_i), -2 ln(p_j)]}. 21 | 22 | If \code{target = "chisq1"}, the function computes \mjeqn{\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}{Cov[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]}, where \mjeqn{F^{-1}(\cdot,1)}{F^{-1}(.,1)} denotes the inverse of the cumulative distribution function of a chi-square distribution with one degree of freedom. 23 | 24 | If \code{target = "z"}, the function computes \mjeqn{\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]}{Cov[Phi^{-1}(1 - p_i), Phi^{-1}(1 - p_j)]}, where \mjeqn{\Phi^{-1}(\cdot)}{Phi^{-1}(.)} denotes the inverse of the cumulative distribution function of a standard normal distribution. 25 | 26 | } 27 | \value{ 28 | The function returns the covariance matrix (or the correlation matrix if \code{cov2cor = TRUE}). 29 | } 30 | \note{ 31 | Since computation of the covariances requires numerical integration, the function doesn't actually compute these covariances on the fly. Instead, it uses the \code{\link{mvnlookup}} lookup table, which contains the covariances. 32 | } 33 | \author{ 34 | Ozan Cinar \email{ozancinar86@gmail.com} \cr 35 | Wolfgang Viechtbauer \email{wvb@wvbauer.com} \cr 36 | } 37 | \references{ 38 | Cinar, O. & Viechtbauer, W. (2022). The poolr package for combining independent and dependent p values. \emph{Journal of Statistical Software}, \bold{101}(1), 1--42. \verb{https://doi.org/10.18637/jss.v101.i01} 39 | } 40 | \examples{ 41 | # illustrative correlation matrix 42 | R <- matrix(c( 1, 0.8, 0.5, 0.3, 43 | 0.8, 1, 0.2, 0.4, 44 | 0.5, 0.2, 1, 0.7, 45 | 0.3, 0.4, 0.7, 1), nrow = 4, ncol = 4) 46 | 47 | # convert R into covariance matrices for the chosen targets 48 | mvnconv(R, target = "p") 49 | mvnconv(R, target = "m2lp") 50 | mvnconv(R, target = "chisq1") 51 | mvnconv(R, target = "z") 52 | 53 | # convert R into correlation matrices for the chosen targets 54 | mvnconv(R, target = "p", cov2cor = TRUE) 55 | mvnconv(R, target = "m2lp", cov2cor = TRUE) 56 | mvnconv(R, target = "chisq1", cov2cor = TRUE) 57 | mvnconv(R, target = "z", cov2cor = TRUE) 58 | } 59 | \keyword{htest} 60 | -------------------------------------------------------------------------------- /tests/testthat/test_stouffer.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking stouffer() function") 6 | 7 | test_that("stouffer() works correctly under independence.", { 8 | 9 | res <- stouffer(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 1.655433e-09, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 5.915392, tolerance = stat_tol) 14 | 15 | }) 16 | 17 | test_that("stouffer() works correctly with effective number of tests.", { 18 | 19 | res_nyh <- stouffer(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 20 | res_lj <- stouffer(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_gao <- stouffer(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gal <- stouffer(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_che <- stouffer(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_user <- stouffer(grid2ip.p, m = 18) 25 | 26 | out <- capture.output(print(res_nyh)) 27 | out <- capture.output(print(res_lj)) 28 | out <- capture.output(print(res_gao)) 29 | out <- capture.output(print(res_gal)) 30 | out <- capture.output(print(res_che)) 31 | out <- capture.output(print(res_user)) 32 | 33 | expect_equivalent(c(res_nyh$p), 3.617704e-09, tolerance = p_tol) 34 | expect_equivalent(c(res_nyh$statistic), 5.785367, tolerance = stat_tol) 35 | 36 | expect_equivalent(c(res_lj$p), 7.913328e-09, tolerance = p_tol) 37 | expect_equivalent(c(res_lj$statistic), 5.652353, tolerance = stat_tol) 38 | 39 | expect_equivalent(c(res_gao$p), 1.655433e-09, tolerance = p_tol) 40 | expect_equivalent(c(res_gao$statistic), 5.915392, tolerance = stat_tol) 41 | 42 | expect_equivalent(c(res_gal$p), 1.732717e-08, tolerance = p_tol) 43 | expect_equivalent(c(res_gal$statistic), 5.516131, tolerance = stat_tol) 44 | 45 | expect_equivalent(c(res_che$p), 3.617704e-09, tolerance = p_tol) 46 | expect_equivalent(c(res_che$statistic), 5.785367, tolerance = stat_tol) 47 | 48 | expect_equivalent(c(res_user$p), 8.336258e-08, tolerance = p_tol) 49 | expect_equivalent(c(res_user$statistic), 5.233062, tolerance = stat_tol) 50 | 51 | }) 52 | 53 | test_that("stouffer() works correctly with empirically-derived null distributions.", { 54 | 55 | set.seed(1234) 56 | res <- stouffer(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 57 | out <- capture.output(print(res)) 58 | 59 | expect_equivalent(c(res$p), 0.00049995, tolerance = p_tol * emp_sca) 60 | expect_equivalent(c(res$statistic), 5.915392, tolerance = stat_tol * emp_sca) 61 | expect_equivalent(c(res$ci[1]), 0.0001623517, tolerance = p_tol * emp_sca) 62 | expect_equivalent(c(res$ci[2]), 0.001166328, tolerance = p_tol * emp_sca) 63 | 64 | set.seed(1234) 65 | res <- stouffer(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 66 | out <- capture.output(print(res)) 67 | 68 | expect_equivalent(c(res$p), 0.0007599924, tolerance = p_tol * emp_sca) 69 | expect_equivalent(c(res$statistic), 5.915392, tolerance = stat_tol * emp_sca) 70 | expect_equivalent(c(res$ci[1]), 0.0005988329, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$ci[2]), 0.0009511528, tolerance = p_tol * emp_sca) 72 | 73 | set.seed(1234) 74 | res <- stouffer(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 75 | out <- capture.output(print(res)) 76 | 77 | expect_equivalent(c(res$p), 0.0007119993, tolerance = p_tol * emp_sca) 78 | expect_equivalent(c(res$statistic), 5.915392, tolerance = stat_tol * emp_sca) 79 | expect_equivalent(c(res$ci[1]), 0.0006625978, tolerance = p_tol * emp_sca) 80 | expect_equivalent(c(res$ci[2]), 0.0007683274, tolerance = p_tol * emp_sca) 81 | 82 | set.seed(1234) 83 | res <- stouffer(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 84 | out <- capture.output(print(res)) 85 | 86 | expect_equivalent(c(res$p), 0.0007899921, tolerance = p_tol * emp_sca) 87 | expect_equivalent(c(res$statistic), 5.915392, tolerance = stat_tol * emp_sca) 88 | expect_equivalent(c(res$ci[1]), 0.0006254925, tolerance = p_tol * emp_sca) 89 | expect_equivalent(c(res$ci[2]), 0.0009844701, tolerance = p_tol * emp_sca) 90 | 91 | }) 92 | 93 | test_that("stouffer() works correctly under multivariate theory.", { 94 | 95 | res1 <- stouffer(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 1)) 96 | out <- capture.output(print(res1)) 97 | 98 | expect_equivalent(c(res1$p), 1.67123e-06, tolerance = p_tol) 99 | expect_equivalent(c(res1$statistic), 4.648569, tolerance = stat_tol) 100 | 101 | res2 <- stouffer(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 2)) 102 | out <- capture.output(print(res2)) 103 | 104 | expect_equivalent(c(res2$p), 0.000112044, tolerance = p_tol) 105 | expect_equivalent(c(res2$statistic), 3.690188, tolerance = stat_tol) 106 | 107 | }) 108 | -------------------------------------------------------------------------------- /docs/404.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | Page not found (404) • poolr 9 | 10 | 11 | 12 | 13 | 14 | 15 | 19 | 20 | 21 | 22 | 23 |
    24 |
    63 | 64 | 65 | 66 | 67 |
    68 |
    69 |
    70 |

    Page not found (404)

    71 |
    72 | 73 | Content not found. Please use links in the navbar. 74 | 75 |
    76 | 77 | 81 | 82 |
    83 | 84 | 85 | 86 |
    87 |

    88 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    89 |
    90 | 91 |
    92 |

    93 |

    Site built with pkgdown 2.2.0.

    94 |
    95 | 96 |
    97 |
    98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /docs/bootstrap-toc.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * Bootstrap Table of Contents v0.4.1 (http://afeld.github.io/bootstrap-toc/) 3 | * Copyright 2015 Aidan Feldman 4 | * Licensed under MIT (https://github.com/afeld/bootstrap-toc/blob/gh-pages/LICENSE.md) */ 5 | (function() { 6 | 'use strict'; 7 | 8 | window.Toc = { 9 | helpers: { 10 | // return all matching elements in the set, or their descendants 11 | findOrFilter: function($el, selector) { 12 | // http://danielnouri.org/notes/2011/03/14/a-jquery-find-that-also-finds-the-root-element/ 13 | // http://stackoverflow.com/a/12731439/358804 14 | var $descendants = $el.find(selector); 15 | return $el.filter(selector).add($descendants).filter(':not([data-toc-skip])'); 16 | }, 17 | 18 | generateUniqueIdBase: function(el) { 19 | var text = $(el).text(); 20 | var anchor = text.trim().toLowerCase().replace(/[^A-Za-z0-9]+/g, '-'); 21 | return anchor || el.tagName.toLowerCase(); 22 | }, 23 | 24 | generateUniqueId: function(el) { 25 | var anchorBase = this.generateUniqueIdBase(el); 26 | for (var i = 0; ; i++) { 27 | var anchor = anchorBase; 28 | if (i > 0) { 29 | // add suffix 30 | anchor += '-' + i; 31 | } 32 | // check if ID already exists 33 | if (!document.getElementById(anchor)) { 34 | return anchor; 35 | } 36 | } 37 | }, 38 | 39 | generateAnchor: function(el) { 40 | if (el.id) { 41 | return el.id; 42 | } else { 43 | var anchor = this.generateUniqueId(el); 44 | el.id = anchor; 45 | return anchor; 46 | } 47 | }, 48 | 49 | createNavList: function() { 50 | return $(''); 51 | }, 52 | 53 | createChildNavList: function($parent) { 54 | var $childList = this.createNavList(); 55 | $parent.append($childList); 56 | return $childList; 57 | }, 58 | 59 | generateNavEl: function(anchor, text) { 60 | var $a = $(''); 61 | $a.attr('href', '#' + anchor); 62 | $a.text(text); 63 | var $li = $('
  • '); 64 | $li.append($a); 65 | return $li; 66 | }, 67 | 68 | generateNavItem: function(headingEl) { 69 | var anchor = this.generateAnchor(headingEl); 70 | var $heading = $(headingEl); 71 | var text = $heading.data('toc-text') || $heading.text(); 72 | return this.generateNavEl(anchor, text); 73 | }, 74 | 75 | // Find the first heading level (`

    `, then `

    `, etc.) that has more than one element. Defaults to 1 (for `

    `). 76 | getTopLevel: function($scope) { 77 | for (var i = 1; i <= 6; i++) { 78 | var $headings = this.findOrFilter($scope, 'h' + i); 79 | if ($headings.length > 1) { 80 | return i; 81 | } 82 | } 83 | 84 | return 1; 85 | }, 86 | 87 | // returns the elements for the top level, and the next below it 88 | getHeadings: function($scope, topLevel) { 89 | var topSelector = 'h' + topLevel; 90 | 91 | var secondaryLevel = topLevel + 1; 92 | var secondarySelector = 'h' + secondaryLevel; 93 | 94 | return this.findOrFilter($scope, topSelector + ',' + secondarySelector); 95 | }, 96 | 97 | getNavLevel: function(el) { 98 | return parseInt(el.tagName.charAt(1), 10); 99 | }, 100 | 101 | populateNav: function($topContext, topLevel, $headings) { 102 | var $context = $topContext; 103 | var $prevNav; 104 | 105 | var helpers = this; 106 | $headings.each(function(i, el) { 107 | var $newNav = helpers.generateNavItem(el); 108 | var navLevel = helpers.getNavLevel(el); 109 | 110 | // determine the proper $context 111 | if (navLevel === topLevel) { 112 | // use top level 113 | $context = $topContext; 114 | } else if ($prevNav && $context === $topContext) { 115 | // create a new level of the tree and switch to it 116 | $context = helpers.createChildNavList($prevNav); 117 | } // else use the current $context 118 | 119 | $context.append($newNav); 120 | 121 | $prevNav = $newNav; 122 | }); 123 | }, 124 | 125 | parseOps: function(arg) { 126 | var opts; 127 | if (arg.jquery) { 128 | opts = { 129 | $nav: arg 130 | }; 131 | } else { 132 | opts = arg; 133 | } 134 | opts.$scope = opts.$scope || $(document.body); 135 | return opts; 136 | } 137 | }, 138 | 139 | // accepts a jQuery object, or an options object 140 | init: function(opts) { 141 | opts = this.helpers.parseOps(opts); 142 | 143 | // ensure that the data attribute is in place for styling 144 | opts.$nav.attr('data-toggle', 'toc'); 145 | 146 | var $topContext = this.helpers.createChildNavList(opts.$nav); 147 | var topLevel = this.helpers.getTopLevel(opts.$scope); 148 | var $headings = this.helpers.getHeadings(opts.$scope, topLevel); 149 | this.helpers.populateNav($topContext, topLevel, $headings); 150 | } 151 | }; 152 | 153 | $(function() { 154 | $('nav[data-toggle="toc"]').each(function(i, el) { 155 | var $nav = $(el); 156 | Toc.init($nav); 157 | }); 158 | }); 159 | })(); 160 | -------------------------------------------------------------------------------- /tests/testthat/test_fisher.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking fisher() function") 6 | 7 | test_that("fisher() works correctly under independence.", { 8 | 9 | res <- fisher(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 1.389547e-09, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 127.4818, tolerance = stat_tol) 14 | expect_equivalent(attributes(res$statistic)$df, 46, tolerance = df_tol) 15 | 16 | }) 17 | 18 | test_that("fisher() works correctly with effective number of tests.", { 19 | 20 | res_nyh <- fisher(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_lj <- fisher(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gao <- fisher(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_gal <- fisher(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_che <- fisher(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 25 | res_user <- fisher(grid2ip.p, m = 18) 26 | 27 | out <- capture.output(print(res_nyh)) 28 | out <- capture.output(print(res_lj)) 29 | out <- capture.output(print(res_gao)) 30 | out <- capture.output(print(res_gal)) 31 | out <- capture.output(print(res_che)) 32 | out <- capture.output(print(res_user)) 33 | 34 | expect_equivalent(c(res_nyh$p), 3.008722e-09, tolerance = p_tol) 35 | expect_equivalent(c(res_nyh$statistic), 121.9391, tolerance = stat_tol) 36 | 37 | expect_equivalent(c(res_lj$p), 6.52039e-09, tolerance = p_tol) 38 | expect_equivalent(c(res_lj$statistic), 116.3964, tolerance = stat_tol) 39 | 40 | expect_equivalent(c(res_gao$p), 1.389547e-09, tolerance = p_tol) 41 | expect_equivalent(c(res_gao$statistic), 127.4818, tolerance = stat_tol) 42 | 43 | expect_equivalent(c(res_gal$p), 1.414432e-08, tolerance = p_tol) 44 | expect_equivalent(c(res_gal$statistic), 110.8537, tolerance = stat_tol) 45 | 46 | expect_equivalent(c(res_che$p), 3.008722e-09, tolerance = p_tol) 47 | expect_equivalent(c(res_che$statistic), 121.9391, tolerance = stat_tol) 48 | 49 | expect_equivalent(c(res_user$p), 6.677494e-08, tolerance = p_tol) 50 | expect_equivalent(c(res_user$statistic), 99.76835, tolerance = stat_tol) 51 | 52 | }) 53 | 54 | test_that("fisher() works correctly with empirically-derived null distributions.", { 55 | 56 | set.seed(1234) 57 | res <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 58 | out <- capture.output(print(res)) 59 | 60 | expect_equivalent(c(res$p), 0.00049995, tolerance = p_tol * emp_sca) 61 | expect_equivalent(c(res$statistic), 127.4818, tolerance = stat_tol * emp_sca) 62 | expect_equivalent(c(res$ci[1]), 0.0001623517, tolerance = p_tol * emp_sca) 63 | expect_equivalent(c(res$ci[2]), 0.001166328, tolerance = p_tol * emp_sca) 64 | expect_equivalent(attributes(res$statistic)$df, 46, tolerance = df_tol) 65 | 66 | set.seed(1234) 67 | res <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 68 | out <- capture.output(print(res)) 69 | 70 | expect_equivalent(c(res$p), 0.00101999, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$statistic), 127.4818, tolerance = stat_tol * emp_sca) 72 | expect_equivalent(c(res$ci[1]), 0.000831754, tolerance = p_tol * emp_sca) 73 | expect_equivalent(c(res$ci[2]), 0.001238063, tolerance = p_tol * emp_sca) 74 | expect_equivalent(attributes(res$statistic)$df, 46, tolerance = df_tol) 75 | 76 | set.seed(1234) 77 | res <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 78 | out <- capture.output(print(res)) 79 | 80 | expect_equivalent(c(res$p), 0.000972999, tolerance = p_tol * emp_sca) 81 | expect_equivalent(c(res$statistic), 127.4818, tolerance = stat_tol * emp_sca) 82 | expect_equivalent(c(res$ci[1]), 0.0009128416, tolerance = p_tol * emp_sca) 83 | expect_equivalent(c(res$ci[2]), 0.001036076, tolerance = p_tol * emp_sca) 84 | expect_equivalent(attributes(res$statistic)$df, 46, tolerance = df_tol) 85 | 86 | set.seed(1234) 87 | res <- fisher(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 88 | out <- capture.output(print(res)) 89 | 90 | expect_equivalent(c(res$p), 0.00104999, tolerance = p_tol * emp_sca) 91 | expect_equivalent(c(res$statistic), 127.4818, tolerance = stat_tol * emp_sca) 92 | expect_equivalent(c(res$ci[1]), 0.0008588652, tolerance = p_tol * emp_sca) 93 | expect_equivalent(c(res$ci[2]), 0.001270936, tolerance = p_tol * emp_sca) 94 | expect_equivalent(attributes(res$statistic)$df, 46, tolerance = df_tol) 95 | 96 | }) 97 | 98 | test_that("fisher() works correctly under multivariate theory.", { 99 | 100 | res1 <- fisher(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 1)) 101 | out <- capture.output(print(res1)) 102 | 103 | expect_equivalent(c(res1$p), 6.063446e-06, tolerance = p_tol) 104 | expect_equivalent(c(res1$statistic), 67.80295, tolerance = stat_tol) 105 | expect_equivalent(attributes(res1$statistic)$df, 24.46574, tolerance = df_tol) 106 | 107 | res2 <- fisher(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 2)) 108 | out <- capture.output(print(res2)) 109 | 110 | expect_equivalent(c(res2$p), 0.0002622587, tolerance = p_tol) 111 | expect_equivalent(c(res2$statistic), 41.55411, tolerance = stat_tol) 112 | expect_equivalent(attributes(res2$statistic)$df, 14.99421, tolerance = df_tol) 113 | 114 | }) 115 | -------------------------------------------------------------------------------- /tests/testthat/test_invchisq.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | context("Checking invchisq() function") 6 | 7 | test_that("invchisq() works correctly under independence.", { 8 | 9 | res <- invchisq(grid2ip.p) 10 | out <- capture.output(print(res)) 11 | 12 | expect_equivalent(c(res$p), 4.447048e-09, tolerance = p_tol) 13 | expect_equivalent(c(res$statistic), 85.21864, tolerance = stat_tol) 14 | expect_equivalent(attributes(res$statistic)$df, 23, tolerance = df_tol) 15 | 16 | }) 17 | 18 | test_that("invchisq() works correctly with effective number of tests.", { 19 | 20 | res_nyh <- invchisq(grid2ip.p, adjust = "nyholt", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 21 | res_lj <- invchisq(grid2ip.p, adjust = "liji", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 22 | res_gao <- invchisq(grid2ip.p, adjust = "gao", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 23 | res_gal <- invchisq(grid2ip.p, adjust = "galwey", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 24 | res_che <- invchisq(grid2ip.p, adjust = "chen", R = mvnconv(grid2ip.ld, target = "p", cov2cor = TRUE)) 25 | res_user <- invchisq(grid2ip.p, m = 18) 26 | 27 | out <- capture.output(print(res_nyh)) 28 | out <- capture.output(print(res_lj)) 29 | out <- capture.output(print(res_gao)) 30 | out <- capture.output(print(res_gal)) 31 | out <- capture.output(print(res_che)) 32 | out <- capture.output(print(res_user)) 33 | 34 | expect_equivalent(c(res_nyh$p), 9.116737e-09, tolerance = p_tol) 35 | expect_equivalent(c(res_nyh$statistic), 81.51348, tolerance = stat_tol) 36 | 37 | expect_equivalent(c(res_lj$p), 1.870575e-08, tolerance = p_tol) 38 | expect_equivalent(c(res_lj$statistic), 77.80832, tolerance = stat_tol) 39 | 40 | expect_equivalent(c(res_gao$p), 4.447048e-09, tolerance = p_tol) 41 | expect_equivalent(c(res_gao$statistic), 85.21864, tolerance = stat_tol) 42 | 43 | expect_equivalent(c(res_gal$p), 3.841594e-08, tolerance = p_tol) 44 | expect_equivalent(c(res_gal$statistic), 74.10316, tolerance = stat_tol) 45 | 46 | expect_equivalent(c(res_che$p), 9.116737e-09, tolerance = p_tol) 47 | expect_equivalent(c(res_che$statistic), 81.51348, tolerance = stat_tol) 48 | 49 | expect_equivalent(c(res_user$p), 1.625318e-07, tolerance = p_tol) 50 | expect_equivalent(c(res_user$statistic), 66.69285, tolerance = stat_tol) 51 | 52 | }) 53 | 54 | test_that("invchisq() works correctly with empirically-derived null distributions.", { 55 | 56 | set.seed(1234) 57 | res <- invchisq(grid2ip.p, adjust = "empirical", R = grid2ip.ld) 58 | out <- capture.output(print(res)) 59 | 60 | expect_equivalent(c(res$p), 0.00069993, tolerance = p_tol * emp_sca) 61 | expect_equivalent(c(res$statistic), 85.21864, tolerance = stat_tol * emp_sca) 62 | expect_equivalent(c(res$ci[1]), 0.000281453, tolerance = p_tol * emp_sca) 63 | expect_equivalent(c(res$ci[2]), 0.001441588, tolerance = p_tol * emp_sca) 64 | expect_equivalent(attributes(res$statistic)$df, 23, tolerance = df_tol) 65 | 66 | set.seed(1234) 67 | res <- invchisq(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 100000) 68 | out <- capture.output(print(res)) 69 | 70 | expect_equivalent(c(res$p), 0.001209988, tolerance = p_tol * emp_sca) 71 | expect_equivalent(c(res$statistic), 85.21864, tolerance = stat_tol * emp_sca) 72 | expect_equivalent(c(res$ci[1]), 0.001004114, tolerance = p_tol * emp_sca) 73 | expect_equivalent(c(res$ci[2]), 0.001445611, tolerance = p_tol * emp_sca) 74 | expect_equivalent(attributes(res$statistic)$df, 23, tolerance = df_tol) 75 | 76 | set.seed(1234) 77 | res <- invchisq(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = 1000000, batchsize = 1000) 78 | out <- capture.output(print(res)) 79 | 80 | expect_equivalent(c(res$p), 0.001142999, tolerance = p_tol * emp_sca) 81 | expect_equivalent(c(res$statistic), 85.21864, tolerance = stat_tol * emp_sca) 82 | expect_equivalent(c(res$ci[1]), 0.001077723, tolerance = p_tol * emp_sca) 83 | expect_equivalent(c(res$ci[2]), 0.001211191, tolerance = p_tol * emp_sca) 84 | expect_equivalent(attributes(res$statistic)$df, 23, tolerance = df_tol) 85 | 86 | set.seed(1234) 87 | res <- invchisq(grid2ip.p, adjust = "empirical", R = grid2ip.ld, size = c(1000, 10000, 100000), threshold = c(0.10, 0.01)) 88 | out <- capture.output(print(res)) 89 | 90 | expect_equivalent(c(res$p), 0.001229988, tolerance = p_tol * emp_sca) 91 | expect_equivalent(c(res$statistic), 85.21864, tolerance = stat_tol * emp_sca) 92 | expect_equivalent(c(res$ci[1]), 0.001022341, tolerance = p_tol * emp_sca) 93 | expect_equivalent(c(res$ci[2]), 0.001467375, tolerance = p_tol * emp_sca) 94 | expect_equivalent(attributes(res$statistic)$df, 23, tolerance = df_tol) 95 | 96 | }) 97 | 98 | test_that("invchisq() works correctly under multivariate theory.", { 99 | 100 | res1 <- invchisq(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 1)) 101 | out <- capture.output(print(res1)) 102 | 103 | expect_equivalent(c(res1$p), 2.044974e-05, tolerance = p_tol) 104 | expect_equivalent(c(res1$statistic), 42.07063, tolerance = stat_tol) 105 | expect_equivalent(attributes(res1$statistic)$df, 11.35461, tolerance = df_tol) 106 | 107 | res2 <- invchisq(grid2ip.p, adjust = "generalized", R = mvnconv(grid2ip.ld, side = 2)) 108 | out <- capture.output(print(res2)) 109 | 110 | expect_equivalent(c(res2$p), 0.0003806222, tolerance = p_tol) 111 | expect_equivalent(c(res2$statistic), 27.44923, tolerance = stat_tol) 112 | expect_equivalent(attributes(res2$statistic)$df, 7.408383, tolerance = df_tol) 113 | 114 | }) 115 | -------------------------------------------------------------------------------- /docs/authors.html: -------------------------------------------------------------------------------- 1 | 2 | Authors and Citation • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |
    50 |

    Authors and Citation

    51 |
    52 | 53 | 54 |
    • 55 |

      Ozan Cinar. Author, maintainer. 56 |

      57 |
      • 58 |
    • 59 |

      Wolfgang Viechtbauer. Author. 60 |

      61 |
      • 62 |
    63 |
    64 |
    65 |

    Citation

    66 | 67 |
    68 |
    69 | 70 | 71 |

    Cinar, O., & Viechtbauer, W. (2022) The poolr package for combining independent and dependent p values. Journal of Statistical Software, 101(1), 1-42. https://doi.org/10.18637/jss.v101.i01

    72 | 
    @Article{,
 73 |   title = {The {poolr} Package for Combining Independent and Dependent $p$ Values},
 74 |   author = {Ozan Cinar and Wolfgang Viechtbauer},
 75 |   journal = {Journal of Statistical Software},
 76 |   year = {2022},
 77 |   volume = {101},
 78 |   number = {1},
 79 |   pages = {1--42},
 80 |   doi = {10.18637/jss.v101.i01},
 81 | }
    82 | 83 |
    84 | 85 |
    86 | 87 | 88 | 89 |
    90 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    91 |
    92 | 93 |
    94 |

    Site built with pkgdown 2.2.0.

    95 |
    96 | 97 |
    98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | -------------------------------------------------------------------------------- /tests/testthat/test_misc_funs.r: -------------------------------------------------------------------------------- 1 | ### library(poolr); library(testthat); Sys.setenv(NOT_CRAN="true") 2 | 3 | source("tolerances.r") 4 | 5 | # unsymmetric matrix 6 | unsym_mat <- matrix(0.5, 2, 2); diag(unsym_mat) <- 1; unsym_mat[1, 2] <- 0.2 7 | 8 | # matrix with a missing value 9 | mat_w_mis <- matrix(0.5, 2, 2); diag(mat_w_mis) <- 1; mat_w_mis[1, 1] <- NA 10 | 11 | # negative-definite matrix 12 | neg_def_mat <- matrix(-0.8, 3, 3); diag(neg_def_mat) <- 1 13 | 14 | # matrix as a data frame 15 | dat_fra_mat <- matrix(0.8, 3, 3); diag(dat_fra_mat) <- 1 16 | dat_fra_mat <- as.data.frame(dat_fra_mat) 17 | 18 | # matrix with values out of bounds 19 | mat_out_bou <- matrix(1.5, 2, 2); diag(unsym_mat) <- 1 20 | 21 | # matrix with diagonal values other than 1 22 | mat_out_diag <- matrix(0.9, 2, 2) 23 | 24 | # an appropriate matrix (to test the dimensions with the vector of p-values) 25 | approp_mat <- matrix(0.5, 2, 2); diag(approp_mat) <- 1 26 | 27 | # a set of p-values stored as a matrix with 1 row 28 | p_mat <- t(as.matrix(c(0.02, 0.05, 0.20))) 29 | 30 | context("Checking errors") 31 | 32 | test_that("Errors are thrown correctly.", { 33 | 34 | expect_error(fisher(), "Argument 'p' must be specified.") 35 | expect_error(fisher(matrix("a", 2, 2)), "Argument 'p' must be a numeric vector.") 36 | expect_error(fisher(c(0.1, NA)), "Values in 'p' vector must not contain NAs.") 37 | expect_error(fisher(c(1.1, 0.1)), "Values in 'p' vector \\(i.e., the p-values\\) must be between 0 and 1.") 38 | 39 | expect_error(mvnconv(unsym_mat, target = "m2lp"), "Argument 'R' must be a symmetric matrix.") 40 | expect_error(meff(mat_w_mis, method = "liji"), "Values in 'R' must not contain NAs.") 41 | expect_warning(empirical(neg_def_mat, method = "fisher"), "Matrix 'R' is not positive definite. Used Matrix::nearPD\\(\\) to make 'R' positive definite.") 42 | expect_error(meff(mat_out_bou, method = "liji"), "Argument 'R' must be a correlation matrix, but contains values outside \\[-1,1\\].") 43 | 44 | expect_error(fisher(c(.1,.1), adjust = "generalized", R = mvnconv(unsym_mat)), "Argument 'R' must be a symmetric matrix.") 45 | expect_error(fisher(c(.1,.1), adjust = "generalized", R = mvnconv(mat_w_mis)), "Values in 'R' must not contain NAs.") 46 | 47 | expect_error(fisher(runif(3), adjust = "liji", R = approp_mat), "Length of 'p' vector \\(3\\) does not match the dimensions of the 'R' matrix \\(2,2\\).") 48 | expect_warning(fisher(runif(2), R = approp_mat)) 49 | expect_warning(fisher(runif(2), m = 3, R = approp_mat)) 50 | expect_warning(fisher(runif(2), m = 3)) 51 | 52 | expect_error(empirical(approp_mat, method = "fisher", side = c(1, 2)), "Argument 'side' must be of length 1.") 53 | expect_error(empirical(approp_mat, method = "fisher", side = 3), "Argument 'side' must be either 1 or 2.") 54 | 55 | expect_warning(fisher(runif(2), adjust = "empirical", R = approp_mat, emp.dist = runif(10), threshold = 0.5)) 56 | 57 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = "a"), "Argument 'size' must be numeric. See help\\(fisher\\).") 58 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = -1), "Values in 'size' must be >= 1. See help\\(fisher\\).") 59 | 60 | expect_warning(fisher(runif(2), adjust = "empirical", R = approp_mat, threshold = 0.5)) 61 | 62 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000)), "Argument 'threshold' must be specified when 'size' is a vector. See help\\(fisher\\).") 63 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000), threshold = "a"), "Argument 'threshold' must be numeric. See help\\(fisher\\).") 64 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000), threshold = 1.1), "Values in 'threshold' must be between 0 and 1. See help\\(fisher\\).") 65 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000), threshold = c(0.3, 0.3, 0.1)), "Length of 'threshold' argument is not compatible with length of 'size' argument. See help\\(fisher\\).") 66 | expect_error(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000), threshold = c(0.3, 0.3, 0.1)), "Length of 'threshold' argument is not compatible with length of 'size' argument. See help\\(fisher\\).") 67 | 68 | out <- capture.output(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000), threshold = c(0.3), verbose = TRUE)) 69 | 70 | expect_error(fisher(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 71 | expect_error(stouffer(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 72 | expect_error(invchisq(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 73 | expect_error(binomtest(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 74 | expect_error(bonferroni(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 75 | expect_error(tippett(runif(2), adjust = "empirical"), "Argument 'R' must be specified when using an adjustment method.") 76 | 77 | expect_error(fisher(runif(2), adjust = "liji", R = mat_out_diag), "Diagonal values in 'R' must all be equal to 1.") 78 | 79 | expect_warning(fisher(runif(2), adjust = "empirical", R = approp_mat, size = c(100, 1000, 10000), threshold = rep(0.5, 3))) 80 | 81 | expect_warning(fisher(runif(2), adjust = "generalized", R = mvnconv(approp_mat, target = "z"))) 82 | 83 | }) 84 | 85 | test_that("Conversions work correctly.", { 86 | 87 | meff_neg_def_mat <- expect_warning(meff(neg_def_mat, method = "liji"), "One or more eigenvalues derived from the 'R' matrix are negative.") 88 | meff_dat_fra_mat <- meff(dat_fra_mat, method = "liji") 89 | 90 | expect_equivalent(meff_neg_def_mat, 4, tolerance = m_tol) 91 | expect_equivalent(meff_dat_fra_mat, 2, tolerance = m_tol) 92 | 93 | # set.seed(1234) 94 | # meff_nearpd <- fisher(runif(3), adjust = "liji", R = nearPD(neg_def_mat, corr = TRUE)$mat) 95 | # expect_equivalent(c(meff_nearpd$p), 0.3917173, tolerance = p_tol) 96 | 97 | set.seed(1234) 98 | emp_mvnmethod <- fisher(runif(2), adjust = "liji", R = approp_mat, mvnmethod = "mass_eigen") 99 | expect_equivalent(c(emp_mvnmethod$p), 0.2581587, tolerance = p_tol) 100 | 101 | p_mat_comb <- fisher(p_mat) 102 | expect_equivalent(c(p_mat_comb$p), 0.009157697, tolerance = p_tol) 103 | 104 | }) 105 | -------------------------------------------------------------------------------- /docs/reference/print.poolr.html: -------------------------------------------------------------------------------- 1 | 2 | Print Method for 'poolr' Objects — print.poolr • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |

    Print Method for 'poolr' Objects

    50 | 51 | 52 |
    53 | 54 |
    55 |

    Print method for objects of class "poolr".

    56 |
    57 | 58 |
    59 | 
    # S3 method for class 'poolr'
 60 | print(x, digits=3, ...)
    61 |
    62 | 63 |
    64 |

    Arguments

    65 |

    66 |
    x
    67 |

    an object of class "poolr".

    68 | 69 |
    digits
    70 |

    integer specifying the number of (significant) digits for rounding/presenting the results.

    71 | 72 |
    ...
    73 |

    other arguments.

    74 | 75 |
    76 |
    77 |

    Details

    78 |

    The output shows the combined \(p\)-value (with the specified number of significant digits), the test statistic (and its assumed null distribution), and the adjustment method that was applied.

    79 |
    80 |
    81 |

    Value

    82 |

    The function does not return an object.

    83 |
    84 |
    85 |

    Author

    86 |

    Ozan Cinar ozancinar86@gmail.com
    87 | Wolfgang Viechtbauer wvb@wvbauer.com

    88 |
    89 | 90 |
    91 | 94 |
    95 | 96 | 97 |
    98 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    99 |
    100 | 101 |
    102 |

    Site built with pkgdown 2.2.0.

    103 |
    104 | 105 |
    106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /docs/reference/grid2ip.html: -------------------------------------------------------------------------------- 1 | 2 | Results from testing the association between depressive symptoms and 23 SNPs in the GRID2IP gene — grid2ip • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |

    Results from testing the association between depressive symptoms and 23 SNPs in the GRID2IP gene

    50 | 51 | 52 |
    53 | 54 |
    55 |

    Results from testing the association between depressive symptoms (as measured with the CES-D scale) and 23 single-nucleotide polymorphisms (SNPs) in the GRID2IP gene based on a sample of 886 adolescents (Van Assche et al., 2017).

    56 |
    57 | 58 |
    59 | 
    grid2ip.p
60 | grid2ip.ld
61 | grid2ip.geno
62 | grid2ip.pheno
    63 |
    64 | 65 |
    66 |

    Format

    67 |

    Object grid2ip.p is a vector with the 23 \(p\)-values of the tests (two-sided). Object grid2ip.ld contains a matrix with the linkage disequilibrium (LD) correlations among the 23 SNPs. grid2ip.geno is a matrix that contains the genotypes of the adoloscents for the 23 SNPs. grid2ip.pheno is a vector with the phenotype for the adoloscents (the log-transformed CES-D scale values).

    68 |
    69 |
    70 |

    References

    71 |

    Van Assche, E., Moons, T., Cinar, O., Viechtbauer, W., Oldehinkel, A. J., Van Leeuwen, K., Verschueren, K., Colpin, H., Lambrechts, D., Van den Noortgate, W., Goossens, L., Claes, S., & van Winkel, R. (2017). Gene-based interaction analysis shows GABAergic genes interacting with parenting in adolescent depressive symptoms. Journal of Child Psychology and Psychiatry, 58(12), 1301–1309. https://doi.org/10.1111/jcpp.12766

    72 |
    73 | 74 |
    75 | 78 |
    79 | 80 | 81 |
    82 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    83 |
    84 | 85 |
    86 |

    Site built with pkgdown 2.2.0.

    87 |
    88 | 89 |
    90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /man/meff.Rd: -------------------------------------------------------------------------------- 1 | \name{meff} 2 | \alias{meff} 3 | \title{Estimate the Effective Number of Tests} 4 | \description{Estimate the effective number of tests.\loadmathjax} 5 | \usage{ 6 | meff(R, eigen, method, \dots) 7 | } 8 | \arguments{ 9 | \item{R}{a \mjeqn{k \times k}{k * k} symmetric matrix that reflects the correlation structure among the tests.} 10 | \item{eigen}{optional vector to directly supply the eigenvalues to the function (instead of computing them from the matrix given via \code{R}).} 11 | \item{method}{character string to specify the method to be used to estimate the effective number of tests (either \code{"nyholt"}, \code{"liji"}, \code{"gao"}, \code{"galwey"}, or \code{"chen"}). See \sQuote{Details}.} 12 | \item{\dots}{other arguments.} 13 | } 14 | \details{ 15 | 16 | The function estimates the effective number of tests based on one of five different methods. All methods except the one by Chen and Liu (2011) work by extracting the eigenvalues from the \mjseqn{R} matrix supplied via the \code{R} argument (or from the eigenvalues directly passed via the \code{eigen} argument). Letting \mjseqn{\lambda_i} denote the \mjseqn{i}th eigenvalue of this matrix (with \mjseqn{i = 1, \ldots, k}) in decreasing order, the effective number of tests (\mjseqn{m}) is estimated as follows. 17 | 18 | \bold{Method by Nyholt (2004)} 19 | 20 | \mjdeqn{m = 1 + (k - 1) \left(1 - \frac{\mbox{Var}(\lambda)}{k}\right)}{m = 1 + (k - 1) (1 - Var(\lambda) / k)} where \mjeqn{\mbox{Var}(\lambda)}{Var(\lambda)} is the observed sample variance of the \mjseqn{k} eigenvalues. 21 | 22 | \bold{Method by Li & Ji (2005)} 23 | 24 | \mjdeqn{m = \sum_{i = 1}^k f(|\lambda_i|)}{m = sum_{i=1}^k f(|\lambda_i|)} where \mjeqn{f(x) = I(x \ge 1) + (x - \lfloor x \rfloor)}{f(x) = I(x \ge 1) + (x - floor(x))} and \mjeqn{\lfloor \cdot \rfloor}{floor(.)} is the floor function. 25 | 26 | \bold{Method by Gao et al. (2008)} 27 | 28 | \mjtdeqn{m = \min(x) \; \mbox{such that} \; \frac{\sum_{i = 1}^x \lambda_{i}}{\sum_{i = 1}^k \lambda_{i}} > C}{m = \min(x) \; \mbox{such that} \; \frac{\sum_{i = 1}^x \lambda_{i}}{\sum_{i = 1}^k \lambda_{i}} \gt C}{m = min(x) such that sum_{i=1}^x \lambda_(i) / sum_{i=1}^k \lambda_(i) > C} where \mjseqn{C} is a pre-defined parameter which is set to 0.995 by default, but can be adjusted (see \sQuote{Note}). 29 | 30 | \bold{Method by Galwey (2009)} 31 | 32 | \mjdeqn{m = \frac{\left(\sum_{i = 1}^k \sqrt{\lambda_i'}\right)^2}{\sum_{i = 1}^k \lambda_i'}}{m = (sum_{i=1}^k \sqrt{\lambda_i'})^2 / \sum_{i=1}^k \lambda_i'} where \mjeqn{\lambda_i' = \max[0, \lambda_i]}{\lambda_i' = max[0, \lambda_i]}. 33 | 34 | \bold{Method by Chen & Liu (2011)} 35 | 36 | \mjdeqn{m = \sum_{i = 1}^k \frac{1}{R_i}}{m = sum_{i=1}^k 1/R_i} where \mjeqn{R_i = \sum_{j = 1}^k |r_{ij}|^C}{R_i = |r_{ij}|^C} for \mjseqn{i = 1, \ldots, k} and \mjseqn{r_{ij}} denotes the element in the \mjseqn{R} matrix in row \mjseqn{i} and column \mjseqn{j}. By default, the value of \mjseqn{C} is set to 7, but can be adjusted (see \sQuote{Note}). 37 | 38 | \bold{Note:} For all methods that can yield a non-integer estimate (all but the method by Gao et al., 2008), the resulting estimate \mjseqn{m} is rounded down to the nearest integer. 39 | 40 | \bold{Specifying the R Matrix} 41 | 42 | The \mjseqn{R} matrix should reflect the dependence structure among the tests. There is no general solution on how such a matrix should be constructed, as this depends on the type of test and the sidedness of these tests. For example, we can use the correlations among related but changing elements across the analyses/tests, or a function thereof, as a proxy for the dependence structure. For example, when conducting \mjseqn{k} analyses with the same dependent variable and \mjseqn{k} different independent variables, the correlations among the independent variables could serve as such a proxy. Analogously, if analyses are conducted for \mjseqn{k} dependent variables with the same set of independent variables, the correlations among the dependent variables could be used instead. 43 | 44 | If the tests of interest have test statistics that can be assumed to follow a multivariate normal distribution and a matrix is available that reflects the correlations among the test statistics (which might be approximated by the correlations among the interchanging independent or dependent variables), then the \code{\link{mvnconv}} function can be used to convert this correlation matrix into the correlations among the (one- or two-sided) \mjseqn{p}-values, which in turn can then be passed to the \code{R} argument. See \sQuote{Examples}. 45 | 46 | \bold{Non-Positive Semi-Definite R} 47 | 48 | Depending on the way \mjseqn{R} was constructed, it may happen that this matrix is not positive semi-definite, leading to negative eigenvalues. The methods given above can all still be carried out in this case. However, another possibility is to handle such a case by using an algorithm that finds the nearest positive (semi-)definite matrix (e.g., Higham 2002) before passing this matrix to the function (see \code{\link[Matrix]{nearPD}} from the \pkg{Matrix} package for a corresponding implementation). 49 | 50 | } 51 | \value{ 52 | A scalar giving the estimate of the effective number of tests. 53 | } 54 | \note{ 55 | For \code{method = "gao"}, \code{C = 0.995} by default, but a different value of \code{C} can be passed to the function via \code{\dots} (e.g., \code{meff(R, method = "gao", C = 0.95)}). For \code{method = "chen"}, \code{C = 7} by default, but a different value of \code{C} can be passed to the function via \code{\dots} (e.g., \code{meff(R, method = "chen", C = 6)}). 56 | } 57 | \author{ 58 | Ozan Cinar \email{ozancinar86@gmail.com} \cr 59 | Wolfgang Viechtbauer \email{wvb@wvbauer.com} \cr 60 | } 61 | \references{ 62 | Chen, Z. X., & Liu, Q. Z. (2011). A new approach to account for the correlations among single nucleotide polymorphisms in genome-wide association studies. \emph{Human Heredity}, \bold{72}(1), 1--9. \verb{https://doi.org/10.1159/000330135} 63 | 64 | Cinar, O. & Viechtbauer, W. (2022). The poolr package for combining independent and dependent p values. \emph{Journal of Statistical Software}, \bold{101}(1), 1--42. \verb{https://doi.org/10.18637/jss.v101.i01} 65 | 66 | Gao, X., Starmer, J., & Martin, E. R. (2008). A multiple testing correction method for genetic association studies using correlated single nucleotide polymorphisms. \emph{Genetic Epidemiology, 32}(4), 361--369. \verb{https://doi.org/10.1002/gepi.20310} 67 | 68 | Galwey, N. W. (2009). A new measure of the effective number of tests, a practical tool for comparing families of non-independent significance tests. \emph{Genetic Epidemiology, 33}(7), 559--568. \verb{https://doi.org/10.1002/gepi.20408} 69 | 70 | Higham, N. J. (2002). Computing the nearest correlation matrix: A problem from finance. \emph{IMA Journal of Numerical Analysis, 22}(3), 329--343. \verb{https://doi.org/10.1093/imanum/22.3.329} 71 | 72 | Li, J., & Ji, L. (2005). Adjusting multiple testing in multilocus analyses using the eigenvalues of a correlation matrix. \emph{Heredity, 95}(3), 221--227. \verb{https://doi.org/10.1038/sj.hdy.6800717} 73 | 74 | Nyholt, D. R. (2004). A simple correction for multiple testing for single-nucleotide polymorphisms in linkage disequilibrium with each other. \emph{American Journal of Human Genetics, 74}(4), 765--769. \verb{https://doi.org/10.1086/383251} 75 | } 76 | \examples{ 77 | # copy LD correlation matrix into r (see help(grid2ip) for details on these data) 78 | r <- grid2ip.ld 79 | 80 | # estimate the effective number of tests based on the LD correlation matrix 81 | meff(r, method = "nyholt") 82 | meff(r, method = "liji") 83 | meff(r, method = "gao") 84 | meff(r, method = "galwey") 85 | meff(r, method = "chen") 86 | 87 | # use mvnconv() to convert the LD correlation matrix into a matrix with the 88 | # correlations among the (two-sided) p-values assuming that the test 89 | # statistics follow a multivariate normal distribution with correlation 90 | # matrix r (note: 'side = 2' by default in mvnconv()) 91 | mvnconv(r, target = "p", cov2cor = TRUE)[1:5,1:5] # show only rows/columns 1-5 92 | 93 | # use this matrix instead for estimating the effective number of tests 94 | meff(mvnconv(r, target = "p", cov2cor = TRUE), method = "nyholt") 95 | meff(mvnconv(r, target = "p", cov2cor = TRUE), method = "liji") 96 | meff(mvnconv(r, target = "p", cov2cor = TRUE), method = "gao") 97 | meff(mvnconv(r, target = "p", cov2cor = TRUE), method = "galwey") 98 | meff(mvnconv(r, target = "p", cov2cor = TRUE), method = "chen") 99 | } 100 | \keyword{htest} 101 | -------------------------------------------------------------------------------- /docs/reference/mvnlookup.html: -------------------------------------------------------------------------------- 1 | 2 | Lookup Table for the mvnconv() Function — mvnlookup • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |

    Lookup Table for the mvnconv() Function

    50 | 51 | 52 |
    53 | 54 |
    55 |

    Lookup table for the mvnconv function.

    56 |
    57 | 58 |
    59 | 
    mvnlookup
    60 |
    61 | 62 |
    63 |

    Format

    64 |

    The data frame contains the following columns:

    rhosnumericcorrelations among the test statistics
    m2lp_1numeric\(\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]\) (for one-sided tests)
    m2lp_2numeric\(\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]\) (for two-sided tests)
    z_1numeric\(\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]\) (for one-sided tests)
    z_2numeric\(\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]\) (for two-sided tests)
    chisq1_1numeric\(\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]\) (for one-sided tests)
    chisq1_2numeric\(\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]\) (for two-sided tests)
    p_1numeric\(\mbox{Cov}[p_i, p_j]\) (for one-sided tests)
    p_2numeric\(\mbox{Cov}[p_i, p_j]\) (for two-sided tests)
    65 |
    66 |

    Details

    67 |

    Assume \[\begin{bmatrix} t_i \\ t_j \end{bmatrix} \sim \mbox{MVN} \left(\begin{bmatrix} 0 \\ 0 \end{bmatrix}, \begin{bmatrix} 1 & \rho_{ij} \\ \rho_{ij} & 1 \end{bmatrix} \right)\] is the joint distribution for test statistics \(t_i\) and \(t_j\). For one-sided tests, let \(p_i = 1 - \Phi(t_i)\) and \(p_j = 1 - \Phi(t_j)\) where \(\Phi(\cdot)\) denotes the cumulative distribution function of a standard normal distribution. For two-sided tests, let \(p_i = 2(1 - \Phi(|t_i|))\) and \(p_j = 2(1 - \Phi(|t_j|))\). These are simply the one- and two-sided \(p\)-values corresponding to \(t_i\) and \(t_j\).

    68 |

    Columns p_1 and p_2 contain the values for \(\mbox{Cov}[p_i, p_j]\).

    69 |

    Columns m2lp_1 and m2lp_2 contain the values for \(\mbox{Cov}[-2 \ln(p_i), -2 \ln(p_j)]\).

    70 |

    Columns chisq1_1 and chisq1_2 contain the values for \(\mbox{Cov}[F^{-1}(1 - p_i, 1), F^{-1}(1 - p_j, 1)]\), where \(F^{-1}(\cdot,1)\) denotes the inverse of the cumulative distribution function of a chi-square distribution with one degree of freedom.

    71 |

    Columns z_1 and z_2 contain the values for \(\mbox{Cov}[\Phi^{-1}(1 - p_i), \Phi^{-1}(1 - p_j)]\), where \(\Phi^{-1}(\cdot)\) denotes the inverse of the cumulative distribution function of a standard normal distribution.

    72 |

    Computation of these covariances required numerical integration. The values in this table were precomputed.

    73 |
    74 | 75 |
    76 | 79 |
    80 | 81 | 82 |
    83 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    84 |
    85 | 86 |
    87 |

    Site built with pkgdown 2.2.0.

    88 |
    89 | 90 |
    91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | -------------------------------------------------------------------------------- /docs/news/index.html: -------------------------------------------------------------------------------- 1 | 2 | Changelog • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |

    Changelog

    50 | 51 |
    52 | 53 |
    54 |

    poolr 1.3-0 (2025-12-01)

    55 |
    • version bump for development version
    56 |
    57 |

    poolr 1.2-0 (2025-12-01)2025-05-07

    58 |

    • added the reference to the publication in the Journal of Statistical Software

      • 59 |

    • fixed an issue where the Bonferroni and Tippett methods were not identical with adjust = "empirical" when the observed Bonferroni-adjusted p-value is equal to 1

      • 60 |

    • added the method by Chen & Liu (2011) for estimating the effective number of tests via adjust = "chen"

      • 61 |
    62 |
    63 |

    poolr 1.0-0 (2021-06-02)2021-06-16

    64 |

    • changed name of binotest() function to binomtest()

      • 65 |

    • the HTML help files now show rendered equations with the help of the mathjaxr package

      • 66 |

    • increased resolution of mvnlookup table (now in steps of .001)

      • 67 |

    • meff() function now issues a warning if there are negative eigenvalues (and if they were set to 0 for method="galway")

      • 68 |

    • added nearpd argument to all base functions; if TRUE, a negative definite R matrix will be turned into the nearest positive semi-definite matrix (only for adjust="empirical" and adjust="generalized")

      • 69 |

    • implemented a simplified version of Matrix::nearPD(); hence, dependence on the package Matrix was removed

      • 70 |

    • added a more specific test on p and eigen that they are numeric vectors

      • 71 |

    • improved the pkgdown docs and added a quick start guide

      • 72 |

    • changed the way the pseudo replicates are generated in empirical() to a more stable method

      • 73 |

    • slight improvements to the output of print.poolr() when using the effective number of tests or empirical distribution adjustments

      • 74 |

    • mvnconv() now uses the variances from the lookup table instead of cov2cor() for the transformation when cov2cor=TRUE

      • 75 |

    • added a check on R (where appropriate) that its diagonal values are all equal to 1

      • 76 |

    • added a check on p to convert it into a numeric vector if it is a matrix with 1 row

      • 77 |
    78 |
    79 |

    poolr 0.8-2 (2020-02-12)2020-02-21

    80 |
    • first version for CRAN
    81 |
    82 | 83 | 86 | 87 |
    88 | 89 | 90 |
    91 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    92 |
    93 | 94 |
    95 |

    Site built with pkgdown 2.2.0.

    96 |
    97 | 98 |
    99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | -------------------------------------------------------------------------------- /docs/reference/index.html: -------------------------------------------------------------------------------- 1 | 2 | Package index • poolr 6 | 7 | 8 |
    9 |
    43 | 44 | 45 | 46 |
    47 |
    48 |
    49 |

    Reference

    50 |
    51 | 52 | 56 | 59 | 60 | 64 | 67 | 68 | 71 | 72 | 75 | 76 | 79 | 80 | 83 | 84 | 87 | 88 | 92 | 95 | 96 | 99 | 100 | 103 | 104 | 107 | 108 | 112 | 115 | 116 | 119 | 120 |
    53 |

    Package Introduction

    54 |

    Introduction to the package.

    55 |
    57 |

    poolr-package poolr

    58 |

    Methods for Pooling P-Values from (Dependent) Tests

    61 |

    Base Methods

    62 |

    Functions to combine independent and dependent p-values.

    63 |
    65 |

    fisher()

    66 |

    Fisher's Method

    69 |

    stouffer()

    70 |

    Stouffer's Method

    73 |

    invchisq()

    74 |

    Inverse Chi-Square Method

    77 |

    binomtest()

    78 |

    Binomial Test

    81 |

    bonferroni()

    82 |

    Bonferroni Method

    85 |

    tippett()

    86 |

    Tippett's Method

    89 |

    Support Functions

    90 |

    Functions to support the functionality of the base methods..

    91 |
    93 |

    empirical()

    94 |

    Simulate Empirically-Derived Null Distributions

    97 |

    meff()

    98 |

    Estimate the Effective Number of Tests

    101 |

    mvnconv()

    102 |

    Convert Correlations Among Multivariate Normal Test Statistics to Covariances for Various Target Statistics

    105 |

    print(<poolr>)

    106 |

    Print Method for 'poolr' Objects

    109 |

    Datasets

    110 |

    Functions for creating various types of plots.

    111 |
    113 |

    grid2ip.p grid2ip.ld grid2ip.geno grid2ip.pheno

    114 |

    Results from testing the association between depressive symptoms and 23 SNPs in the GRID2IP gene

    117 |

    mvnlookup

    118 |

    Lookup Table for the mvnconv() Function

    121 | 122 | 125 |
    126 | 127 | 128 |
    129 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    130 |
    131 | 132 |
    133 |

    Site built with pkgdown 2.2.0.

    134 |
    135 | 136 |
    137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /docs/pkgdown.css: -------------------------------------------------------------------------------- 1 | /* Sticky footer */ 2 | 3 | /** 4 | * Basic idea: https://philipwalton.github.io/solved-by-flexbox/demos/sticky-footer/ 5 | * Details: https://github.com/philipwalton/solved-by-flexbox/blob/master/assets/css/components/site.css 6 | * 7 | * .Site -> body > .container 8 | * .Site-content -> body > .container .row 9 | * .footer -> footer 10 | * 11 | * Key idea seems to be to ensure that .container and __all its parents__ 12 | * have height set to 100% 13 | * 14 | */ 15 | 16 | html, body { 17 | height: 100%; 18 | } 19 | 20 | body { 21 | position: relative; 22 | } 23 | 24 | body > .container { 25 | display: flex; 26 | height: 100%; 27 | flex-direction: column; 28 | } 29 | 30 | body > .container .row { 31 | flex: 1 0 auto; 32 | } 33 | 34 | footer { 35 | margin-top: 45px; 36 | padding: 35px 0 36px; 37 | border-top: 1px solid #e5e5e5; 38 | color: #666; 39 | display: flex; 40 | flex-shrink: 0; 41 | } 42 | footer p { 43 | margin-bottom: 0; 44 | } 45 | footer div { 46 | flex: 1; 47 | } 48 | footer .pkgdown { 49 | text-align: right; 50 | } 51 | footer p { 52 | margin-bottom: 0; 53 | } 54 | 55 | img.icon { 56 | float: right; 57 | } 58 | 59 | /* Ensure in-page images don't run outside their container */ 60 | .contents img { 61 | max-width: 100%; 62 | height: auto; 63 | } 64 | 65 | /* Fix bug in bootstrap (only seen in firefox) */ 66 | summary { 67 | display: list-item; 68 | } 69 | 70 | /* Typographic tweaking ---------------------------------*/ 71 | 72 | .contents .page-header { 73 | margin-top: calc(-60px + 1em); 74 | } 75 | 76 | dd { 77 | margin-left: 3em; 78 | } 79 | 80 | /* Section anchors ---------------------------------*/ 81 | 82 | a.anchor { 83 | display: none; 84 | margin-left: 5px; 85 | width: 20px; 86 | height: 20px; 87 | 88 | background-image: url(./link.svg); 89 | background-repeat: no-repeat; 90 | background-size: 20px 20px; 91 | background-position: center center; 92 | } 93 | 94 | h1:hover .anchor, 95 | h2:hover .anchor, 96 | h3:hover .anchor, 97 | h4:hover .anchor, 98 | h5:hover .anchor, 99 | h6:hover .anchor { 100 | display: inline-block; 101 | } 102 | 103 | /* Fixes for fixed navbar --------------------------*/ 104 | 105 | .contents h1, .contents h2, .contents h3, .contents h4 { 106 | padding-top: 60px; 107 | margin-top: -40px; 108 | } 109 | 110 | /* Navbar submenu --------------------------*/ 111 | 112 | .dropdown-submenu { 113 | position: relative; 114 | } 115 | 116 | .dropdown-submenu>.dropdown-menu { 117 | top: 0; 118 | left: 100%; 119 | margin-top: -6px; 120 | margin-left: -1px; 121 | border-radius: 0 6px 6px 6px; 122 | } 123 | 124 | .dropdown-submenu:hover>.dropdown-menu { 125 | display: block; 126 | } 127 | 128 | .dropdown-submenu>a:after { 129 | display: block; 130 | content: " "; 131 | float: right; 132 | width: 0; 133 | height: 0; 134 | border-color: transparent; 135 | border-style: solid; 136 | border-width: 5px 0 5px 5px; 137 | border-left-color: #cccccc; 138 | margin-top: 5px; 139 | margin-right: -10px; 140 | } 141 | 142 | .dropdown-submenu:hover>a:after { 143 | border-left-color: #ffffff; 144 | } 145 | 146 | .dropdown-submenu.pull-left { 147 | float: none; 148 | } 149 | 150 | .dropdown-submenu.pull-left>.dropdown-menu { 151 | left: -100%; 152 | margin-left: 10px; 153 | border-radius: 6px 0 6px 6px; 154 | } 155 | 156 | /* Sidebar --------------------------*/ 157 | 158 | #pkgdown-sidebar { 159 | margin-top: 30px; 160 | position: -webkit-sticky; 161 | position: sticky; 162 | top: 70px; 163 | } 164 | 165 | #pkgdown-sidebar h2 { 166 | font-size: 1.5em; 167 | margin-top: 1em; 168 | } 169 | 170 | #pkgdown-sidebar h2:first-child { 171 | margin-top: 0; 172 | } 173 | 174 | #pkgdown-sidebar .list-unstyled li { 175 | margin-bottom: 0.5em; 176 | } 177 | 178 | /* bootstrap-toc tweaks ------------------------------------------------------*/ 179 | 180 | /* All levels of nav */ 181 | 182 | nav[data-toggle='toc'] .nav > li > a { 183 | padding: 4px 20px 4px 6px; 184 | font-size: 1.5rem; 185 | font-weight: 400; 186 | color: inherit; 187 | } 188 | 189 | nav[data-toggle='toc'] .nav > li > a:hover, 190 | nav[data-toggle='toc'] .nav > li > a:focus { 191 | padding-left: 5px; 192 | color: inherit; 193 | border-left: 1px solid #878787; 194 | } 195 | 196 | nav[data-toggle='toc'] .nav > .active > a, 197 | nav[data-toggle='toc'] .nav > .active:hover > a, 198 | nav[data-toggle='toc'] .nav > .active:focus > a { 199 | padding-left: 5px; 200 | font-size: 1.5rem; 201 | font-weight: 400; 202 | color: inherit; 203 | border-left: 2px solid #878787; 204 | } 205 | 206 | /* Nav: second level (shown on .active) */ 207 | 208 | nav[data-toggle='toc'] .nav .nav { 209 | display: none; /* Hide by default, but at >768px, show it */ 210 | padding-bottom: 10px; 211 | } 212 | 213 | nav[data-toggle='toc'] .nav .nav > li > a { 214 | padding-left: 16px; 215 | font-size: 1.35rem; 216 | } 217 | 218 | nav[data-toggle='toc'] .nav .nav > li > a:hover, 219 | nav[data-toggle='toc'] .nav .nav > li > a:focus { 220 | padding-left: 15px; 221 | } 222 | 223 | nav[data-toggle='toc'] .nav .nav > .active > a, 224 | nav[data-toggle='toc'] .nav .nav > .active:hover > a, 225 | nav[data-toggle='toc'] .nav .nav > .active:focus > a { 226 | padding-left: 15px; 227 | font-weight: 500; 228 | font-size: 1.35rem; 229 | } 230 | 231 | /* orcid ------------------------------------------------------------------- */ 232 | 233 | .orcid { 234 | font-size: 16px; 235 | color: #A6CE39; 236 | /* margins are required by official ORCID trademark and display guidelines */ 237 | margin-left:4px; 238 | margin-right:4px; 239 | vertical-align: middle; 240 | } 241 | 242 | /* Reference index & topics ----------------------------------------------- */ 243 | 244 | .ref-index th {font-weight: normal;} 245 | 246 | .ref-index td {vertical-align: top; min-width: 100px} 247 | .ref-index .icon {width: 40px;} 248 | .ref-index .alias {width: 40%;} 249 | .ref-index-icons .alias {width: calc(40% - 40px);} 250 | .ref-index .title {width: 60%;} 251 | 252 | .ref-arguments th {text-align: right; padding-right: 10px;} 253 | .ref-arguments th, .ref-arguments td {vertical-align: top; min-width: 100px} 254 | .ref-arguments .name {width: 20%;} 255 | .ref-arguments .desc {width: 80%;} 256 | 257 | /* Nice scrolling for wide elements --------------------------------------- */ 258 | 259 | table { 260 | display: block; 261 | overflow: auto; 262 | } 263 | 264 | /* Syntax highlighting ---------------------------------------------------- */ 265 | 266 | pre, code, pre code { 267 | background-color: #f8f8f8; 268 | color: #333; 269 | } 270 | pre, pre code { 271 | white-space: pre-wrap; 272 | word-break: break-all; 273 | overflow-wrap: break-word; 274 | } 275 | 276 | pre { 277 | border: 1px solid #eee; 278 | } 279 | 280 | pre .img, pre .r-plt { 281 | margin: 5px 0; 282 | } 283 | 284 | pre .img img, pre .r-plt img { 285 | background-color: #fff; 286 | } 287 | 288 | code a, pre a { 289 | color: #375f84; 290 | } 291 | 292 | a.sourceLine:hover { 293 | text-decoration: none; 294 | } 295 | 296 | .fl {color: #1514b5;} 297 | .fu {color: #000000;} /* function */ 298 | .ch,.st {color: #036a07;} /* string */ 299 | .kw {color: #264D66;} /* keyword */ 300 | .co {color: #888888;} /* comment */ 301 | 302 | .error {font-weight: bolder;} 303 | .warning {font-weight: bolder;} 304 | 305 | /* Clipboard --------------------------*/ 306 | 307 | .hasCopyButton { 308 | position: relative; 309 | } 310 | 311 | .btn-copy-ex { 312 | position: absolute; 313 | right: 0; 314 | top: 0; 315 | visibility: hidden; 316 | } 317 | 318 | .hasCopyButton:hover button.btn-copy-ex { 319 | visibility: visible; 320 | } 321 | 322 | /* headroom.js ------------------------ */ 323 | 324 | .headroom { 325 | will-change: transform; 326 | transition: transform 200ms linear; 327 | } 328 | .headroom--pinned { 329 | transform: translateY(0%); 330 | } 331 | .headroom--unpinned { 332 | transform: translateY(-100%); 333 | } 334 | 335 | /* mark.js ----------------------------*/ 336 | 337 | mark { 338 | background-color: rgba(255, 255, 51, 0.5); 339 | border-bottom: 2px solid rgba(255, 153, 51, 0.3); 340 | padding: 1px; 341 | } 342 | 343 | /* vertical spacing after htmlwidgets */ 344 | .html-widget { 345 | margin-bottom: 10px; 346 | } 347 | 348 | /* fontawesome ------------------------ */ 349 | 350 | .fab { 351 | font-family: "Font Awesome 5 Brands" !important; 352 | } 353 | 354 | /* don't display links in code chunks when printing */ 355 | /* source: https://stackoverflow.com/a/10781533 */ 356 | @media print { 357 | code a:link:after, code a:visited:after { 358 | content: ""; 359 | } 360 | } 361 | 362 | /* Section anchors --------------------------------- 363 | Added in pandoc 2.11: https://github.com/jgm/pandoc-templates/commit/9904bf71 364 | */ 365 | 366 | div.csl-bib-body { } 367 | div.csl-entry { 368 | clear: both; 369 | } 370 | .hanging-indent div.csl-entry { 371 | margin-left:2em; 372 | text-indent:-2em; 373 | } 374 | div.csl-left-margin { 375 | min-width:2em; 376 | float:left; 377 | } 378 | div.csl-right-inline { 379 | margin-left:2em; 380 | padding-left:1em; 381 | } 382 | div.csl-indent { 383 | margin-left: 2em; 384 | } 385 | -------------------------------------------------------------------------------- /docs/reference/poolr-package.html: -------------------------------------------------------------------------------- 1 | 2 | Methods for Pooling P-Values from (Dependent) Tests — poolr-package • poolr 17 | 18 | 19 |
    20 |
    54 | 55 | 56 | 57 |
    58 |
    59 |
    60 |

    Methods for Pooling P-Values from (Dependent) Tests

    61 | 62 | 63 |
    64 | 65 |
    66 |

    67 | The poolr package contains functions for pooling/combining the results (i.e., \(p\)-values) from (dependent) hypothesis tests. Included are Fisher's method, Stouffer's method, the inverse chi-square method, the Bonferroni method, Tippett's method, and the binomial test. Each method can be adjusted based on an estimate of the effective number of tests or using empirically-derived null distribution using pseudo replicates. For Fisher's, Stouffer's, and the inverse chi-square method, direct generalizations based on multivariate theory are also available (leading to Brown's method, Strube's method, and the generalized inverse chi-square method). For more details, see:

    68 |

    • fisher: for Fisher's method (and Brown's method)

      • 69 |

    • stouffer: for Stouffer's method (and Strube's method)

      • 70 |

    • invchisq: for the inverse chi-square method

      • 71 |

    • bonferroni: for the Bonferroni method

      • 72 |

    • tippett: for Tippett's method

      • 73 |

    • binomtest: for the binomial test

      • 74 |

    Note that you can also read the documentation of the package online at https://ozancinar.github.io/poolr/ (where it is nicely formatted and the output from all examples is provided).

    75 |
    76 | 77 | 78 |
    79 |

    Author

    80 |

    Ozan Cinar ozancinar86@gmail.com
    81 | Wolfgang Viechtbauer wvb@wvbauer.com

    82 |
    83 |
    84 |

    References

    85 |

    Brown, M. B. (1975). 400: A method for combining non-independent, one-sided tests of significance. Biometrics, 31(4), 987–992. https://doi.org/10.2307/2529826

    86 |

    Cinar, O. & Viechtbauer, W. (2022). The poolr package for combining independent and dependent p values. Journal of Statistical Software, 101(1), 1–42. https://doi.org/10.18637/jss.v101.i01

    87 |

    Fisher, R. A. (1932). Statistical Methods for Research Workers (4th ed.). Edinburgh: Oliver and Boyd.

    88 |

    Lancaster, H. O. (1961). The combination of probabilities: An application of orthonormal functions. Australian Journal of Statistics, 3(1), 20–33. https://doi.org/10.1111/j.1467-842X.1961.tb00058.x

    89 |

    Strube, M. J. (1985). Combining and comparing significance levels from nonindependent hypothesis tests. Psychological Bulletin, 97(2), 334–341. https://doi.org/10.1037/0033-2909.97.2.334

    90 |

    Tippett, L. H. C. (1931). Methods of Statistics. London: Williams Norgate.

    91 |

    Wilkinson, B. (1951). A statistical consideration in psychological research. Psychological Bulletin, 48(2), 156–158. https://doi.org/10.1037/h0059111

    92 |
    93 | 94 |
    95 | 98 |
    99 | 100 | 101 |
    102 |

    Developed by Ozan Cinar, Wolfgang Viechtbauer.

    103 |
    104 | 105 |
    106 |

    Site built with pkgdown 2.2.0.

    107 |
    108 | 109 |
    110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | Methods for Pooling P-Values from (Dependent) Tests • poolr 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 20 | 21 | 22 | 23 | 24 |
    25 |
    64 | 65 | 66 | 67 | 68 |
    69 |
    70 |
    71 |

    poolr: Package for Pooling the Results from (Dependent) Tests 72 |

    73 |

    R build status CRAN Version devel Version Code Coverage

    74 |
    75 |

    Description 76 |

    77 |

    The poolr package contains functions for pooling/combining the results (i.e., p-values) from (dependent) hypothesis tests. Included are Fisher’s method, Stouffer’s method, the inverse chi-square method, the Bonferroni method, Tippett’s method, and the binomial test. Each method can be adjusted based on an estimate of the effective number of tests or using empirically derived null distribution using pseudo replicates. For Fisher’s, Stouffer’s, and the inverse chi-square method, direct generalizations based on multivariate theory are also available (leading to Brown’s method, Strube’s method, and the generalized inverse chi-square method).

    78 |
    79 |
    80 |

    Documentation 81 |

    82 |

    You can read the documentation of the poolr package online at https://ozancinar.github.io/poolr/ (where it is nicely formatted, equations are shown correctly, and the output from all examples is provided).

    83 |
    84 |
    85 |

    Installation 86 |

    87 |

    The current official (i.e., CRAN) release can be installed directly within R with:

    88 | 
     89 | install.packages("poolr")
    90 |

    After installing the remotes package with install.packages("remotes"), the development version of the poolr package can be installed with:

    91 | 
     92 | remotes::install_github("ozancinar/poolr")
    93 |
    94 |
    95 |

    Meta 96 |

    97 |

    The poolr package was written by Ozan Cinar and Wolfgang Viechtbauer. It is licensed under the GNU General Public License Version 2. To report any issues or bugs, please go here.

    98 |
    99 |
    100 |
    101 | 102 | 137 |
    138 | 139 | 140 | 151 |
    152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | -------------------------------------------------------------------------------- /misc/create_mvnlookup.r: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | 3 | # Code to create the mvnlookup.rdata file. 4 | 5 | # for rhos <- seq(1, -0.99, by = -0.01) 6 | # note: 15865 secs for "pracma" (with n=1000) on 'psysim' using 18 cores 7 | # 2853 secs for "cubature" on 'psysim' using 18 cores 8 | 9 | # for rhos <- seq(1, -0.99, by = -0.001) 10 | # note: 160347 secs for "pracma" (with n=1000) on 'psysim' using 18 cores 11 | 12 | ############################################################################ 13 | 14 | library(parallel) 15 | 16 | cl <- makePSOCKcluster(18) 17 | 18 | # vector of rho values for which we obtain the covariances 19 | #rhos <- seq(1, -0.99, by = -0.01) 20 | rhos <- seq(1, -0.99, by = -0.001) 21 | 22 | # choose method for the numerical integration 23 | method <- "pracma" 24 | #method <- "cubature" 25 | 26 | # number of nodes for pracma::gaussLegendre() 27 | n <- 1000 28 | 29 | # limits and tolerance for cubature::adaptIntegrate() 30 | lims <- 5 31 | tol <- 1e-07 32 | 33 | # value to round final results to 34 | rnd <- 4 35 | 36 | # load required packages in workers 37 | invisible(clusterEvalQ(cl, { 38 | library(cubature) 39 | library(pracma) 40 | library(mvtnorm) 41 | })) 42 | 43 | # export 'n', 'lims', and 'tol' 44 | clusterExport(cl, c("n", "lims", "tol")) 45 | 46 | # set up data frame for storing results 47 | mvnlookup <- data.frame(rhos = rhos) 48 | 49 | time.start <- proc.time() 50 | 51 | ############################################################################ 52 | 53 | if (method == "pracma") { 54 | doint <- function(fun, xa = -5, xb = 5, ya = -5, yb = 5, n = 32, rho) { 55 | !any(is.numeric(xa), length(xa) == 1, is.numeric(ya), length(ya) == 1, 56 | is.numeric(xb), length(xb) == 1, is.numeric(yb), length(yb) == 1) 57 | cx <- gaussLegendre(n, xa, xb) 58 | x <- cx$x 59 | wx <- cx$w 60 | cy <- gaussLegendre(n, ya, yb) 61 | y <- cy$x 62 | wy <- cy$w 63 | mgrid <- meshgrid(x, y) 64 | Z <- matrix(NA, n, n) 65 | for(a in 1:n) { 66 | for(b in 1:n) { 67 | Z[a, b] <- fun(c(mgrid$X[a, b], mgrid$Y[a, b]), rho) 68 | } 69 | } 70 | Q <- wx %*% Z %*% as.matrix(wy) 71 | Q <- as.numeric(Q) 72 | return(Q) 73 | } 74 | } 75 | 76 | if (method == "cubature") { 77 | doint <- function(rho, tol, lims) { 78 | # adaptIntegrate() gets stuck in some cases when rho = 0, so skips this (we know that cov = 0 then anyway) 79 | if (rho == 0) { 80 | cov <- NA 81 | } else { 82 | # for 'z_2', using c(-lims,lims) leads to -Inf; make upper lims slightly larger to avoid this 83 | cov <- adaptIntegrate(intfun, tol=tol, lowerLimit=c(-lims,-lims), upperLimit=c(lims+.01,lims+.01), rho=rho)$integral 84 | } 85 | return(cov) 86 | } 87 | } 88 | 89 | clusterExport(cl, "doint") 90 | 91 | ############################################################################ 92 | 93 | # Cov(-2ln(p_i), -2ln(p_j)) for one-sided p-values 94 | 95 | intfun <- function(xy, rho) { 96 | fx <- -2 * pnorm(xy[1], log.p = TRUE) 97 | fy <- -2 * pnorm(xy[2], log.p = TRUE) 98 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 99 | } 100 | 101 | clusterExport(cl, "intfun") 102 | 103 | if (method == "pracma") 104 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 4 105 | if (method == "cubature") 106 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 4 107 | 108 | covs[rhos == 1] <- 4 109 | mvnlookup$m2lp_1 <- covs 110 | 111 | ############################################################################ 112 | 113 | # Cov(-2ln(p_i), -2ln(p_j)) for two-sided p-values 114 | 115 | intfun <- function(xy,rho) { 116 | fx <- -2 * (log(2) + pnorm(abs(xy[1]), log.p = TRUE, lower.tail = FALSE)) 117 | fy <- -2 * (log(2) + pnorm(abs(xy[2]), log.p = TRUE, lower.tail = FALSE)) 118 | fx * fy * dmvnorm(xy, mean=c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 119 | } 120 | 121 | clusterExport(cl, "intfun") 122 | 123 | if (method == "pracma") 124 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 4 125 | if (method == "cubature") 126 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 4 127 | 128 | covs[rhos == 1] <- 4 129 | mvnlookup$m2lp_2 <- covs 130 | 131 | ############################################################################ 132 | 133 | # Cov(z_i, z_j) for one-sided p-values 134 | 135 | intfun <- function(xy, rho) { 136 | fx <- qnorm(pnorm(xy[1]), lower.tail = FALSE) 137 | fy <- qnorm(pnorm(xy[2]), lower.tail = FALSE) 138 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 139 | } 140 | 141 | clusterExport(cl, "intfun") 142 | 143 | if (method == "pracma") 144 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) 145 | if (method == "cubature") 146 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) 147 | 148 | covs[rhos == 1] <- 1 149 | mvnlookup$z_1 <- covs 150 | 151 | ############################################################################ 152 | 153 | # Cov(z_i, z_j) for two-sided p-values 154 | 155 | intfun <- function(xy, rho) { 156 | fx <- qnorm(2 * pnorm(abs(xy[1]), lower.tail = FALSE), lower.tail = FALSE) 157 | fy <- qnorm(2 * pnorm(abs(xy[2]), lower.tail = FALSE), lower.tail = FALSE) 158 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 159 | } 160 | 161 | clusterExport(cl, "intfun") 162 | 163 | if (method == "pracma") 164 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) 165 | if (method == "cubature") 166 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) 167 | 168 | covs[rhos == 1] <- 1 169 | mvnlookup$z_2 <- covs 170 | 171 | ############################################################################ 172 | 173 | # Cov(X^2_i, X^2_j) for one-sided p-values 174 | 175 | intfun <- function(xy, rho) { 176 | fx <- qchisq(pnorm(xy[1]), df = 1, lower.tail = FALSE) 177 | fy <- qchisq(pnorm(xy[2]), df = 1, lower.tail = FALSE) 178 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 179 | } 180 | 181 | clusterExport(cl, "intfun") 182 | 183 | if (method == "pracma") 184 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 1 185 | if (method == "cubature") 186 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 1 187 | 188 | covs[rhos == 1] <- 2 189 | mvnlookup$chisq1_1 <- covs 190 | 191 | ############################################################################ 192 | 193 | # Cov(X^2_i, X^2_j) for two-sided p-values 194 | 195 | intfun <- function(xy, rho) { 196 | fx <- qchisq(2 * pnorm(abs(xy[1]), lower.tail = FALSE), df = 1, lower.tail = FALSE) 197 | fy <- qchisq(2 * pnorm(abs(xy[2]), lower.tail = FALSE), df = 1, lower.tail = FALSE) 198 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 199 | } 200 | 201 | clusterExport(cl, "intfun") 202 | 203 | if (method == "pracma") 204 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 1 205 | if (method == "cubature") 206 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 1 207 | 208 | covs[rhos == 1] <- 2 209 | mvnlookup$chisq1_2 <- covs 210 | 211 | ############################################################################ 212 | 213 | # Cov(p_i, p_j) for one-sided p-values 214 | 215 | intfun <- function(xy, rho) { 216 | fx <- pnorm(xy[1]) 217 | fy <- pnorm(xy[2]) 218 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 219 | } 220 | 221 | clusterExport(cl, "intfun") 222 | 223 | if (method == "pracma") 224 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 1/4 225 | if (method == "cubature") 226 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 1/4 227 | 228 | covs[rhos == 1] <- 1/12 229 | mvnlookup$p_1 <- covs 230 | 231 | ############################################################################ 232 | 233 | # Cov(p_i, p_j) for two-sided p-values 234 | 235 | intfun <- function(xy, rho) { 236 | fx <- 2 * pnorm(abs(xy[1]), lower.tail = FALSE) 237 | fy <- 2 * pnorm(abs(xy[2]), lower.tail = FALSE) 238 | fx * fy * dmvnorm(xy, mean = c(0, 0), sigma = matrix(c(1, rho, rho, 1), nrow = 2)) 239 | } 240 | 241 | clusterExport(cl, "intfun") 242 | 243 | if (method == "pracma") 244 | covs <- parSapplyLB(cl, rhos, function(r) doint(intfun, n=n, rho=r)) - 1/4 245 | if (method == "cubature") 246 | covs <- parSapplyLB(cl, rhos, function(r) doint(rho=r, tol=tol, lims=lims)) - 1/4 247 | 248 | covs[rhos == 1] <- 1/12 249 | mvnlookup$p_2 <- covs 250 | 251 | ############################################################################ 252 | 253 | stopCluster(cl) 254 | 255 | time.end <- proc.time() 256 | secs <- unname(time.end - time.start)[3] 257 | 258 | # total running time in seconds and minutes 259 | print(round(secs)) 260 | print(round(secs / 60, 1)) 261 | 262 | # set all covs to 0 for rho = 0 263 | mvnlookup[rhos == 0,] <- 0 264 | 265 | # round results 266 | mvnlookup <- round(mvnlookup, rnd) 267 | 268 | # save results 269 | #save(mvnlookup, file = "mvnlookup.rdata") 270 | save(mvnlookup, file = "../data/mvnlookup.rdata") 271 | #save(mvnlookup, file = paste0("mvnlookup_", method, ".rdata")) 272 | 273 | ############################################################################ 274 | 275 | if (F) { 276 | 277 | load("../data/mvnlookup.rdata") 278 | 279 | #mvnlookup <- mvnlookup[mvnlookup$rhos >= .90,] 280 | #mvnlookup <- mvnlookup[mvnlookup$rhos <= -.90,] 281 | 282 | par(mfrow=c(4, 2)) 283 | 284 | for (i in 1:8) { 285 | print(names(mvnlookup)[i+1]) 286 | x <- mvnlookup$rhos 287 | y <- mvnlookup[[i + 1]] 288 | X <- poly(x, raw=TRUE, simple=TRUE, degree=8) 289 | colnames(X) <- paste0(".", 1:ncol(X)) 290 | weights <- c(rep(1, length(x) - 1), 1000) 291 | res <- lm(y ~ 0 + X, weights=weights) 292 | print(summary(res)) 293 | print(round(coef(res), 4)) 294 | 295 | if (F) { 296 | plot(x, y, pch=19, cex=0.2, main=names(mvnlookup)[i+1], xlab="rho", ylab="cov") 297 | abline(h=0, lty="dotted") 298 | abline(v=0, lty="dotted") 299 | lines(x, fitted(res)) 300 | } else { 301 | abslim <- .01 302 | plot(x, resid(res), pch=19, cex=0.2, main=names(mvnlookup)[i+1], type="l", ylim=c(-abslim,abslim), xlab="rho", ylab="resid") 303 | abline(h=0, lty="dotted") 304 | abline(v=0, lty="dotted") 305 | } 306 | 307 | } 308 | 309 | } 310 | 311 | if (F) { 312 | 313 | # heuristically demonstrate that the integral for z_2 is convergent 314 | 315 | load("../data/mvnlookup.rdata") 316 | 317 | library(MASS) 318 | rho <- 0.92 319 | Sigma <- matrix(c(1,rho,rho,1), nrow=2) 320 | titj <- mvrnorm(10^7, mu=c(0,0), Sigma=Sigma) 321 | pipj <- 2 * pnorm(abs(titj), lower.tail=FALSE) 322 | zizj <- qnorm(pipj, lower.tail=FALSE) 323 | round(cov(zizj)[1,2], 4) 324 | mvnlookup[mvnlookup$rho == rho, "z_2"] 325 | 326 | } 327 | 328 | ############################################################################ 329 | --------------------------------------------------------------------------------