diff --git a/.Rbuildignore b/.Rbuildignore index 181d921..93e4be6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -28,3 +28,4 @@ NUL ^codecov\.yml$ ^CLAUDE\.md$ ^references$ +^\.claude$ diff --git a/.claude/settings.local.json b/.claude/settings.local.json new file mode 100644 index 0000000..c7c82df --- /dev/null +++ b/.claude/settings.local.json @@ -0,0 +1,134 @@ +{ + "permissions": { + "allow": [ + "Bash(Rscript:*)", + "Bash(where Rscript)", + "Bash(where:*)", + "Bash(cmd /c \"where Rscript 2>nul || dir /s /b C:\\\\\"Program Files\"\\\\R\\\\*Rscript.exe)", + "Bash(echo not found \")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Program Files\\\\R\\\\*Rscript.exe\"\" 2>nul\")", + "Bash(cmd /c \"dir /s /b C:\\\\R*Rscript.exe 2>nul & dir /s /b C:\\\\Users\\\\caldwellaaron\\\\AppData\\\\Local\\\\R*Rscript.exe 2>nul & dir /s /b C:\\\\Users\\\\caldwellaaron\\\\scoop\\\\*Rscript.exe 2>nul\")", + "Bash(git add:*)", + "Bash(git commit -m \"$\\(cat <<''EOF''\nFix boot_ses_calc to default to no hypothesis test; add ses_calc unit tests\n\nboot_ses_calc now defaults to alternative=\"none\", matching ses_calc behavior.\nWhen no test is requested, statistic/p.value/null.value are omitted from htest\noutput and method string reads \"estimate with CI\" instead of \"test\".\n\nAdded dedicated test file \\(test-ses_calc.R\\) covering ses_calc, boot_ses_calc,\nand internal helpers \\(rbs_calc, ses_compute_agresti, ses_ci_logodds,\nses_ci_fisher, compute_placements, var_concordance_*, to_logodds,\ntransformation round-trips\\).\n\nCo-Authored-By: Claude Opus 4.5 \nEOF\n\\)\")", + "Bash(git checkout:*)", + "Bash(git merge:*)", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-ses_calc.R''\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::test\\(\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::document\\(\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\":*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::document\\(\\)\")", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::test\\(\\)\")", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"testthat::test_file\\(''tests/testthat/test-smd_calc_htest.R''\\)\")", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::test\\(filter=''smd_calc_htest''\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e:*)", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" -e:*)", + "Bash(cmd.exe:*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" test_vignette.R)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" test_vignette2.R)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" test_hl_concordance.R)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.2\\\\bin\\\\Rscript.exe\" -e \"\ndevtools::load_all\\(quiet = TRUE\\)\nx_sep <- 1:5\ny_sep <- 6:10\n\n# Check the raw rbs_calc output\nr_raw <- TOSTER:::rbs_calc\\(x_sep, y_sep, mu = 0, paired = FALSE\\)\ncat\\(''rbs_calc result:'', r_raw, ''\\\\n''\\)\n\np_raw <- \\(r_raw + 1\\) / 2\ncat\\(''p_hat \\(cstat\\):'', p_raw, ''\\\\n''\\)\n\n# Check what ses_compute_agresti returns\nagresti_res <- TOSTER:::ses_compute_agresti\\(x_sep, y_sep, paired = FALSE\\)\ncat\\(''agresti cstat:'', agresti_res$cstat, ''\\\\n''\\)\ncat\\(''agresti rb:'', agresti_res$rb, ''\\\\n''\\)\ncat\\(''boundary_corrected:'', agresti_res$boundary_corrected, ''\\\\n''\\)\ncat\\(''p_hat_original:'', agresti_res$p_hat_original, ''\\\\n''\\)\n\")", + "Bash(dir:*)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"cat\\(''R is working''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"\ndevtools::load_all\\(quiet = TRUE\\)\nx_sep <- 1:5\ny_sep <- 6:10\n\n# Check the raw rbs_calc output\nr_raw <- TOSTER:::rbs_calc\\(x_sep, y_sep, mu = 0, paired = FALSE\\)\ncat\\(''rbs_calc result:'', r_raw, ''\\\\n''\\)\n\np_raw <- \\(r_raw + 1\\) / 2\ncat\\(''p_hat \\(cstat\\):'', p_raw, ''\\\\n''\\)\n\n# Check what ses_compute_agresti returns\nagresti_res <- TOSTER:::ses_compute_agresti\\(x_sep, y_sep, paired = FALSE\\)\ncat\\(''agresti cstat:'', agresti_res$cstat, ''\\\\n''\\)\ncat\\(''agresti rb:'', agresti_res$rb, ''\\\\n''\\)\ncat\\(''boundary_corrected:'', agresti_res$boundary_corrected, ''\\\\n''\\)\ncat\\(''p_hat_original:'', agresti_res$p_hat_original, ''\\\\n''\\)\n\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.1\\\\bin\\\\Rscript.exe\" -e \"\ndevtools::load_all\\(quiet = TRUE\\)\nx_sep <- 1:5\ny_sep <- 6:10\n\n# Check the raw rbs_calc output\nr_raw <- TOSTER:::rbs_calc\\(x_sep, y_sep, mu = 0, paired = FALSE\\)\ncat\\(''rbs_calc result:'', r_raw, ''\\\\n''\\)\n\np_raw <- \\(r_raw + 1\\) / 2\ncat\\(''p_hat \\(cstat\\):'', p_raw, ''\\\\n''\\)\n\n# Check what ses_compute_agresti returns\nagresti_res <- TOSTER:::ses_compute_agresti\\(x_sep, y_sep, paired = FALSE\\)\ncat\\(''agresti cstat:'', agresti_res$cstat, ''\\\\n''\\)\ncat\\(''agresti rb:'', agresti_res$rb, ''\\\\n''\\)\ncat\\(''boundary_corrected:'', agresti_res$boundary_corrected, ''\\\\n''\\)\ncat\\(''p_hat_original:'', agresti_res$p_hat_original, ''\\\\n''\\)\n\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.1\\\\bin\\\\Rscript.exe\" test_debug.R)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.1\\\\bin\\\\Rscript.exe\" -e \"devtools::test\\(filter = ''ses_calc''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.1\\\\bin\\\\Rscript.exe\" -e \"devtools::check\\(\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.4.1\\\\bin\\\\Rscript.exe\" -e \"devtools::check\\(vignettes = FALSE\\)\")", + "Bash(cmd /c \"where Rscript 2>nul & where R 2>nul & dir /s /b \"\"C:\\\\Program Files\\\\R\"\" 2>nul | findstr Rscript\")", + "Bash(cmd /c \"dir /s /b C:\\\\R*.exe 2>nul & dir /s /b \"\"C:\\\\Program Files\\\\R\"\" 2>nul & dir /s /b \"\"C:\\\\Users\\\\caldwellaaron\\\\AppData\\\\Local\\\\Programs\\\\R\"\" 2>nul & dir /s /b \"\"C:\\\\Users\\\\caldwellaaron\\\\scoop\\\\apps\\\\r\"\" 2>nul\")", + "Bash(cmd /c \"reg query HKLM\\\\SOFTWARE\\\\R-core\\\\R /v InstallPath 2>nul & reg query HKCU\\\\SOFTWARE\\\\R-core\\\\R /v InstallPath 2>nul & reg query HKLM\\\\SOFTWARE\\\\R-core\\\\R64 /v InstallPath 2>nul\")", + "Bash(cmd /c \"powershell -Command \"\"Get-ChildItem -Path ''C:\\\\'' -Recurse -Filter ''Rscript.exe'' -ErrorAction SilentlyContinue | Select-Object -First 3 -ExpandProperty FullName\"\"\")", + "Bash(cmd /c \"echo %PATH%\")", + "Bash(powershell:*)", + "Bash(cmd /c \"R --version 2>nul\")", + "Bash(cmd /c \"\"\"C:\\\\Program Files\\\\R\\\\R-4.4.2\\\\bin\\\\Rscript.exe\"\" --version 2>nul\")", + "Bash(cmd /c \"\"\"C:\\\\Program Files\\\\R\\\\R-4.3.0\\\\bin\\\\Rscript.exe\"\" --version 2>nul\")", + "Bash(cmd /c \"rig list 2>nul || where rig 2>nul\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); cat\\(''Package loaded successfully\\\\n''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(python:*)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); testthat::test_file\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/tests/testthat/test-htest.R''\\)\")", + "Bash(grep:*)", + "WebFetch(domain:github.com)", + "WebFetch(domain:raw.githubusercontent.com)", + "Bash(powershell.exe:*)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\":*)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"testthat::test_file\\(''tests/testthat/test-wilcox.R''\\)\")", + "Bash(where.exe:*)", + "Bash(findstr:*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-boot_t_test_trimmed.R''\\)\")", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(\\); devtools::test\\(\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-denom_param.R''\\)\")", + "Bash(cmd /c \"where Rscript 2>nul\")", + "Bash(cmd /c \"where R 2>nul\")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Program Files\\\\R\\\\*.exe\"\" 2>nul | findstr Rscript\")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Program Files\\\\R\"\" 2>nul\")", + "Bash(cmd /c \"where /R C:\\\\ Rscript.exe 2>nul\")", + "Bash(cmd /c \"dir /s /b C:\\\\R\\\\*.exe 2>nul\")", + "Bash(cmd /c \"dir /s /b \"\"%LOCALAPPDATA%\\\\Programs\\\\R\"\" 2>nul\")", + "Bash(cmd /c \"dir /s /b \"\"%USERPROFILE%\\\\AppData\\\\Local\\\\R\"\" 2>nul\")", + "Bash(echo:*)", + "Bash(\"/c/Users/caldwellaaron/AppData/Local/Programs/R/R-4.3.2/bin/Rscript.exe\" -e \"setwd\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-htest_output_updates.R''\\)\")", + "Bash(\"/c/Users/caldwellaaron/AppData/Local/Programs/R/R-4.3.2/bin/Rscript.exe\" -e \"setwd\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-htest.R''\\)\")", + "Bash(\"/c/Users/caldwellaaron/AppData/Local/Programs/R/R-4.3.2/bin/Rscript.exe\" -e \"setwd\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-hodges_lehmann.R''\\)\")", + "Bash(\"/c/Users/caldwellaaron/AppData/Local/Programs/R/R-4.3.2/bin/Rscript.exe\" -e \"setwd\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-perm_t_test.R''\\)\")", + "Bash(\"/c/Users/caldwellaaron/AppData/Local/Programs/R/R-4.3.2/bin/Rscript.exe\" -e \"setwd\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-boot_t_test_trimmed.R''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::build_vignettes\\(pkg = ''C:/Users/caldwellaaron/Documents/GitHub/TOSTER'', install = FALSE\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"knitr::purl\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/vignettes/hypothesis_testing.Rmd'', output = tempfile\\(fileext = ''.R''\\)\\)\")", + "Bash(NOT_CRAN=true \"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\":*)", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"cat\\(''R works\\\\n''\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"cat\\(requireNamespace\\(''TOSTER'', quietly=TRUE\\)\\)\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" diagnose_bm.R)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::document\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::document\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" -e \"cat\\(''R works\\\\n''\\); cat\\(R.version.string, ''\\\\n''\\)\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_ses_bug.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_ses_bug2.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_ses_bug3.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_placement_paired.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_placement_paired2.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_rbs_zeros.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_fix.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_plan_tests.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" -e \"devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER'', filter = ''ses_calc''\\)\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\":*)", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" \"C:/Users/caldwellaaron/Documents/GitHub/TOSTER/junk/test_sleep.R\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" -e \"devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER'', filter = ''tTOST''\\)\")", + "Bash(\"C:/Program Files/R/R-4.4.1/bin/Rscript.exe\" -e \"devtools::test\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\)\")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Program Files\\\\R\\\\Rscript.exe\"\" 2>nul\")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Program Files \\(x86\\)\\\\R\\\\Rscript.exe\"\" 2>nul\")", + "Bash(cmd /c \"dir /s /b \"\"C:\\\\Users\\\\caldwellaaron\\\\AppData\\\\Local\\\\Programs\\\\R\\\\Rscript.exe\"\" 2>nul\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::test\\(filter = ''ses_calc''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e:*)", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\test_phat.R\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\test_phat2.R\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\test_phat3.R\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::test\\(\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\debug_direction.R\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"library\\(TOSTER\\); data\\(sleep\\); res <- ses_calc\\(x=sleep$extra[sleep$group==2], y=sleep$extra[sleep$group==1], paired=TRUE, ses=''cstat'', se_method=''agresti''\\); cat\\(as.numeric\\(res$estimate\\)\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\check_installed.R\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" \"C:\\\\Users\\\\caldwellaaron\\\\Documents\\\\GitHub\\\\TOSTER\\\\junk\\\\debug_direction2.R\")", + "Bash(\"C:/Program Files/R/R-4.4.2/bin/Rscript.exe\" -e \"devtools::test\\(filter = ''ses_calc''\\)\")", + "Bash(Rscript.exe:*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::test\\(filter = ''ses_calc''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"testthat::test_file\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/tests/testthat/test-ses_calc.R''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); testthat::test_file\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/tests/testthat/test-ses_calc.R''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); testthat::test_file\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/tests/testthat/test-brunner_munzel.R''\\)\")", + "Bash(\"C:\\\\Program Files\\\\R\\\\R-4.5.1\\\\bin\\\\Rscript.exe\" -e \"devtools::load_all\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER''\\); testthat::test_file\\(''C:/Users/caldwellaaron/Documents/GitHub/TOSTER/tests/testthat/test-brunner_munzel_scale.R''\\)\")", + "Bash(export PATH=\"/c/Program Files/R/R-4.5.1/bin:$PATH\")", + "Bash(cmd //c \"where Rscript\")", + "Bash(cmd //c \"dir /s /b \"\"C:\\\\Program Files\\\\R\\\\*Rscript.exe\"\"\")", + "Bash(R:*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"devtools::load_all\\(\\); testthat::test_file\\(''tests/testthat/test-boot_t_test_variance_fix.R''\\)\")", + "Bash(NOT_CRAN=true \"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\":*)", + "Bash(\"/c/Program Files/R/R-4.5.1/bin/Rscript.exe\":*)", + "Bash(ls:*)", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" -e \"git diff HEAD -- tests/testthat/test-smd_calc_htest.R\")", + "Bash(\"C:/Program Files/R/R-4.5.1/bin/Rscript.exe\" junk/diag_bca.R)", + "Bash(git -C /Users/aaroncaldwell/Documents/GitHub/TOSTER check-ignore vignettes/robustTOST.html)" + ] + } +} diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index a010cb1..12f20c5 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -27,6 +27,7 @@ jobs: env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_KEEP_PKG_SOURCE: yes + NOT_CRAN: true steps: - uses: actions/checkout@v4 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 0ab748d..484a851 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -14,6 +14,7 @@ jobs: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + NOT_CRAN: true steps: - uses: actions/checkout@v4 diff --git a/.gitignore b/.gitignore index 359e462..da28c61 100644 --- a/.gitignore +++ b/.gitignore @@ -18,3 +18,4 @@ NUL cran-comments.md Rplots.pdf references/working/ +.claude/ diff --git a/CLAUDE.md b/CLAUDE.md index f116e9b..fd607ef 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -8,6 +8,12 @@ Implements the two one-sided tests (TOST) procedure to test equivalence for t-te Primary citation: Lakens (2017) +## Workflow + +**Always work directly in the local repository** — edit files in place, run tests, and commit from the main checkout. Do NOT create git worktrees or separate working directories. This keeps the workflow simple and changes immediately visible in the user's IDE/editor. + +**Non-production files**: If separate R scripts, markdown files, or other working files are needed during development but are not intended for the package itself (e.g., scratch analyses, exploratory scripts, notes), place them in the `junk/` folder. This keeps the package source tree clean. + ## Development Commands ```r @@ -19,6 +25,20 @@ devtools::document() # Generate documentation from roxygen2 ## Code Style +### R Script Section Headings +Place the section title after a `#` (or `##` for sub-sections) followed by at least four trailing dashes (`-`), equal signs (`=`), or hashtags (`#`). Do NOT place lines of `#` signs before and after section headings. + +```r +# Good +# Load data -------- +## Clean variables ---- + +# Bad +###################### +# Load data +###################### +``` + ### Naming Conventions - **Main functions**: `snake_case` (e.g., `t_TOST`, `boot_t_TOST`, `brunner_munzel`, `wilcox_TOST`) - **Legacy functions**: `camelCase` or mixed (e.g., `TOSTone`, `TOSTpaired`, `powerTOSTtwo`) diff --git a/DESCRIPTION b/DESCRIPTION index d5578ea..06a57f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,5 +40,5 @@ LazyData: true Config/testthat/edition: 3 Depends: R (>= 3.5) -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Language: en-US diff --git a/NAMESPACE b/NAMESPACE index 5f6270c..c0c6ec5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,8 @@ S3method(boot_log_TOST,default) S3method(boot_log_TOST,formula) S3method(boot_ses_calc,default) S3method(boot_ses_calc,formula) +S3method(boot_ses_test,default) +S3method(boot_ses_test,formula) S3method(boot_smd_calc,default) S3method(boot_smd_calc,formula) S3method(boot_t_TOST,default) @@ -48,6 +50,7 @@ export(boot_compare_smd) export(boot_cor_test) export(boot_log_TOST) export(boot_ses_calc) +export(boot_ses_test) export(boot_smd_calc) export(boot_t_TOST) export(boot_t_test) @@ -86,11 +89,13 @@ export(power_eq_f) export(power_t_TOST) export(power_twoprop) export(power_z_cor) +export(rank_diff) export(rbs) export(ses_calc) export(simple_htest) export(smd_calc) export(t_TOST) +export(trans_rank_prob) export(tsum_TOST) export(twoprop_test) export(wilcox_TOST) @@ -110,6 +115,7 @@ importFrom(lifecycle,deprecated) importFrom(stats,complete.cases) importFrom(stats,cor) importFrom(stats,density) +importFrom(stats,dlogis) importFrom(stats,dnorm) importFrom(stats,dt) importFrom(stats,integrate) diff --git a/NEWS.md b/NEWS.md index ab42d02..3583dda 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,37 @@ NEWS ## New Features +- New `trans_rank_prob()` function for transforming probability-scale effect sizes + between four scales: probability (concordance), difference (rank-biserial), + log-odds, and odds. Supports bidirectional transformation via `from` and `to` + arguments with delta-method standard errors and monotonic CI endpoint mapping. + +- `brunner_munzel()` gains a `scale` argument to report results on alternative + scales ("probability", "difference", "logodds", "odds") without changing the + underlying test. The default `scale = "probability"` preserves existing behavior. + +- `ses_calc()` estimate labels now use probability notation (e.g., + `P(X>Y) - P(X0)` notation (where Z = X - Y); + one-sample labels use `P(X>0)`. + + +- Effect size calculators now support hypothesis testing and `htest` output: + - `ses_calc` and `boot_ses_calc` updated with `output`, `alternative`, and `null.value` arguments + - Default output is now `"htest"` class; use `output = "data.frame"` for legacy format + - Supports `"two.sided"`, `"less"`, `"greater"`, `"equivalence"`, and `"minimal.effect"` alternatives + - New Agresti/Lehmann placement-based SE method (`se_method = "agresti"`) with log-odds scale hypothesis testing + - Continuity correction for boundary cases (complete separation) + - `smd_calc` and `boot_smd_calc` updated with `output`, `alternative`, `null.value`, and `test_method` arguments + - Default output is now `"htest"` class; use `output = "data.frame"` for legacy format + - Supports the same alternative hypothesis options as `ses_calc` + - `test_method` argument (`"z"` or `"t"`) controls the reference distribution for `smd_calc` + - Degrees of freedom included in output when `test_method = "t"` + - Bootstrap p-values for `boot_smd_calc` computed from empirical distribution + - New `denom` argument for direct denominator selection (`"z"`, `"rm"`, `"pooled"`, `"avg"`, `"glass1"`, `"glass2"`), overriding `glass`, `rm_correction`, and `var.equal` as needed; informative messages on conflicts - Added `hodges_lehmann` function for robust location testing - Implements Hodges-Lehmann estimators (HL1 for one-sample/paired, HL2 for two-sample) - Supports exact permutation, randomization, and asymptotic (KDE-based) inference @@ -19,8 +50,49 @@ NEWS - Handles null values (single or equivalence bounds) as reference lines - Automatically handles two-sample t-test estimates by computing mean difference +- Added BCa (bias-corrected and accelerated) bootstrap confidence intervals as a new `boot_ci = "bca"` option for: + - `boot_t_test`, `boot_t_TOST`, `boot_log_TOST`, `boot_smd_calc`, `boot_ses_calc`, and `boot_cor_test` + - BCa intervals provide second-order accuracy by correcting for bias and skewness in the bootstrap distribution + - Acceleration factor computed via leave-one-out jackknife (pooled jackknife for two-sample designs) + - Informative errors for degenerate cases with suggestion to use `boot_ci = "perc"` as fallback + ## Improvements +- **Correlation SE improvements** for `z_cor_test()` and `corsum_test()`: + - Spearman's rho now uses the Bonett-Wright ρ-dependent SE formula + (`sqrt((1 + r^2/2) / (n - 3))`) instead of the fixed 1.06 constant, + providing better calibration across the full range of rho. + - `z_cor_test()` gains a `se_method` argument (`"analytic"` or `"jackknife"`) + for computing the standard error via leave-one-out resampling on the + Fisher z scale. The jackknife SE is used consistently for both the test + statistic and the confidence interval. + - Both functions now return `stderr` as a named vector with `z.se` + (Fisher z scale, used for inference) and `cor.se` (delta method SE on the + correlation scale, for descriptive purposes). + - The `method` string in the returned `htest` object now indicates the SE + type used (e.g., `"Pearson's product-moment correlation with approximate SE"` + or `"Spearman's rank correlation rho with jackknifed SE"`). + +- `simple_htest()`, `boot_t_test()`, `perm_t_test()`, and `hodges_lehmann()` + now produce more informative estimate labels that indicate the direction of + calculation (e.g., `"mean difference (treatment - control)"` when using the + formula interface). +- For two-sample mean-based tests (`simple_htest` with t-test, `boot_t_test`, + `perm_t_test`), the mean difference is now appended as a third element of + `$estimate`, while preserving existing group means at positions 1-2 + (backwards-compatible). +- Paired test estimates are labeled to clarify the differencing operation, + e.g., `"mean of the differences (z = x - y)"`. +- Wilcoxon/Mann-Whitney estimates in `simple_htest()` are labeled as + `"Hodges-Lehmann estimate"` with direction indicated. +- `hodges_lehmann()` estimate labels updated for clarity: `"pseudomedian of x"` + for one-sample, `"Hodges-Lehmann estimate (x - y)"` for two-sample, and + `"Hodges-Lehmann estimate (z = x - y)"` for paired tests. +- Trimmed mean labels in `boot_t_test()` and `perm_t_test()` now include the + trimming proportion, e.g., `"trimmed mean difference (x - y, tr = 0.1)"`. +- A `$sample_size` element (named numeric vector) is now included in the + returned `htest` object for all four functions. For two-sample formula calls, + names reflect the actual factor levels. - **Permutation test terminology**: Clarified distinction between "Exact Permutation" (all permutations enumerated) and "Randomization" (permutations sampled with replacement) tests across `perm_t_test`, `hodges_lehmann`, and `brunner_munzel` - **p_method auto-selection**: Added intelligent default for `p_method` argument in permutation-based functions: - `NULL` (default): Automatically selects "exact" for exact permutation tests and "plusone" for randomization tests diff --git a/R/boot_cor_test.R b/R/boot_cor_test.R index 1e3cdff..078c15d 100644 --- a/R/boot_cor_test.R +++ b/R/boot_cor_test.R @@ -17,8 +17,14 @@ #' #' Can be abbreviated. #' @param boot_ci type of bootstrap confidence interval: -#' * "basic": basic/empirical bootstrap CI -#' * "perc": percentile bootstrap CI (default) +#' * "basic": basic/empirical bootstrap CI (default) +#' * "perc": percentile bootstrap CI +#' * "bca": bias-corrected and accelerated bootstrap CI. Provides second-order +#' accuracy by correcting for bias and skewness, but requires additional +#' computation via the jackknife (n extra evaluations of the statistic). +#' * "stud": studentized (bootstrap-t) CI. Uses pivot statistics on the Fisher z +#' scale with analytical SEs. Only available for `method = "pearson"`, +#' `"kendall"`, or `"spearman"`. #' @param R number of bootstrap replications (default = 1999). #' @param ... additional arguments passed to correlation functions, such as: #' * tr: trim for Winsorized correlation (default = 0.2) @@ -26,7 +32,27 @@ #' #' @details #' This function uses bootstrap methods to calculate correlation coefficients and their -#' confidence intervals. P-values are calculated from a re-sampled null distribution. +#' confidence intervals. P-values are computed by inverting the selected CI method, +#' which guarantees that `p < alpha` if and only if the corresponding CI excludes the +#' null value. +#' +#' **P-value computation by CI method:** +#' +#' * `boot_ci = "perc"`: p-values are computed from the raw bootstrap distribution +#' (proportion of replicates beyond the null). This is the original approach from +#' Wilcox (2017). +#' +#' * `boot_ci = "basic"`: p-values use the reflected bootstrap distribution +#' (`2 * est - bvec`), which is the exact inversion of the basic CI. +#' +#' * `boot_ci = "bca"`: p-values are derived from the BCa probability transformation, +#' using the same bias correction and acceleration parameters as the BCa CI. +#' +#' * `boot_ci = "stud"`: p-values are derived from the bootstrap pivot distribution +#' on the Fisher z scale. Each replicate's pivot is `(z_star - z_obs) / se_star`, +#' where `se_star` is the analytical SE. This method is only available for +#' Pearson, Kendall, and Spearman correlations, since robust methods lack +#' analytical SEs on the Fisher z scale. #' #' The bootstrap correlation methods in this package offer two robust correlations beyond #' the standard methods: @@ -63,7 +89,7 @@ #' * **p.value**: the bootstrap p-value of the test. #' * **parameter**: the number of observations used in the test. #' * **conf.int**: a bootstrap confidence interval for the correlation coefficient. -#' * **estimate**: the estimated correlation coefficient, with name "cor", "tau", "rho", "pb", or "wincor" +#' * **estimate**: the estimated correlation coefficient, with name "r", "tau", "rho", "pb", or "wincor" #' corresponding to the method employed. #' * **stderr**: the bootstrap standard error of the correlation coefficient. #' * **null.value**: the value(s) of the correlation under the null hypothesis. @@ -71,6 +97,7 @@ #' * **method**: a character string indicating which bootstrapped correlation was measured. #' * **data.name**: a character string giving the names of the data. #' * **boot_res**: vector of bootstrap correlation estimates. +#' * **boot_ci**: character string indicating which bootstrap CI method was used. #' * **call**: the matched call. #' #' @examples @@ -116,7 +143,7 @@ boot_cor_test <- function(x, "winsorized", "bendpercent"), alpha = 0.05, null = 0, - boot_ci = c("basic","perc"), + boot_ci = c("bca","stud", "basic", "perc"), R = 1999, ...) { boot_ci = match.arg(boot_ci) @@ -124,6 +151,14 @@ boot_cor_test <- function(x, alternative = match.arg(alternative) method = match.arg(method) + + if (boot_ci == "stud" && method %in% c("winsorized", "bendpercent")) { + stop( + "Studentized bootstrap requires an analytical SE and is only available ", + "for method = 'pearson', 'kendall', or 'spearman'.", + call. = FALSE + ) + } nboot = R null.value = null if(!is.vector(x) || !is.vector(y)){ @@ -184,96 +219,144 @@ boot_cor_test <- function(x, bvec <- apply(data, 1, .corboot_wincor, x, y, ...) # get bootstrap results corr } - } else { est <- cor(x, y, method = method) data <- matrix(sample(n, size=n*nboot, replace=TRUE), nrow=nboot) bvec <- apply(data, 1, .corboot, x, y, method = method, ...) # get bootstrap results corr } + alpha2 = ifelse(alternative != "two.sided", alpha*2, alpha) + + # Compute pivots for studentized bootstrap + tvec <- NULL + se_obs <- NULL + if (boot_ci == "stud") { + se_obs <- .fisher_z_se(est, n, method) + se_star <- .fisher_z_se(bvec, n, method) + z_star <- atanh(bvec) + z_obs <- atanh(est) + tvec <- (z_star - z_obs) / se_star + } + + # Jackknife for BCa (if needed) + z0 <- NULL + acc <- NULL + if (boot_ci == "bca") { + jack_est <- numeric(n) + for (j in seq_len(n)) { + if (method == "bendpercent") { + jack_est[j] <- pbcor(x[-j], y[-j], ...) + } else if (method == "winsorized") { + jack_est[j] <- wincor(x[-j], y[-j], ...) + } else { + jack_est[j] <- cor(x[-j], y[-j], method = method) + } + } + # Pre-compute BCa parameters for p-value use + bca_par <- bca_params(bvec, est, jack_est) + z0 <- bca_par$z0 + acc <- bca_par$acc + } + + # CI computation boot.cint = switch(boot_ci, "basic" = basic(bvec, t0 = est, alpha2), - "perc" = perc(bvec, alpha2)) - #quantile(bvec, c((1 - ci) / 2, 1 - (1 - ci) / 2)) + "perc" = perc(bvec, alpha2), + "bca" = bca_ci(boots_est = bvec, t0 = est, + jack_est = jack_est, alpha = alpha2), + "stud" = stud_ci(tvec, t0_z = atanh(est), + se_obs = se_obs, alpha = alpha2)) attr(boot.cint, "conf.level") <- ci - # pvalue - ## note method different than Efron (e.g., t-test, SMDs, etc) - ## Dervied from work of Wilcox - if(alternative == "two.sided"){ - phat <- (sum(bvec < null.value)+.5*sum(bvec==null.value))/nboot - sig <- 2 * min(phat, 1 - phat) - } - if(alternative == "greater"){ - sig <- 1 - sum(bvec >= null.value)/nboot - } - if(alternative == "less"){ - sig <- 1 - sum(bvec <= null.value)/nboot - } - if(alternative == "equivalence"){ - #sig2 <- 1 - sum(bvec >= -1*null.value)/nboot - #sig = max(sig,sig2) - sig1 = 1 - sum(bvec >= min(null.value))/nboot - sig2 = 1 - sum(bvec <= max(null.value))/nboot - sig = max(sig1,sig2) - } - if(alternative == "minimal.effect"){ - #sig2 <- 1 - sum(bvec >= -1*null.value)/nboot - #sig = max(sig,sig2) - sig1 = 1 - sum(bvec >= max(null.value))/nboot - sig2 = 1 - sum(bvec <= min(null.value))/nboot - sig = min(sig1,sig2) + + # P-value computation (method-consistent) + if (alternative %in% c("two.sided", "greater", "less")) { + sig <- boot_pvalue(bvec = bvec, est = est, null = null.value, + alternative = alternative, boot_ci = boot_ci, + tvec = tvec, se_obs = se_obs, + z0 = z0, acc = acc, nboot = nboot, + z_transform= TRUE) + } else if (alternative == "equivalence") { + sig1 <- boot_pvalue(bvec = bvec, est = est, null = min(null.value), + alternative = "greater", boot_ci = boot_ci, + tvec = tvec, se_obs = se_obs, + z0 = z0, acc = acc, nboot = nboot, + z_transform= TRUE) + sig2 <- boot_pvalue(bvec = bvec, est = est, null = max(null.value), + alternative = "less", boot_ci = boot_ci, + tvec = tvec, se_obs = se_obs, + z0 = z0, acc = acc, nboot = nboot, + z_transform= TRUE) + sig <- max(sig1, sig2) + } else if (alternative == "minimal.effect") { + sig1 <- boot_pvalue(bvec = bvec, est = est, null = max(null.value), + alternative = "greater", boot_ci = boot_ci, + tvec = tvec, se_obs = se_obs, + z0 = z0, acc = acc, nboot = nboot, + z_transform= TRUE) + sig2 <- boot_pvalue(bvec = bvec, est = est, null = min(null.value), + alternative = "less", boot_ci = boot_ci, + tvec = tvec, se_obs = se_obs, + z0 = z0, acc = acc, nboot = nboot, + z_transform= TRUE) + sig <- min(sig1, sig2) } + # CI method label for method string + ci_label <- switch(boot_ci, + "basic" = "(basic)", + "perc" = " (percentile)", + "bca" = " (BCa)", + "stud" = " (studentized)") if (method == "pearson") { - # Pearson # Fisher - method2 <- "Bootstrapped Pearson's product-moment correlation" + method2 <- paste0("Bootstrapped Pearson's product-moment correlation", ci_label) names(null.value) = rep("correlation",length(null.value)) - rfinal = c(cor = est) + rfinal = c(r = est) } if (method == "spearman") { - method2 <- "Bootstrapped Spearman's rank correlation rho" - # # Fieller adjusted + method2 <- paste0("Bootstrapped Spearman's rank correlation rho", ci_label) rfinal = c(rho = est) names(null.value) = rep("rho",length(null.value)) - } if (method == "kendall") { - method2 <- "Bootstrapped Kendall's rank correlation tau" - # # Fieller adjusted + method2 <- paste0("Bootstrapped Kendall's rank correlation tau", ci_label) rfinal = c(tau = est) names(null.value) = rep("tau",length(null.value)) - } if (method == "bendpercent") { - method2 <- "Bootstrapped percentage bend correlation pb" - # # Fieller adjusted + method2 <- paste0("Bootstrapped percentage bend correlation pb", ci_label) rfinal = c(pb = est) names(null.value) = rep("pb",length(null.value)) - } if (method == "winsorized") { - method2 <- "Bootstrapped Winsorized correlation wincor" - # # Fieller adjusted + method2 <- paste0("Bootstrapped Winsorized correlation wincor", ci_label) rfinal = c(wincor = est) names(null.value) = rep("wincor",length(null.value)) - } N = n names(N) = "N" + + # SE: for stud, report both bootstrap SE and analytical z-scale SE + if (boot_ci == "stud") { + se_out <- c(boot.se = sd(bvec, na.rm = TRUE), z.se = se_obs) + } else { + se_out <- sd(bvec, na.rm = TRUE) + } + # Store as htest rval <- list(p.value = sig, parameter = N, conf.int = boot.cint, estimate = rfinal, - stderr = sd(bvec,na.rm=TRUE), + stderr = se_out, null.value = null.value, alternative = alternative, method = method2, data.name = DNAME, boot_res = bvec, + boot_ci = boot_ci, call = match.call()) class(rval) <- "htest" return(rval) diff --git a/R/boot_log_TOST.R b/R/boot_log_TOST.R index 27757c4..d32c205 100644 --- a/R/boot_log_TOST.R +++ b/R/boot_log_TOST.R @@ -25,7 +25,7 @@ #' @param alpha alpha level (default = 0.05). #' @param null the ratio value under the null hypothesis (default = 1). #' @param boot_ci method for bootstrap confidence interval calculation: "stud" (studentized, default), -#' "basic" (basic bootstrap), or "perc" (percentile bootstrap). +#' "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap). #' @param R number of bootstrap replications (default = 1999). #' @param ... further arguments to be passed to or from methods. #' @@ -42,10 +42,30 @@ #' The bootstrap procedure follows these steps: #' - Log-transform the data #' - Perform resampling with replacement to generate bootstrap samples -#' - For each bootstrap sample, calculate test statistics and effect sizes -#' - Use the distribution of bootstrap results to compute p-values and confidence intervals -#' - Back-transform for the ratio of means +#' - For each bootstrap sample, calculate test statistics and effect sizes on the log scale +#' - Compute p-values and confidence intervals using the selected bootstrap method +#' - Back-transform confidence intervals for the ratio of means #' +#' ## Bootstrap Confidence Interval Methods +#' +#' Four types of bootstrap confidence intervals are available via the `boot_ci` argument: +#' - **Studentized ("stud")**: Uses the bootstrap distribution of pivotal t-statistics +#' to account for variability in standard error estimates. This is the default. +#' - **Basic/Empirical ("basic")**: Reflects the bootstrap distribution of estimates +#' around the observed value. +#' - **Percentile ("perc")**: Uses percentiles of the bootstrap distribution directly. +#' - **Bias-corrected and accelerated ("bca")**: Corrects for both bias and skewness +#' in the bootstrap distribution using jackknife-based acceleration. +#' +#' ## Bootstrap P-values +#' +#' The p-value for each test (two-tailed and both one-sided) is computed using +#' the method that matches the selected `boot_ci`, ensuring that p < alpha if and +#' only if the corresponding confidence interval excludes the null value +#' (CI inversion principle). Previously, all bootstrap CI methods used the +#' studentized (pivot) p-value, which could produce p-values inconsistent with +#' non-studentized CIs. All computations are performed on the log scale, then +#' back-transformed. #' #' Note that all input data must be positive (ratio scale with a true zero) since log transformation #' is applied. The function will stop with an error if any negative values are detected. @@ -121,7 +141,7 @@ boot_log_TOST.default <- function(x, eqb = 1.25, alpha = 0.05, null = 1, - boot_ci = c("stud","basic", "perc"), + boot_ci = c("stud","basic", "perc", "bca"), R = 1999, ...){ hypothesis = match.arg(hypothesis) boot_ci = match.arg(boot_ci) @@ -393,27 +413,102 @@ if(!paired){ tstat = nullTOST$TOST$t[1] tstat_l = nullTOST$TOST$t[2] tstat_u = nullTOST$TOST$t[3] - #m_vec = append(m_vec, nullTOST$effsize$estimate[1]) - #d_vec = append(d_vec, nullTOST$effsize$estimate[2]) - boot.pval <- 2 * min(mean(TSTAT <= tstat), mean(TSTAT > tstat)) + boot.se = sd(m_vec) + d.se = sd(exp(m_vec)) - if(hypothesis == "EQU"){ - p_l = mean(TSTAT > tstat_l) - p_u = mean(TSTAT < tstat_u) - } else{ - p_l = mean(TSTAT < tstat_l) - p_u = mean(TSTAT > tstat_u) + # Jackknife for BCa (if needed) + if (boot_ci == "bca") { + if (is.null(y)) { + # Paired (already converted to differences on log scale) + n_jack <- nx + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- log_pair( + x = x[-j], + hypothesis = hypothesis, + eqb = eqb, + alpha = alpha, + null = null + ) + jack_est[j] <- res_jack$effsize$estimate[1] + } + } else { + # Two-sample: pooled jackknife (x and y are already log-transformed) + n_jack <- nx + ny + jack_est <- numeric(n_jack) + for (j in seq_len(nx)) { + res_jack <- log_TOST(x = exp(x[-j]), + y = exp(y), + hypothesis = hypothesis, + paired = paired, + var.equal = var.equal, + eqb = eqb, + alpha = alpha, + null = null) + jack_est[j] <- res_jack$effsize$estimate[1] + } + for (j in seq_len(ny)) { + res_jack <- log_TOST(x = exp(x), + y = exp(y[-j]), + hypothesis = hypothesis, + paired = paired, + var.equal = var.equal, + eqb = eqb, + alpha = alpha, + null = null) + jack_est[nx + j] <- res_jack$effsize$estimate[1] + } + } + } + + # Pre-compute BCa parameters for p-value use + z0 <- NULL; acc <- NULL + if (boot_ci == "bca") { + bca_par <- bca_params(m_vec, nullTOST$effsize$estimate[1], jack_est) + z0 <- bca_par$z0; acc <- bca_par$acc } - boot.se = sd(m_vec) - d.se = sd(exp(m_vec)) boot.cint <- switch(boot_ci, "stud" = stud(boots_est = m_vec, boots_se = se_vec, se0=nullTOST$effsize$SE[1], t0 = nullTOST$effsize$estimate[1], - alpha), + alpha*2), "basic" = basic(m_vec, t0 = nullTOST$effsize$estimate[1], alpha*2), - "perc" = perc(m_vec, alpha*2)) + "perc" = perc(m_vec, alpha*2), + "bca" = bca_ci(boots_est = m_vec, t0 = nullTOST$effsize$estimate[1], + jack_est = jack_est, alpha = alpha*2)) + + # P-value computation (method-consistent with CI) on log scale + log_est <- nullTOST$effsize$estimate[1] + se_obs_log <- nullTOST$effsize$SE[1] + log_null_twosided <- log(null) + log_low <- nullTOST$eqb$low_eq[1] # = log(low_eqbound) + log_high <- nullTOST$eqb$high_eq[1] # = log(high_eqbound) + + boot.pval <- boot_pvalue(bvec = m_vec, est = log_est, null = log_null_twosided, + alternative = "two.sided", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_log, + z0 = z0, acc = acc, nboot = R) + + if(hypothesis == "EQU"){ + p_l <- boot_pvalue(bvec = m_vec, est = log_est, null = log_low, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_log, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = log_est, null = log_high, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_log, + z0 = z0, acc = acc, nboot = R) + } else { + p_l <- boot_pvalue(bvec = m_vec, est = log_est, null = log_low, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_log, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = log_est, null = log_high, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_log, + z0 = z0, acc = acc, nboot = R) + } d.cint = exp(boot.cint) #d.cint <- switch(boot_ci, # "basic" = basic(d_vec, t0 = nullTOST$effsize$estimate[2], alpha*2), @@ -520,7 +615,7 @@ boot_log_TOST.formula <- function (formula, data, subset, na.action, ...){ || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -528,7 +623,7 @@ boot_log_TOST.formula <- function (formula, data, subset, na.action, ...){ message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) diff --git a/R/boot_ses_calc.R b/R/boot_ses_calc.R index fc8be27..826e05f 100644 --- a/R/boot_ses_calc.R +++ b/R/boot_ses_calc.R @@ -25,8 +25,9 @@ #' or shift (for independent samples) is to be estimated (default = 0). #' @param se_method a character string specifying the method for computing standard errors #' within each bootstrap sample: -#' - "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation. -#' This method has better asymptotic properties. +#' - "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation +#' with the log-odds working scale, which has better asymptotic properties +#' (faster convergence to normality per Agresti, 1980). #' - "fisher": Uses the legacy Fisher z-transformation method. Retained for backward #' compatibility. #' @param output a character string specifying the output format: @@ -54,7 +55,9 @@ #' - Calculate the raw effect size using the original data #' - Create R bootstrap samples by resampling with replacement from the original data #' - Calculate the effect size for each bootstrap sample -#' - Apply the Fisher z-transformation to stabilize variance for rank-biserial correlation values +#' - Transform bootstrap estimates to the working scale for CI construction: +#' the log-odds scale when `se_method = "agresti"` (default), or Fisher z +#' when `se_method = "fisher"` #' - Calculate confidence intervals using the specified method #' - Back-transform the confidence intervals to the original scale #' - Convert to the requested effect size measure (if not rank-biserial) @@ -72,21 +75,40 @@ #' #' ## Bootstrap Confidence Interval Methods #' -#' Three bootstrap confidence interval methods are available: -#' - **Basic bootstrap ("basic")**: Uses the empirical distribution of bootstrap estimates -#' - **Studentized bootstrap ("stud")**: Accounts for the variability in standard error estimates +#' Four bootstrap confidence interval methods are available via the `boot_ci` argument: +#' - **Basic bootstrap ("basic")**: Reflects the bootstrap distribution of estimates +#' around the observed value +#' - **Studentized bootstrap ("stud")**: Uses the bootstrap distribution of pivotal +#' t-statistics to account for variability in standard error estimates. This is the +#' default and usually provides the most accurate coverage. #' - **Percentile bootstrap ("perc")**: Uses percentiles of the bootstrap distribution directly +#' - **Bias-corrected and accelerated ("bca")**: Corrects for both bias and skewness in the +#' bootstrap distribution using jackknife-based acceleration +#' +#' All CI methods operate on a working scale that is better suited +#' to symmetric bootstrap distributions: the log-odds scale when +#' `se_method = "agresti"` (default), or the Fisher z scale when +#' `se_method = "fisher"`. Confidence limits are then back-transformed to the +#' requested effect size scale. #' #' ## Hypothesis Testing #' -#' When an alternative other than "two.sided" is specified, or when null.value is not the +#' When an alternative other than "none" is specified, or when null.value is not the #' default, the function performs bootstrap hypothesis testing. For equivalence and minimal #' effect testing, specify null.value as a vector of two values (lower and upper bounds). #' +#' The p-value is computed using the method that matches the selected `boot_ci`, +#' ensuring that p < alpha if and only if the corresponding confidence interval +#' excludes the null value (CI inversion principle). Previously, all bootstrap +#' CI methods used the studentized (pivot) p-value, which could produce p-values +#' inconsistent with non-studentized CIs. The null value is converted to the +#' working scale (log-odds or Fisher z) before computing the p-value, maintaining +#' consistency with the CI construction. +#' #' For different alternatives, the p-values are calculated as follows: -#' * "two.sided": Proportion of bootstrap statistics at least as extreme as the observed statistic -#' * "less": Proportion of bootstrap statistics less than or equal to the observed statistic -#' * "greater": Proportion of bootstrap statistics greater than or equal to the observed statistic +#' * "two.sided": Two-tailed p-value from the bootstrap distribution +#' * "less": One-sided p-value for the hypothesis that the true value is less than the null +#' * "greater": One-sided p-value for the hypothesis that the true value is greater than the null #' * "equivalence": Maximum of two one-sided p-values (for lower and upper bounds) #' * "minimal.effect": Minimum of two one-sided p-values (for lower and upper bounds) #' @@ -100,6 +122,30 @@ #' #' For detailed information on calculation methods, see `vignette("robustTOST")`. #' +#' ## Edge Cases +#' +#' - **Complete separation**: When one group entirely dominates the other +#' (concordance probability = 0 or 1), the bootstrap distribution collapses +#' and CIs become degenerate. The function stops with an informative error +#' directing users to [ses_calc()] with `se_method = "agresti"` for +#' asymptotic inference. This condition is detected before resampling begins. +#' - **Near-complete separation**: When the observed rb is close to +/-1 but +#' not exactly at the boundary, the working-scale transformation (log-odds +#' or Fisher z) helps stabilize the bootstrap but coverage may still +#' degrade. The function issues a message when bootstrap replicates contain +#' infinite values after transformation, which is a symptom of this problem. +#' - **Why the bootstrap fails at boundaries**: The rank-biserial is bounded +#' on \[-1, 1\]. When the observed value is near a boundary, resampled +#' values pile up at the boundary, producing a distribution that is not +#' well-approximated by the symmetric bootstrap CI methods (basic, +#' percentile, studentized). The log-odds and Fisher z working scales +#' mitigate this by mapping \[-1, 1\] to the real line, but the mapping +#' itself becomes unstable as rb approaches +/-1. +#' - **Recommendation**: For data with complete or near-complete separation, +#' prefer the asymptotic Agresti/Lehmann interval from [ses_calc()], which +#' handles boundary behavior more gracefully through the placement-based +#' variance estimator. +#' #' @return #' If `output = "htest"` (default), returns a list with class `"htest"` containing: #' - estimate: The effect size estimate calculated from the original data @@ -149,13 +195,14 @@ #' R = 99) #' #' # Example 4: Paired samples -#' data(sleep) -#' with(sleep, boot_ses_calc(x = extra[group == 1], -#' y = extra[group == 2], -#' paired = TRUE, -#' ses = "rb", -#' alternative = "greater", -#' R = 99)) +#' set.seed(42) +#' pre <- c(4.5, 5.2, 3.8, 6.1, 4.9, 5.7, 3.6, 5.0, 4.3, 6.5) +#' post <- c(5.1, 4.9, 4.5, 5.8, 5.5, 5.2, 4.3, 5.4, 4.0, 6.2) +#' boot_ses_calc(x = pre, y = post, +#' paired = TRUE, +#' ses = "rb", +#' alternative = "greater", +#' R = 99) #' #' # Example 5: Using formula notation #' data(mtcars) @@ -184,7 +231,7 @@ boot_ses_calc <- function(x, ..., ses = "rb", alpha = 0.05, mu = 0, - boot_ci = c("basic","stud","perc"), + boot_ci = c("bca", "stud", "basic", "perc"), R = 1999, se_method = c("agresti", "fisher"), output = c("htest", "data.frame"), @@ -204,7 +251,7 @@ boot_ses_calc.default = function(x, ses = c("rb","odds","logodds","cstat"), alpha = 0.05, mu = 0, - boot_ci = c("basic","stud", "perc"), + boot_ci = c("basic","stud", "perc","bca"), R = 1999, se_method = c("agresti", "fisher"), output = c("htest", "data.frame"), @@ -218,6 +265,18 @@ boot_ses_calc.default = function(x, output = match.arg(output) alternative = match.arg(alternative) + # Working-scale transformations + # Fisher z: atanh(rb), back-transform: tanh(z) + # Log-odds: log((1+rb)/(1-rb)) = 2*atanh(rb), back-transform: tanh(lo/2) + if (se_method == "fisher") { + to_working <- function(rb) atanh(rb) + from_working <- function(w) tanh(w) + } else { + # agresti: log-odds scale + to_working <- function(rb) log((1 + rb) / (1 - rb)) # = 2 * atanh(rb) + from_working <- function(w) (exp(w) - 1) / (exp(w) + 1) # = tanh(w/2) + } + # Set default null.value based on effect size type if (is.null(null.value)) { null.value <- switch(ses, @@ -264,8 +323,10 @@ boot_ses_calc.default = function(x, if (abs(rb) >= 1) { return(NA) } - se_z <- se_rb / (1 - rb^2) - return(se_z) + # Delta method: SE on log-odds scale + # d/d(rb) log((1+rb)/(1-rb)) = 2/(1-rb^2) + se_logodds <- 2 * se_rb / (1 - rb^2) + return(se_logodds) } else { if (paired || is.null(y_boot)) { n1 <- if(is.null(y_boot)) length(x_boot) else length(x_boot) @@ -302,14 +363,14 @@ boot_ses_calc.default = function(x, if (se_method == "agresti") { est_results <- ses_compute_agresti(x = data$x, y = data$y, paired = TRUE, mu = mu) raw_rb <- est_results$rb - raw_SE <- est_results$se_rb / (1 - raw_rb^2) + raw_SE <- 2 * est_results$se_rb / (1 - raw_rb^2) # SE on log-odds scale } else { maxw <- (nd^2 + nd) / 2 raw_SE = sqrt((2 * nd^3 + 3 * nd^2 + nd) / 6) / maxw } # Check for complete separation (paired case) - p_init <- rb_to_cstat(rbs_calc(x = data$y, y = data$x, mu = mu, paired = TRUE)) + p_init <- rb_to_cstat(rbs_calc(x = data$x, y = data$y, mu = mu, paired = TRUE)) check_complete_separation(p_init) raw_ses = ses_calc(x = data$x, @@ -333,7 +394,7 @@ boot_ses_calc.default = function(x, alpha = alpha, se_method = se_method, output = "data.frame") - boots = c(boots, atanh(res_boot$estimate)) + boots = c(boots, to_working(res_boot$estimate)) rfSE <- compute_boot_se(data$x[sampler], data$y[sampler], paired = TRUE, se_method, mu) boots_se = c(boots_se, rfSE) @@ -357,7 +418,7 @@ boot_ses_calc.default = function(x, if (se_method == "agresti") { est_results <- ses_compute_agresti(x = i1, y = i2, paired = FALSE, mu = mu) raw_rb <- est_results$rb - raw_SE <- est_results$se_rb / (1 - raw_rb^2) + raw_SE <- 2 * est_results$se_rb / (1 - raw_rb^2) # SE on log-odds scale } else { raw_SE = sqrt((n1 + n2 + 1) / (3 * n1 * n2)) } @@ -386,7 +447,7 @@ boot_ses_calc.default = function(x, alpha = alpha, se_method = se_method, output = "data.frame") - boots = c(boots, atanh(res_boot$estimate)) + boots = c(boots, to_working(res_boot$estimate)) rfSE <- compute_boot_se(x_boot$values, y_boot$values, paired = FALSE, se_method, mu) boots_se = c(boots_se, rfSE) @@ -403,14 +464,14 @@ boot_ses_calc.default = function(x, d_nonzero <- d[d != 0] if (length(d_nonzero) > 0) { # Compute concordance probability from signed ranks - p_init <- rb_to_cstat(rbs_calc(x = rep(mu, length(x1)), y = x1, mu = 0, paired = TRUE)) + p_init <- rb_to_cstat(rbs_calc(x = x1, y = rep(mu, length(x1)), mu = 0, paired = TRUE)) check_complete_separation(p_init) } if (se_method == "agresti") { est_results <- ses_compute_agresti(x = x1, y = NULL, paired = FALSE, mu = mu) raw_rb <- est_results$rb - raw_SE <- est_results$se_rb / (1 - raw_rb^2) + raw_SE <- 2 * est_results$se_rb / (1 - raw_rb^2) # SE on log-odds scale } else { maxw <- (nd^2 + nd) / 2 raw_SE = sqrt((2 * nd^3 + 3 * nd^2 + nd) / 6) / maxw @@ -437,7 +498,7 @@ boot_ses_calc.default = function(x, alpha = alpha, se_method = se_method, output = "data.frame") - boots = c(boots, atanh(res_boot$estimate)) + boots = c(boots, to_working(res_boot$estimate)) rfSE <- compute_boot_se(x_boot, NULL, paired = FALSE, se_method, mu) boots_se = c(boots_se, rfSE) @@ -448,18 +509,81 @@ boot_ses_calc.default = function(x, message("Bootstrapped results contain extreme results (i.e., no overlap), caution advised interpreting confidence intervals.") } - # Get CI on Fisher Z scale - zci = switch(boot_ci, + # Jackknife for BCa (if needed) — on working scale + if (boot_ci == "bca") { + if (paired == TRUE && !is.null(y)) { + # Paired: delete one pair at a time + n_jack <- nrow(data) + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- ses_calc(x = data$x[-j], + y = data$y[-j], + paired = paired, + ses = "rb", + mu = mu, + alpha = alpha, + se_method = se_method, + output = "data.frame") + jack_est[j] <- to_working(res_jack$estimate) + } + } else if (!is.null(y)) { + # Two-sample: pooled jackknife (delete one from combined) + n_total <- n1 + n2 + jack_est <- numeric(n_total) + for (j in seq_len(n1)) { + res_jack <- ses_calc(x = i1[-j], + y = i2, + paired = paired, + ses = "rb", + mu = mu, + alpha = alpha, + se_method = se_method, + output = "data.frame") + jack_est[j] <- to_working(res_jack$estimate) + } + for (j in seq_len(n2)) { + res_jack <- ses_calc(x = i1, + y = i2[-j], + paired = paired, + ses = "rb", + mu = mu, + alpha = alpha, + se_method = se_method, + output = "data.frame") + jack_est[n1 + j] <- to_working(res_jack$estimate) + } + } else { + # One-sample: delete one observation at a time + n_jack <- length(x1) + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- ses_calc(x = x1[-j], + paired = paired, + ses = "rb", + mu = mu, + alpha = alpha, + se_method = se_method, + output = "data.frame") + jack_est[j] <- to_working(res_jack$estimate) + } + } + } + + # Get CI on working scale (log-odds for agresti, Fisher z for fisher) + ci_alpha <- if(alternative %in% c("equivalence", "minimal.effect")) alpha * 2 else alpha + wci = switch(boot_ci, "stud" = stud(boots_est = boots, boots_se = boots_se, - se0=raw_SE, t0 = atanh(raw_ses$estimate[1L]), - alpha = if(alternative %in% c("equivalence", "minimal.effect")) alpha * 2 else alpha), - "perc" = perc(boots, if(alternative %in% c("equivalence", "minimal.effect")) alpha * 2 else alpha), - "basic" = basic(boots, t0 = atanh(raw_ses$estimate), - if(alternative %in% c("equivalence", "minimal.effect")) alpha * 2 else alpha)) + se0 = raw_SE, t0 = to_working(raw_ses$estimate[1L]), + alpha = ci_alpha), + "perc" = perc(boots, ci_alpha), + "basic" = basic(boots, t0 = to_working(raw_ses$estimate), + ci_alpha), + "bca" = bca_ci(boots_est = boots, t0 = to_working(raw_ses$estimate[1L]), + jack_est = jack_est, alpha = ci_alpha)) # Transform back to rb scale - rci = tanh(zci) - rboots = tanh(boots) + rci = from_working(wci) + rboots = from_working(boots) # Transform to requested effect size scale boots_transformed = switch(ses, @@ -503,68 +627,84 @@ boot_ses_calc.default = function(x, "logodds" = "WMW Log-Odds", "cstat" = "Concordance") - # Bootstrap SE on the transformed scale + # Bootstrap SE on the transformed scale (for reporting in stderr field) boot_se = sd(boots_transformed, na.rm = TRUE) - # Compute p-value using bootstrap distribution (only when hypothesis test requested) + # Bootstrap pivot and p-value computation on working scale + obs_working <- to_working(raw_ses$estimate[1L]) + TSTAT <- (boots - obs_working) / boots_se + + # Pre-compute BCa parameters for p-value use + z0 <- NULL; acc <- NULL + if (boot_ci == "bca") { + bca_par <- bca_params(boots, obs_working, jack_est) + z0 <- bca_par$z0; acc <- bca_par$acc + } + + # Compute p-value (method-consistent with CI) on working scale if (alternative != "none") { - # Center the bootstrap distribution at the null value - # For rb/logodds: null is 0; for cstat: null is 0.5; for odds: null is 1 - - if (alternative == "two.sided") { - # Two-sided test: proportion of bootstrap values at least as extreme as observed - # Centered at null - boot_centered <- boots_transformed - null.value - obs_centered <- est_val - null.value - boot.pval <- 2 * min(mean(boot_centered <= obs_centered), - mean(boot_centered > obs_centered)) - } else if (alternative == "less") { - # One-sided: proportion of bootstrap values less than or equal to observed - boot_centered <- boots_transformed - null.value - obs_centered <- est_val - null.value - boot.pval <- mean(boot_centered <= obs_centered) - } else if (alternative == "greater") { - # One-sided: proportion of bootstrap values greater than or equal to observed - boot_centered <- boots_transformed - null.value - obs_centered <- est_val - null.value - boot.pval <- mean(boot_centered >= obs_centered) + # Convert null value(s) from user's ses scale to rb, then to working scale + null_to_rb <- function(val, ses_type) { + switch(ses_type, + "rb" = val, + "cstat" = cstat_to_rb(val), + "odds" = (val - 1) / (val + 1), + "logodds" = tanh(val / 2)) + } + + se_obs_working <- raw_SE # already on working scale + + if (alternative %in% c("two.sided", "greater", "less")) { + null_working <- to_working(null_to_rb(null.value, ses)) + boot.pval <- boot_pvalue(bvec = boots, est = obs_working, + null = null_working, + alternative = alternative, boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_working, + z0 = z0, acc = acc, nboot = R) } else if (alternative == "equivalence") { - # Equivalence: max of two one-sided p-values - # Test 1: H0: effect <= low_bound vs H1: effect > low_bound - # Test 2: H0: effect >= high_bound vs H1: effect < high_bound - boot_centered_low <- boots_transformed - low_bound - boot_centered_high <- boots_transformed - high_bound - obs_centered_low <- est_val - low_bound - obs_centered_high <- est_val - high_bound - - p_low <- mean(boot_centered_low >= obs_centered_low) # greater than low bound - p_high <- mean(boot_centered_high <= obs_centered_high) # less than high bound - boot.pval <- max(p_low, p_high) + null_working_l <- to_working(null_to_rb(low_bound, ses)) + null_working_u <- to_working(null_to_rb(high_bound, ses)) + p_l <- boot_pvalue(bvec = boots, est = obs_working, + null = null_working_l, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_working, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = boots, est = obs_working, + null = null_working_u, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_working, + z0 = z0, acc = acc, nboot = R) + boot.pval <- max(p_l, p_u) } else if (alternative == "minimal.effect") { - # Minimal effect: min of two one-sided p-values - # Test 1: H0: effect >= low_bound vs H1: effect < low_bound - # Test 2: H0: effect <= high_bound vs H1: effect > high_bound - boot_centered_low <- boots_transformed - low_bound - boot_centered_high <- boots_transformed - high_bound - obs_centered_low <- est_val - low_bound - obs_centered_high <- est_val - high_bound - - p_low <- mean(boot_centered_low <= obs_centered_low) # less than low bound - p_high <- mean(boot_centered_high >= obs_centered_high) # greater than high bound - boot.pval <- min(p_low, p_high) + null_working_l <- to_working(null_to_rb(low_bound, ses)) + null_working_u <- to_working(null_to_rb(high_bound, ses)) + p_l <- boot_pvalue(bvec = boots, est = obs_working, + null = null_working_u, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_working, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = boots, est = obs_working, + null = null_working_l, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_working, + z0 = z0, acc = acc, nboot = R) + boot.pval <- min(p_l, p_u) } - # Compute z-statistic (for reference) + # Report z-observed (analogous to t-observed in boot_t_test) if (alternative %in% c("equivalence", "minimal.effect")) { - z_low <- (est_val - low_bound) / boot_se - z_high <- (est_val - high_bound) / boot_se + null_working_l <- to_working(null_to_rb(low_bound, ses)) + null_working_u <- to_working(null_to_rb(high_bound, ses)) + z_obs_l <- (obs_working - null_working_l) / se_obs_working + z_obs_u <- (obs_working - null_working_u) / se_obs_working if (alternative == "equivalence") { - z_stat <- if (abs(z_low) < abs(z_high)) z_low else z_high + z_stat <- if (p_l >= p_u) z_obs_l else z_obs_u } else { - z_stat <- if (abs(z_low) < abs(z_high)) z_low else z_high + z_stat <- if (p_l <= p_u) z_obs_l else z_obs_u } } else { - z_stat <- (est_val - null.value) / boot_se + null_working <- to_working(null_to_rb(null.value, ses)) + z_stat <- (obs_working - null_working) / se_obs_working } } @@ -582,7 +722,7 @@ boot_ses_calc.default = function(x, # Note: bootstrap methodology details note_text <- paste0("Bootstrap CI: ", boot_ci, - "; SE method: ", if (se_method == "agresti") "Agresti/Lehmann placement" else "Fisher z-transform") + "; SE method: ", if (se_method == "agresti") "Agresti/Lehmann placement (log-odds scale)" else "Fisher z-transform") # Build output if (output == "data.frame") { @@ -619,7 +759,7 @@ boot_ses_calc.default = function(x, # Add hypothesis test components only if requested if (alternative != "none") { - names(z_stat) <- "z" + names(z_stat) <- "z-observed" if (alternative %in% c("equivalence", "minimal.effect")) { null_val <- c(low_bound, high_bound) diff --git a/R/boot_ses_test.R b/R/boot_ses_test.R new file mode 100644 index 0000000..5c773ca --- /dev/null +++ b/R/boot_ses_test.R @@ -0,0 +1,570 @@ +#' @title Parametric Bootstrap Test for Rank-Based Effect Sizes +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Performs hypothesis testing for rank-based effect sizes using a parametric +#' bootstrap. This function is designed primarily for equivalence testing (TOST) +#' and minimal effect testing with non-zero null hypotheses, where +#' permutation-based approaches are not valid for rank-based effect sizes. +#' +#' @section Warning: +#' This function is experimental. Important caveats: +#' - Validity depends on parametric assumptions (Lehmann alternative for +#' two-sample, sign-randomization for paired). Unlike permutation tests, +#' this is not assumption-free. +#' - The procedure is most reliable for continuous data, moderate n (>= 20), +#' and equivalence bounds not too close to +/-1. +#' - Results should be interpreted with caution and ideally cross-checked +#' against asymptotic methods from [ses_calc()]. +#' - This function exists because no assumption-free alternative for non-zero +#' null TOST is available for rank-based effect sizes. The choice is between +#' this and no test at all, not between this and a better test. +#' +#' @inheritParams ses_calc +#' @param x numeric vector of data values (first group or pre-treatment). +#' @param y numeric vector of data values (second group or post-treatment). +#' @param ses a character string specifying the effect size measure: +#' - "rb": rank-biserial correlation (default) +#' - "cstat": concordance statistic (C-statistic/AUC) +#' - "odds": Wilcoxon-Mann-Whitney odds +#' - "logodds": Wilcoxon-Mann-Whitney log-odds +#' @param alpha significance level (default = 0.05). +#' @param mu the null hypothesis value(s) on the scale of the chosen effect size. +#' - For standard alternatives: a single value (default = 0 for rb/logodds, +#' 0.5 for cstat, 1 for odds) +#' - For equivalence/minimal.effect: two values representing the lower and +#' upper bounds, or a single value for symmetric bounds +#' @param alternative a character string specifying the alternative hypothesis: +#' - "two.sided": Test whether effect differs from mu +#' - "less": Test whether effect is less than mu +#' - "greater": Test whether effect is greater than mu +#' - "equivalence": TOST equivalence test (effect inside bounds) +#' - "minimal.effect": Minimal effect test (effect outside bounds) +#' @param B integer; the number of bootstrap replicates (default = 2000). +#' Increase to 5000+ for publication-quality results. +#' @param keep_boot logical; if `TRUE` (default), return the bootstrap +#' distributions in the output. +#' @param ... further arguments to be passed to or from methods. +#' +#' @details +#' This function calculates p-values for rank-based effect sizes using a +#' parametric bootstrap. It generates data under the null hypothesis and +#' compares the observed effect size to the resulting null reference +#' distribution. +#' +#' ## Why Not Permutation? +#' +#' Permutation tests are exact and assumption-free when testing the null +#' \eqn{\rho = 0}. However, for non-zero nulls — as required by equivalence +#' (TOST) and minimal effect testing — the permutation distribution cannot be +#' shifted to the correct null by arithmetic operations. The rank-biserial +#' correlation is a nonlinear, bounded function of the data, so there is no +#' data transformation that shifts rb by a fixed \eqn{\Delta}. Studentization +#' (as used in [perm_t_test()] and [brunner_munzel()]) cannot rescue this +#' because rb is not a studentized statistic. +#' +#' This function uses parametric models to generate data under the non-zero +#' null. The tradeoff is that validity now depends on how well the model +#' approximates the true data-generating process. +#' +#' Users who need TOST for means should use [boot_t_TOST()], which handles +#' non-zero nulls correctly via studentization without any parametric +#' assumption. +#' +#' ## Why No Confidence Intervals? +#' +#' This function intentionally omits confidence intervals. The parametric +#' bootstrap here generates data under a specific null to produce a reference +#' distribution for p-value computation. This is fundamentally different from +#' the nonparametric bootstrap in [boot_ses_calc()], which resamples from the +#' observed data to characterize the sampling distribution of the estimator. +#' Users who need confidence intervals should use [boot_ses_calc()] or the +#' asymptotic intervals from [ses_calc()]. +#' +#' ## Algorithm +#' +#' **Two-sample (independent)**: Uses the Lehmann alternative (proportional +#' hazards) model. Data are pooled and treated as a common empirical CDF +#' \eqn{F}. Under the null \eqn{P(X > Y) = \text{target}}, group Y is +#' resampled from \eqn{F} and group X is resampled from a transformed CDF +#' \eqn{G(t) = 1 - (1 - F(t))^{1/\gamma}} where +#' \eqn{\gamma = \text{target\_cstat} / (1 - \text{target\_cstat})}. This +#' produces data with the correct population rank-biserial under the +#' proportional hazards assumption. +#' +#' **Paired samples**: Uses a sign-randomization model. The absolute +#' differences \eqn{|d_i| = |x_i - y_i|} are resampled with replacement, and +#' signs are assigned independently with probability +#' \eqn{P(\text{sign} = +) = (1 + \Delta) / 2}. This produces a bootstrap +#' distribution with the correct expected signed-rank rb under the assumption +#' of rank-independent sign probabilities. +#' +#' For equivalence testing, two null distributions are generated (one per bound) +#' and the TOST p-value is the maximum of the two one-sided p-values. +#' +#' @section Future Work: +#' \itemize{ +#' \item **Confidence intervals**: Not currently provided. Adding CIs would +#' require test inversion across a grid of null values (Berger & Boos, 1994), +#' which is computationally expensive. Use [boot_ses_calc()] or [ses_calc()] +#' for interval estimation. +#' \item **Rank-dependent sign model**: The current paired bootstrap assigns +#' signs independently of rank. A rank-weighted sign model could improve +#' accuracy by allowing the sign probability to depend on the magnitude of +#' the difference. +#' \item **Copula-based generation**: A normal copula model could provide an +#' alternative data generation mechanism, especially for paired data where +#' the joint distribution matters beyond marginals. This would require +#' numerical calibration of the copula parameter to the target rb. +#' } +#' +#' @return A list with class `"htest"` containing: +#' \item{estimate}{Observed effect size on the requested scale.} +#' \item{p.value}{Bootstrap p-value.} +#' \item{alternative}{Character string describing the alternative hypothesis.} +#' \item{method}{Description of the test performed.} +#' \item{null.value}{Null hypothesis value(s) on the requested scale.} +#' \item{data.name}{Character string giving the name(s) of the data.} +#' \item{call}{The matched call.} +#' \item{model.param}{The model parameter(s) used for null generation +#' (for diagnostics). For two-sample: the Lehmann gamma parameter(s). +#' For paired: the sign probability parameter(s).} +#' \item{boot.dist}{Bootstrap null distribution (if `keep_boot = TRUE` and +#' standard alternative).} +#' \item{boot.dist.low}{Bootstrap distribution under lower bound (if +#' `keep_boot = TRUE` and TOST).} +#' \item{boot.dist.high}{Bootstrap distribution under upper bound (if +#' `keep_boot = TRUE` and TOST).} +#' +#' @examples +#' \donttest{ +#' # Example 1: Two-sided test +#' set.seed(42) +#' x <- rnorm(30, mean = 0) +#' y <- rnorm(30, mean = 0.5) +#' boot_ses_test(x = x, y = y, ses = "rb", +#' mu = 0, alternative = "two.sided", B = 599) +#' +#' # Example 2: Equivalence test with rank-biserial +#' boot_ses_test(x = x, y = y, ses = "rb", +#' mu = c(-0.4, 0.4), alternative = "equivalence", B = 599) +#' +#' # Example 3: Paired samples +#' pre <- c(4.5, 5.2, 3.8, 6.1, 4.9, 5.7, 3.6, 5.0, 4.3, 6.5, +#' 4.1, 5.5, 3.9, 6.0, 4.7, 5.3, 3.7, 5.1, 4.4, 6.3) +#' post <- c(5.1, 4.9, 4.5, 5.8, 5.5, 5.2, 4.3, 5.4, 4.0, 6.2, +#' 4.8, 5.3, 4.2, 5.7, 5.1, 5.0, 4.1, 5.3, 4.2, 6.1) +#' boot_ses_test(x = pre, y = post, paired = TRUE, +#' ses = "rb", mu = 0, alternative = "two.sided", B = 599) +#' +#' # Example 4: Using formula interface +#' data(mtcars) +#' boot_ses_test(formula = mpg ~ am, data = mtcars, +#' ses = "rb", mu = 0, +#' alternative = "two.sided", B = 599) +#' } +#' +#' @references +#' Berger, R.L. and Boos, D.D. (1994). P values maximized over a confidence set +#' for the nuisance parameter. *Journal of the American Statistical Association*, +#' 89, 1012-1016. +#' +#' Lehmann, E.L. (1975). *Nonparametrics: Statistical Methods Based on Ranks*. +#' Holden-Day. +#' +#' @family Robust tests +#' @seealso [ses_calc()] for asymptotic inference, [boot_ses_calc()] for +#' bootstrap confidence intervals, [brunner_munzel()] with +#' `test_method = "perm"` for robust TOST on the probability scale. +#' @name boot_ses_test +#' @export boot_ses_test + +boot_ses_test <- function(x, ..., + paired = FALSE, + ses = c("rb", "cstat", "odds", "logodds"), + alpha = 0.05, + mu = NULL, + alternative = c("two.sided", "less", "greater", + "equivalence", "minimal.effect"), + B = 2000L, + keep_boot = TRUE) { + UseMethod("boot_ses_test") +} + +#' @rdname boot_ses_test +#' @method boot_ses_test default +#' @export +boot_ses_test.default <- function(x, + y = NULL, + paired = FALSE, + ses = c("rb", "cstat", "odds", "logodds"), + alpha = 0.05, + mu = NULL, + alternative = c("two.sided", "less", "greater", + "equivalence", "minimal.effect"), + B = 2000L, + keep_boot = TRUE, + ...) { + + ses <- match.arg(ses) + alternative <- match.arg(alternative) + + # Validate inputs -------- + if (is.null(y)) { + stop("boot_ses_test requires two samples (x and y). One-sample designs are not supported.") + } + + if (!is.numeric(alpha) || alpha <= 0 || alpha >= 1) { + stop("alpha must be a numeric value between 0 and 1") + } + + B <- as.integer(B) + if (is.na(B) || B < 100L) { + stop("B must be an integer >= 100") + } + + # Set default mu based on ses scale + if (is.null(mu)) { + mu <- switch(ses, + "rb" = 0, + "cstat" = 0.5, + "odds" = 1, + "logodds" = 0) + } + + # Handle equivalence/minimal.effect bounds -------- + if (alternative %in% c("equivalence", "minimal.effect")) { + if (length(mu) == 1) { + # Create symmetric bounds + mu <- switch(ses, + "rb" = c(-abs(mu), abs(mu)), + "cstat" = c(0.5 - abs(mu - 0.5), 0.5 + abs(mu - 0.5)), + "odds" = c(1 / mu, mu), + "logodds" = c(-abs(mu), abs(mu))) + # Ensure correct ordering + mu <- sort(mu) + } + if (length(mu) != 2) { + stop("For equivalence or minimal.effect testing, mu must be a single value (for symmetric bounds) or a vector of two values.") + } + low_bound <- min(mu) + high_bound <- max(mu) + } else { + if (length(mu) > 1) { + warning("mu has length > 1; only the first element will be used") + mu <- mu[1] + } + } + + # Validate mu is within valid range for ses scale -------- + validate_mu_range <- function(val, ses_type) { + switch(ses_type, + "rb" = { + if (any(val <= -1 | val >= 1)) + stop("mu must be in the open interval (-1, 1) for rb scale") + }, + "cstat" = { + if (any(val <= 0 | val >= 1)) + stop("mu must be in the open interval (0, 1) for cstat scale") + }, + "odds" = { + if (any(val <= 0)) + stop("mu must be positive for odds scale") + }, + "logodds" = { + # logodds is unbounded, no validation needed + }) + } + validate_mu_range(mu, ses) + + # Data name + dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) + + # Handle NA and paired data -------- + if (paired) { + data <- data.frame(x = x, y = y) + data <- na.omit(data) + x <- data$x + y <- data$y + } else { + x <- na.omit(x) + y <- na.omit(y) + } + + n_x <- length(x) + n_y <- length(y) + n <- if (paired) n_x else min(n_x, n_y) + + # Small n warning -------- + if (n < 20) { + warning( + "Sample size is small (n = ", n, "). ", + "The parametric bootstrap may not be reliable for small samples. ", + "Results should be treated as exploratory." + ) + } + + # Compute observed effect size -------- + obs_rb <- rbs_calc(x = x, y = y, mu = 0, paired = paired) + + # Complete separation warning -------- + if (abs(obs_rb) >= 0.999) { + warning( + "Complete or near-complete separation detected (rb = ", round(obs_rb, 3), "). ", + "The parametric bootstrap result may be unreliable. ", + "Interpret with extreme caution." + ) + } + + # Scale conversion helpers -------- + ses_to_rb <- function(val, ses_type) { + switch(ses_type, + "rb" = val, + "cstat" = cstat_to_rb(val), + "odds" = (val - 1) / (val + 1), + "logodds" = tanh(val / 2)) + } + + rb_to_ses_val <- function(rb_val, ses_type) { + switch(ses_type, + "rb" = rb_val, + "cstat" = rb_to_cstat(rb_val), + "odds" = rb_to_odds(rb_val), + "logodds" = log(rb_to_odds(rb_val))) + } + + obs_es <- rb_to_ses_val(obs_rb, ses) + + # Bootstrap null distribution generators -------- + + # Two-sample: Lehmann alternative (proportional hazards) model + # Under G(t) = 1 - (1-F(t))^(1/gamma), P(X > Y) = gamma/(1+gamma) + # So gamma = target_cstat / (1 - target_cstat) + boot_rb_twosample <- function(x, y, target_rb, B) { + pooled <- c(x, y) + n_x_local <- length(x) + n_y_local <- length(y) + target_cstat <- (1 + target_rb) / 2 + gamma_val <- target_cstat / (1 - target_cstat) + + boot_dist <- vapply(seq_len(B), function(b) { + u_y <- runif(n_y_local) + u_x <- runif(n_x_local) + # Y resampled from pooled empirical CDF + y_boot <- quantile(pooled, u_y, type = 1) + # X from Lehmann-transformed CDF: quantile at 1 - (1-u)^gamma + x_boot <- quantile(pooled, 1 - (1 - u_x)^gamma_val, type = 1) + rbs_calc(x_boot, y_boot, mu = 0, paired = FALSE) + }, numeric(1)) + + list(dist = boot_dist, model_param = gamma_val) + } + + # Paired: sign-randomization model + # Resample |d_i| with replacement, assign sign + with P = (1 + target_rb) / 2 + boot_rb_paired <- function(x, y, target_rb, B) { + d <- x - y + abs_d <- abs(d) + # Remove zero differences (consistent with signed-rank convention) + abs_d <- abs_d[abs_d != 0] + n_d <- length(abs_d) + p_sign <- (1 + target_rb) / 2 + + if (n_d == 0) { + return(list(dist = rep(0, B), model_param = p_sign)) + } + + boot_dist <- vapply(seq_len(B), function(b) { + # Resample absolute differences + idx <- sample(n_d, replace = TRUE) + abs_d_boot <- abs_d[idx] + # Assign signs with target probability + signs <- sample(c(1, -1), n_d, replace = TRUE, prob = c(p_sign, 1 - p_sign)) + d_boot <- abs_d_boot * signs + # Compute signed-rank rb + d_nz <- d_boot[d_boot != 0] + n_nz <- length(d_nz) + if (n_nz == 0) return(0) + rr <- rank(abs(d_nz)) + T_plus <- sum(rr[d_nz > 0]) + S <- n_nz * (n_nz + 1) / 2 + 2 * T_plus / S - 1 + }, numeric(1)) + + list(dist = boot_dist, model_param = p_sign) + } + + # Dispatch to appropriate bootstrap generator + boot_rb_under_null <- function(x, y, target_rb, B, paired) { + if (paired) { + boot_rb_paired(x, y, target_rb, B) + } else { + boot_rb_twosample(x, y, target_rb, B) + } + } + + # Compute p-values -------- + if (alternative %in% c("equivalence", "minimal.effect")) { + mu_rb_low <- ses_to_rb(low_bound, ses) + mu_rb_high <- ses_to_rb(high_bound, ses) + + # Warn if bounds are near +/-1 on rb scale + if (any(abs(c(mu_rb_low, mu_rb_high)) > 0.95)) { + warning( + "One or more equivalence bounds are close to +/-1 on the rb scale. ", + "The parametric bootstrap approximation may be unreliable in this region." + ) + } + + boot_low_res <- boot_rb_under_null(x, y, target_rb = mu_rb_low, B = B, paired = paired) + boot_high_res <- boot_rb_under_null(x, y, target_rb = mu_rb_high, B = B, paired = paired) + + boot_low <- boot_low_res$dist + boot_high <- boot_high_res$dist + model_params <- c(boot_low_res$model_param, boot_high_res$model_param) + names(model_params) <- c("lower", "upper") + + if (alternative == "equivalence") { + # IU test: reject non-equivalence if inside bounds + p_low <- mean(boot_low >= obs_rb) # H1: rb > lower bound + p_high <- mean(boot_high <= obs_rb) # H1: rb < upper bound + pvalue <- max(p_low, p_high) + } else { + # UI test: reject equivalence if outside bounds + p_low <- mean(boot_low <= obs_rb) + p_high <- mean(boot_high >= obs_rb) + pvalue <- min(p_low, p_high) + } + + # Null values on user scale + null_val <- c(low_bound, high_bound) + names(null_val) <- c("lower bound", "upper bound") + + } else { + mu_rb <- ses_to_rb(mu, ses) + + # Warn if null is near +/-1 on rb scale + if (abs(mu_rb) > 0.95) { + warning( + "The null value is close to +/-1 on the rb scale. ", + "The parametric bootstrap approximation may be unreliable in this region." + ) + } + + boot_res <- boot_rb_under_null(x, y, target_rb = mu_rb, B = B, paired = paired) + boot_dist <- boot_res$dist + model_params <- boot_res$model_param + names(model_params) <- "null" + + pvalue <- switch(alternative, + "two.sided" = mean(abs(boot_dist - mu_rb) >= abs(obs_rb - mu_rb)), + "greater" = mean(boot_dist >= obs_rb), + "less" = mean(boot_dist <= obs_rb)) + + # Null value on user scale + ses_name_est <- switch(ses, + "rb" = "rank-biserial", + "cstat" = "concordance", + "odds" = "WMW odds", + "logodds" = "WMW log-odds") + null_val <- mu + names(null_val) <- ses_name_est + } + + # Build output -------- + if (is.null(y)) { + sample_type <- "One Sample" + } else if (paired) { + sample_type <- "Paired Sample" + } else { + sample_type <- "Two Sample" + } + + ses_label <- switch(ses, + "rb" = "Rank-Biserial Correlation", + "cstat" = "Concordance", + "odds" = "WMW Odds", + "logodds" = "WMW Log-Odds") + + method_desc <- paste0("Parametric Bootstrap ", sample_type, " ", ses_label, " Test") + + estimate <- obs_es + names(estimate) <- ses_label + + rval <- list( + estimate = estimate, + p.value = pvalue, + alternative = alternative, + method = method_desc, + null.value = null_val, + data.name = dname, + call = match.call(), + model.param = model_params + ) + + # Add bootstrap distributions if requested + if (keep_boot) { + if (alternative %in% c("equivalence", "minimal.effect")) { + rval$boot.dist.low <- rb_to_ses_val(boot_low, ses) + rval$boot.dist.high <- rb_to_ses_val(boot_high, ses) + } else { + rval$boot.dist <- rb_to_ses_val(boot_dist, ses) + } + } + + # TODO 1 — Confidence intervals: Not provided. Adding CIs would require test + # inversion across a grid of null values (Berger & Boos, 1994), which is + # computationally expensive (B x grid size resamples). Use boot_ses_calc() or + # ses_calc() for interval estimation. + + # TODO 2 — Rank-dependent sign model for paired: The current sign-randomization + # assigns signs independently of rank. A model where P(sign = +) depends on the + # rank of |d_i| could improve accuracy for some data configurations. + + # TODO 3 — Copula-based generation: A normal copula model could provide an + # alternative mechanism, especially for paired data. Would require numerical + # calibration rather than the Spearman-to-copula formula (which applies to + # Spearman correlation, not the rank-biserial). + + class(rval) <- "htest" + return(rval) +} + +#' @rdname boot_ses_test +#' @method boot_ses_test formula +#' @export +boot_ses_test.formula <- function(formula, + data, + subset, + na.action, ...) { + + if (missing(formula) + || (length(formula) != 3L) + || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) + stop("'formula' missing or incorrect") + + # Check for paired argument in ... and warn user + dots <- list(...) + if ("paired" %in% names(dots)) { + if (isTRUE(dots$paired)) { + message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") + } + } + + m <- match.call(expand.dots = FALSE) + if (is.matrix(eval(m$data, parent.frame()))) + m$data <- as.data.frame(data) + m[[1L]] <- quote(stats::model.frame) + m$... <- NULL + mf <- eval(m, parent.frame()) + DNAME <- paste(names(mf), collapse = " by ") + names(mf) <- NULL + response <- attr(attr(mf, "terms"), "response") + g <- factor(mf[[-response]]) + if (nlevels(g) != 2L) + stop("grouping factor must have exactly 2 levels") + DATA <- setNames(split(mf[[response]], g), c("x", "y")) + y <- do.call("boot_ses_test", c(DATA, list(...))) + y$data.name <- DNAME + y +} diff --git a/R/boot_smd_calc.R b/R/boot_smd_calc.R index cb09439..73f5bbc 100644 --- a/R/boot_smd_calc.R +++ b/R/boot_smd_calc.R @@ -2,9 +2,8 @@ #' @description #' `r lifecycle::badge('maturing')` #' -#' Calculates standardized mean differences (SMDs) with bootstrap confidence intervals. -#' This function provides more robust confidence intervals for Cohen's d, Hedges' g, -#' and other SMD measures through resampling methods. +#' Calculates standardized mean differences (SMDs) with bootstrap confidence intervals, +#' with optional hypothesis testing. #' #' @section Purpose: #' Use this function when: @@ -14,10 +13,44 @@ #' * Sample sizes are small or standard error approximations may be unreliable #' * You prefer resampling-based confidence intervals over parametric approximations #' * You need to quantify uncertainty in SMD estimates more accurately +#' * You want to test hypotheses about effect size magnitudes using bootstrap methods #' #' @inheritParams boot_t_TOST #' @param mu null value to adjust the calculation. If non-zero, the function calculates x-y-mu (default = 0). #' @param ... further arguments to be passed to or from methods. +#' @param output a character string specifying the output format: +#' - "htest": (default) Returns an object of class "htest" compatible with standard R output. +#' - "data.frame": Returns a data frame for backward compatibility. +#' @param null.value a number or vector specifying the null hypothesis value(s) on the SMD scale: +#' - For standard alternatives: a single value (default = 0) +#' - For equivalence/minimal.effect: two values representing the lower and upper bounds +#' @param alternative a character string specifying the alternative hypothesis: +#' - "none": (default) No hypothesis test is performed; only effect size and CI are returned. +#' - "two.sided": Test whether SMD differs from null.value +#' - "less": Test whether SMD is less than null.value +#' - "greater": Test whether SMD is greater than null.value +#' - "equivalence": Test whether SMD is between specified bounds +#' - "minimal.effect": Test whether SMD is outside specified bounds +#' @param denom a character string specifying the denominator for standardization: +#' - "auto": (default) Uses the standard denominator based on design and other arguments +#' (glass, rm_correction, var.equal). +#' - "z": SD of differences (Cohen's d_z). Valid for paired and one-sample designs. +#' - "rm": Repeated-measures corrected (Cohen's d_rm). Valid for paired designs only. +#' - "pooled": Pooled SD (Cohen's d_s). Valid for independent samples only. +#' - "avg": Root-mean-square SD (Cohen's d_av). Valid for independent samples only. +#' - "glass1": First group's (x) SD (Glass's delta). Valid for paired and independent designs. +#' - "glass2": Second group's (y) SD (Glass's delta). Valid for paired and independent designs. +#' +#' When set to any value other than "auto", this overrides the glass, rm_correction, +#' and var.equal arguments. The bias_correction argument is not affected. +#' @param tr a numeric value specifying the proportion of observations to trim from each +#' tail when computing trimmed means and Winsorized variances (default = 0, no trimming). +#' Must be in the range \[0, 0.5). Common choices are 0.1 (10\% trimming) and 0.2 +#' (20\% trimming). When tr > 0, the effect size uses trimmed means for the numerator +#' and the rescaled Winsorized standard deviation for the denominator, following +#' Algina, Keselman, and Penfield (2005). The rescaling ensures the robust effect +#' size equals Cohen's delta when data are normally distributed. +#' Note: tr > 0 is not compatible with denom = "rm". #' #' @details #' This function calculates bootstrapped confidence intervals for standardized mean differences. @@ -31,10 +64,24 @@ #' * Calculate the SMD and its standard error for each bootstrap sample #' * Calculate confidence intervals using the specified method #' -#' Three bootstrap confidence interval methods are available: -#' - **Studentized bootstrap ("stud")**: Accounts for the variability in standard error estimates. Usually provides the most accurate coverage probability and is set as the default. -#' - **Basic bootstrap ("basic")**: Uses the empirical distribution of bootstrap estimates. Simple approach that works well for symmetric distributions. -#' - **Percentile bootstrap ("perc")**: Uses percentiles of the bootstrap distribution directly. More robust to skewness in the bootstrap distribution. +#' Four bootstrap confidence interval methods are available via the `boot_ci` argument: +#' - **Studentized bootstrap ("stud")**: Uses the bootstrap distribution of pivotal +#' t-statistics to account for variability in standard error estimates. Usually +#' provides the most accurate coverage probability and is set as the default. +#' - **Basic bootstrap ("basic")**: Reflects the bootstrap distribution of estimates +#' around the observed value. Simple approach that works well for symmetric distributions. +#' - **Percentile bootstrap ("perc")**: Uses percentiles of the bootstrap distribution directly. +#' More robust to skewness in the bootstrap distribution. +#' - **Bias-corrected and accelerated ("bca")**: Corrects for both bias and skewness in the +#' bootstrap distribution using jackknife-based acceleration. Most accurate when the +#' bootstrap distribution is skewed, but computationally more expensive. +#' +#' When hypothesis testing is requested (i.e., `alternative` is not `"none"`), +#' the p-value is computed using the method that matches the selected `boot_ci`, +#' ensuring that p < alpha if and only if the corresponding confidence interval +#' excludes the null value (CI inversion principle). Previously, all bootstrap +#' CI methods used the studentized (pivot) p-value, which could produce p-values +#' inconsistent with non-studentized CIs. #' #' The function supports various SMD variants: #' * Classic standardized mean difference (bias_correction = FALSE) @@ -47,16 +94,42 @@ #' * Two-sample independent design: Standardizes the difference between two group means #' * Paired samples design: Standardizes the mean difference between paired observations #' +#' The `denom` parameter provides a direct way to select the standardization denominator. +#' When `denom` is not "auto", it takes precedence over the `glass`, `rm_correction`, and +#' `var.equal` arguments, which are overridden as needed. A message is emitted if any +#' explicitly provided arguments are overridden. The `bias_correction` argument is always +#' respected regardless of `denom`. +#' #' For detailed information on calculation methods, see `vignette("SMD_calcs")`. #' -#' @return A data frame containing the following information: -#' * estimate: The SMD calculated from the original data -#' * bias: Estimated bias (difference between original estimate and median of bootstrap estimates) -#' * SE: Standard error estimated from the bootstrap distribution -#' * lower.ci: Lower bound of the bootstrap confidence interval -#' * upper.ci: Upper bound of the bootstrap confidence interval -#' * conf.level: Confidence level (1-alpha) -#' * boot_ci: The bootstrap confidence interval method used +#' @references +#' Algina, J., Keselman, H. J., & Penfield, R. D. (2005). An alternative to Cohen's +#' standardized mean difference effect size: A robust parameter and confidence interval +#' in the two independent groups case. \emph{Psychological Methods}, \emph{10}(3), 317-328. +#' +#' @return +#' If `output = "htest"` (default), returns a list with class `"htest"` containing: +#' - estimate: The SMD estimate (Cohen's d, Hedges' g, or Glass's delta) +#' - stderr: Standard error estimated from the bootstrap distribution +#' - conf.int: Bootstrap confidence interval with conf.level attribute +#' - alternative: A character string describing the alternative hypothesis +#' - method: A character string indicating what type of test was performed +#' - note: A character string describing the bootstrap CI method used +#' - boot: The bootstrap distribution of SMD estimates +#' - data.name: A character string giving the name(s) of the data +#' - call: The matched call +#' - statistic: z-statistic (only if alternative != "none") +#' - p.value: Bootstrap p-value (only if alternative != "none") +#' - null.value: The specified hypothesized value(s) (only if alternative != "none") +#' +#' If `output = "data.frame"`, returns a data frame containing: +#' - estimate: The SMD calculated from the original data +#' - bias: Estimated bias (difference between original estimate and median of bootstrap estimates) +#' - SE: Standard error estimated from the bootstrap distribution +#' - lower.ci: Lower bound of the bootstrap confidence interval +#' - upper.ci: Upper bound of the bootstrap confidence interval +#' - conf.level: Confidence level (1-alpha) +#' - boot_ci: The bootstrap confidence interval method used #' #' @examples #' # Example 1: Independent groups comparison with studentized bootstrap CI @@ -100,12 +173,30 @@ #' boot_ci = "stud", #' R = 999) #' +#' # Example 5: Two-sided hypothesis test +#' result <- boot_smd_calc(x = group1, y = group2, +#' alternative = "two.sided", +#' null.value = 0, +#' R = 999) +#' +#' # Example 6: Equivalence test with bootstrap +#' result <- boot_smd_calc(x = group1, y = group2, +#' alternative = "equivalence", +#' null.value = c(-0.5, 0.5), +#' R = 999) +#' +#' # Example 7: Legacy data.frame output +#' result <- boot_smd_calc(x = group1, y = group2, +#' output = "data.frame", +#' R = 999) +#' #' @family effect sizes #' @name boot_smd_calc #' @export boot_smd_calc # Bootstrap ------- +# TODO: add xname and yname arguments to allow user-specified group labels #smd_calc <- setClass("smd_calc") boot_smd_calc <- function(x, ..., paired = FALSE, @@ -114,8 +205,15 @@ boot_smd_calc <- function(x, ..., bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - boot_ci = c("stud","basic","perc"), - R = 1999){ + denom = c("auto", "z", "rm", "pooled", "avg", + "glass1", "glass2"), + boot_ci = c("stud","basic","perc","bca"), + R = 1999, + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", + "equivalence", "minimal.effect"), + tr = 0){ UseMethod("boot_smd_calc") } @@ -133,10 +231,104 @@ boot_smd_calc.default = function(x, bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - boot_ci = c("stud","basic","perc"), + denom = c("auto", "z", "rm", "pooled", "avg", + "glass1", "glass2"), + boot_ci = c("stud","basic","perc","bca"), R = 1999, + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", + "equivalence", "minimal.effect"), + tr = 0, ...) { + denom = match.arg(denom) boot_ci = match.arg(boot_ci) + output = match.arg(output) + alternative = match.arg(alternative) + + # Validate tr + if (!is.numeric(tr) || length(tr) != 1 || tr < 0 || tr >= 0.5) { + stop("'tr' must be a single numeric value in [0, 0.5)") + } + + # Capture explicit-pass status before any modifications + var.equal_explicit <- !missing(var.equal) + rm_correction_explicit <- !missing(rm_correction) + glass_explicit <- !missing(glass) + + if((denom == "auto" & (!is.null(glass))) || denom == "glass1" || denom == "glass2" ){ + if(rm_correction){ + origin_author_text = "bias-corrected Glass's" + } else{ + origin_author_text = "Glass's" + } + } else { + if(bias_correction){ + origin_author_text = "Hedges's" + } else{ + origin_author_text = "Cohen's" + } + } + + # Determine sample_type early for denom resolution + if(is.null(y)){ + sample_type = "One Sample" + } else if(paired == TRUE) { + sample_type = "Paired Sample" + } else { + sample_type = "Two Sample" + } + + # Resolve denom ONCE - messages emitted here, not in loop + resolved <- resolve_denom( + denom = denom, + sample_type = sample_type, + var.equal = var.equal, + rm_correction = rm_correction, + glass = if (glass_explicit) glass else NULL, + var.equal_explicit = var.equal_explicit, + rm_correction_explicit = rm_correction_explicit, + glass_explicit = glass_explicit + ) + + for (msg in resolved$messages) message(msg) + + # Apply resolved values for all subsequent smd_calc calls + var.equal <- resolved$var.equal + rm_correction <- resolved$rm_correction + glass <- resolved$glass + + # tr > 0 with rm denom + if (tr > 0 && isTRUE(rm_correction)) { + stop("The repeated measures denominator (denom = 'rm') is not currently supported with trimming (tr > 0). ", + "Consider using denom = 'z' for paired designs with trimming.") + } + + # Handle equivalence/minimal.effect bounds + if (alternative %in% c("equivalence", "minimal.effect")) { + if (length(null.value) != 2) { + stop("For equivalence or minimal.effect testing, null.value must be a vector of two values (lower and upper bounds)") + } + low_bound <- min(null.value) + high_bound <- max(null.value) + conf.level <- 1 - alpha * 2 + } else { + if (length(null.value) > 1) { + warning("null.value has length > 1; only the first element will be used") + null.value <- null.value[1] + } + low_bound <- null.value + high_bound <- null.value + conf.level <- 1 - alpha + } + + # Get data name + if (!is.null(y)) { + dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) + } else { + dname <- deparse(substitute(x)) + } + if(paired == TRUE && !missing(y)){ i1 <- x i2 <- y @@ -151,7 +343,9 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c() boots_se = c() @@ -167,7 +361,9 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c(boots, res_boot$estimate) boots_se = c(boots_se, res_boot$SE) } @@ -190,7 +386,9 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c() boots_se = c() @@ -210,7 +408,9 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c(boots, res_boot$estimate) boots_se = c(boots_se, res_boot$SE) } @@ -227,7 +427,9 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c() boots_se = c() @@ -243,33 +445,262 @@ boot_smd_calc.default = function(x, bias_correction = bias_correction, rm_correction = rm_correction, glass = glass, - smd_ci = "z") + tr = tr, + smd_ci = "z", + output = "data.frame") boots = c(boots, res_boot$estimate) boots_se = c(boots_se, res_boot$SE) } } + # Jackknife for BCa (if needed) + if (boot_ci == "bca") { + if (paired == TRUE && !missing(y)) { + # Paired: delete one pair at a time + n_jack <- nrow(data) + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- smd_calc(x = data$x[-j], + y = data$y[-j], + paired = paired, + var.equal = var.equal, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = rm_correction, + glass = glass, + tr = tr, + smd_ci = "z", + output = "data.frame") + jack_est[j] <- res_jack$estimate + } + } else if (!missing(y)) { + # Two-sample: pooled jackknife (delete one from combined) + n1 <- length(i1) + n2 <- length(i2) + n_total <- n1 + n2 + jack_est <- numeric(n_total) + for (j in seq_len(n1)) { + res_jack <- smd_calc(x = i1[-j], + y = i2, + paired = paired, + var.equal = var.equal, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = rm_correction, + glass = glass, + tr = tr, + smd_ci = "z", + output = "data.frame") + jack_est[j] <- res_jack$estimate + } + for (j in seq_len(n2)) { + res_jack <- smd_calc(x = i1, + y = i2[-j], + paired = paired, + var.equal = var.equal, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = rm_correction, + glass = glass, + tr = tr, + smd_ci = "z", + output = "data.frame") + jack_est[n1 + j] <- res_jack$estimate + } + } else { + # One-sample: delete one observation at a time + n_jack <- length(x1) + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- smd_calc(x = x1[-j], + paired = paired, + var.equal = var.equal, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = rm_correction, + glass = glass, + tr = tr, + smd_ci = "z", + output = "data.frame") + jack_est[j] <- res_jack$estimate + } + } + } + + ci_alpha <- if(alternative %in% c("equivalence", "minimal.effect")) alpha * 2 else alpha ci = switch(boot_ci, "stud" = stud(boots_est = boots, boots_se = boots_se, se0=raw_smd$SE[1L], t0 = raw_smd$estimate[1L], - alpha), - "perc" = perc(boots, alpha), - "basic" = basic(boots, t0 = raw_smd$estimate[1L], alpha=alpha)) - - effsize = data.frame( - estimate = raw_smd$estimate, - bias = raw_smd$estimate - median(boots, na.rm=TRUE), - SE = sd(boots), - lower.ci = ci[1], - upper.ci = ci[2], - conf.level = c((1-alpha)), - boot_ci = boot_ci, - row.names = row.names(raw_smd) - ) + alpha = ci_alpha), + "perc" = perc(boots, ci_alpha), + "basic" = basic(boots, t0 = raw_smd$estimate[1L], + alpha = ci_alpha), + "bca" = bca_ci(boots_est = boots, t0 = raw_smd$estimate[1L], + jack_est = jack_est, alpha = ci_alpha)) + + # Derive int_denom from resolved state (mirrors smd_calc logic) + int_denom <- if (!is.null(glass) && glass %in% c("glass1", "glass2")) { + glass + } else if (sample_type != "Two Sample") { + if (isTRUE(rm_correction)) "rm" else "z" + } else { + "d" + } + + # Derive denom_tag for estimate label subscript -------- + denom_tag <- if (int_denom == "d") { + if (var.equal) "s" else "av" + } else if (int_denom %in% c("z", "rm")) { + int_denom + } else if (int_denom == "glass1") { + "x" + } else if (int_denom == "glass2") { + "y" + } else { + NULL + } + + # Determine SMD label -------- + smd_type_letter <- if (bias_correction) "g" else "d" + trim_note <- if (tr > 0) paste0(", ", tr * 100, "% trimmed") else "" + smd_label <- paste0("SMD (", smd_type_letter, "[", denom_tag, "]", trim_note, ")") + + # Bootstrap SE (for reporting in stderr field) + boot_se <- sd(boots, na.rm = TRUE) + # Studentized bootstrap pivot: centered at observed estimate, scaled by bootstrap SE + # Analogous to TSTAT in boot_t_test + TSTAT <- (boots - raw_smd$estimate[1L]) / boots_se - return(effsize = effsize) + # Pre-compute BCa parameters for p-value use + z0 <- NULL; acc <- NULL + if (boot_ci == "bca") { + bca_par <- bca_params(boots, raw_smd$estimate[1L], jack_est) + z0 <- bca_par$z0; acc <- bca_par$acc + } + + # Compute p-value (method-consistent with CI) + if (alternative != "none") { + est_val <- raw_smd$estimate[1L] + se_obs <- raw_smd$SE[1L] + + if (alternative %in% c("two.sided", "greater", "less")) { + boot.pval <- boot_pvalue(bvec = boots, est = est_val, null = null.value, + alternative = alternative, boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs, + z0 = z0, acc = acc, nboot = R) + } else if (alternative == "equivalence") { + p_l <- boot_pvalue(bvec = boots, est = est_val, null = low_bound, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = boots, est = est_val, null = high_bound, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs, + z0 = z0, acc = acc, nboot = R) + boot.pval <- max(p_l, p_u) + } else if (alternative == "minimal.effect") { + p_l <- boot_pvalue(bvec = boots, est = est_val, null = high_bound, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = boots, est = est_val, null = low_bound, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs, + z0 = z0, acc = acc, nboot = R) + boot.pval <- min(p_l, p_u) + } + + # Report z-observed (analogous to t-observed in boot_t_test) + if (alternative %in% c("equivalence", "minimal.effect")) { + z_obs_l <- (est_val - low_bound) / se_obs + z_obs_u <- (est_val - high_bound) / se_obs + if (alternative == "equivalence") { + z_stat <- if (p_l >= p_u) z_obs_l else z_obs_u + } else { + z_stat <- if (p_l <= p_u) z_obs_l else z_obs_u + } + } else { + z_stat <- (est_val - null.value) / se_obs + } + } + + # Build output + if (output == "data.frame") { + effsize = data.frame( + estimate = raw_smd$estimate, + bias = raw_smd$estimate - median(boots, na.rm=TRUE), + SE = sd(boots), + lower.ci = ci[1], + upper.ci = ci[2], + conf.level = conf.level, + boot_ci = boot_ci, + row.names = row.names(raw_smd) + ) + return(effsize) + + } else { + # htest output + estimate <- raw_smd$estimate + names(estimate) <- smd_label + + conf.int <- c(ci[1], ci[2]) + attr(conf.int, "conf.level") <- conf.level + + # Compute SMD notation label for method description + XNAME <- "x" + YNAME <- if (!is.null(y)) "y" else NULL + sd_label <- resolve_sd_label(denom, int_denom, + xname = XNAME, + yname = if (!is.null(y)) "y" else "x", + var.equal = var.equal) + notation <- smd_notation_label(xname = XNAME, yname = YNAME, denom_label = sd_label) + + # Merge notation into the SMD label: "SMD (g[av]=(x-y)/SD_avg)" + smd_method_label <- paste0("bootstrapped Standardized Mean Difference (SMD; ", origin_author_text, " ", smd_type_letter, "[", denom_tag, "]=", notation, trim_note, ")") + + #method_suffix <- if (alternative != "none") "test" else "estimate with CI" + # removed suffix to avoid redundancy with method description in htest output, which already indicates the test type and CI level + method_desc <- paste0(sample_type, " ", smd_method_label) + + note_text <- paste0("Bootstrap CI: ", boot_ci) + + rval <- list( + estimate = estimate, + stderr = boot_se, + conf.int = conf.int, + alternative = alternative, + method = method_desc, + note = note_text, + boot = boots, + data.name = dname, + call = match.call() + ) + + if (alternative != "none") { + names(z_stat) <- "z-observed" + + if (alternative %in% c("equivalence", "minimal.effect")) { + null_val <- c(low_bound, high_bound) + names(null_val) <- c("lower bound", "upper bound") + } else { + null_val <- null.value + names(null_val) <- "SMD" + } + + rval$statistic <- z_stat + rval$p.value <- boot.pval + rval$null.value <- null_val + } + + class(rval) <- "htest" + return(rval) + } } @@ -286,7 +717,7 @@ boot_smd_calc.formula = function(formula, || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -294,7 +725,7 @@ boot_smd_calc.formula = function(formula, message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) @@ -310,7 +741,32 @@ boot_smd_calc.formula = function(formula, stop("grouping factor must have exactly 2 levels") DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("boot_smd_calc", c(DATA, list(...))) - #y$data.name <- DNAME + + # Update data.name and relabel notation in method string for htest output + if (inherits(y, "htest")) { + y$data.name <- DNAME + + # Replace generic "(x"/"(y" notation with actual group names + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + xq <- quote_if_numeric(XNAME) + yq <- quote_if_numeric(YNAME) + y$method <- gsub("=\\(x-y\\)", paste0("=(", xq, "-", yq, ")"), y$method) + y$method <- gsub("=\\(x\\)", paste0("=(", xq, ")"), y$method) + y$method <- gsub("/SD_x\\)", paste0("/SD_", xq, ")"), y$method) + y$method <- gsub("/SD_y\\)", paste0("/SD_", yq, ")"), y$method) + + # Replace generic group names in estimate label and method string + # (Glass bracket notation: [x] -> [A], [y] -> [B]) + est_name <- names(y$estimate) + est_name <- gsub("\\[x\\]", paste0("[", xq, "]"), est_name) + est_name <- gsub("\\[y\\]", paste0("[", yq, "]"), est_name) + names(y$estimate) <- est_name + + y$method <- gsub("\\[x\\]", paste0("[", xq, "]"), y$method) + y$method <- gsub("\\[y\\]", paste0("[", yq, "]"), y$method) + } + y } diff --git a/R/boot_t_TOST.R b/R/boot_t_TOST.R index da05182..cc72bdc 100644 --- a/R/boot_t_TOST.R +++ b/R/boot_t_TOST.R @@ -15,7 +15,7 @@ #' @param glass Option to calculate Glass's delta instead of Cohen's d style SMD ('glass1' uses first group's SD, 'glass2' uses second group's SD). #' @param mu a number indicating the true value of the mean for the two-tailed test (default = 0). #' @param R number of bootstrap replications (default = 1999). -#' @param boot_ci method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), or "perc" (percentile bootstrap). +#' @param boot_ci method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap). #' @param subset an optional vector specifying a subset of observations to be used. #' @param na.action a function indicating what should happen when the data contain NAs. #' @param ... further arguments to be passed to or from methods. @@ -28,13 +28,28 @@ #' The bootstrap procedure follows these steps: #' * Resample with replacement from the original data to create R bootstrap samples #' * For each bootstrap sample, calculate test statistics and effect sizes -#' * Use the distribution of bootstrap results to compute p-values and confidence intervals -#' * Combine results using the specified bootstrap confidence interval method +#' * Compute p-values and confidence intervals using the selected bootstrap method #' -#' Three types of bootstrap confidence intervals are available: -#' * Studentized ("stud"): Accounts for the variability in the standard error estimate -#' * Basic/Empirical ("basic"): Uses the empirical distribution of bootstrap estimates -#' * Percentile ("perc"): Uses percentiles of the bootstrap distribution +#' ## Bootstrap Confidence Interval Methods +#' +#' Four types of bootstrap confidence intervals are available via the `boot_ci` argument: +#' * **Studentized ("stud")**: Uses the bootstrap distribution of pivotal t-statistics +#' to account for variability in standard error estimates. This is the default +#' and usually provides the most accurate coverage. +#' * **Basic/Empirical ("basic")**: Reflects the bootstrap distribution of estimates +#' around the observed value. +#' * **Percentile ("perc")**: Uses percentiles of the bootstrap distribution directly. +#' * **Bias-corrected and accelerated ("bca")**: Corrects for both bias and skewness +#' in the bootstrap distribution using jackknife-based acceleration. +#' +#' ## Bootstrap P-values +#' +#' The p-value for each test (two-tailed and both one-sided) is computed using +#' the method that matches the selected `boot_ci`, ensuring that p < alpha if and +#' only if the corresponding confidence interval excludes the null value +#' (CI inversion principle). Previously, all bootstrap CI methods used the +#' studentized (pivot) p-value, which could produce p-values inconsistent with +#' non-studentized CIs. #' #' For two-sample tests, the test is of \eqn{\bar x - \bar y} (mean of x minus mean of y). #' For paired samples, the test is of the difference scores (z), @@ -122,7 +137,7 @@ boot_t_TOST.default <- function(x, glass = NULL, mu = 0, R = 1999, - boot_ci = c("stud", "basic", "perc"), + boot_ci = c("stud", "basic", "perc", "bca"), ...){ boot_ci = match.arg(boot_ci) @@ -491,20 +506,105 @@ boot_t_TOST.default <- function(x, tstat = nullTOST$TOST$t[1] tstat_l = nullTOST$TOST$t[2] tstat_u = nullTOST$TOST$t[3] - #m_vec = append(m_vec, nullTOST$effsize$estimate[1]) - #d_vec = append(d_vec, nullTOST$effsize$estimate[2]) - boot.pval <- 2 * min(mean(TSTAT <= tstat), mean(TSTAT > tstat)) + boot.se = sd(m_vec) - if(hypothesis == "EQU"){ - p_l = mean(TSTAT > tstat_l) - p_u = mean(TSTAT < tstat_u) - } else{ - p_l = mean(TSTAT < tstat_l) - p_u = mean(TSTAT > tstat_u) + # Jackknife for BCa (if needed) + if (boot_ci == "bca") { + if (is.null(y) && !paired) { + # One-sample + n_jack <- nx + jack_m <- numeric(n_jack) + jack_d <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- t_TOST(x = x[-j], + hypothesis = hypothesis, + paired = FALSE, + var.equal = TRUE, + low_eqbound = low_eqbound, + high_eqbound = high_eqbound, + eqbound_type = eqbound_type, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = FALSE, + smd_ci = "z") + jack_m[j] <- res_jack$effsize$estimate[1] + jack_d[j] <- res_jack$smd$d + } + } else if (paired) { + # Paired: delete one pair at a time + n_jack <- nrow(data) + jack_m <- numeric(n_jack) + jack_d <- numeric(n_jack) + for (j in seq_len(n_jack)) { + res_jack <- t_TOST(x = data$i1[-j], + y = data$i2[-j], + hypothesis = hypothesis, + paired = TRUE, + var.equal = FALSE, + low_eqbound = low_eqbound, + high_eqbound = high_eqbound, + eqbound_type = eqbound_type, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + glass = glass, + rm_correction = rm_correction, + smd_ci = "z") + jack_m[j] <- res_jack$effsize$estimate[1] + jack_d[j] <- res_jack$smd$d + } + } else { + # Two-sample: pooled jackknife + n_jack <- nx + ny + jack_m <- numeric(n_jack) + jack_d <- numeric(n_jack) + for (j in seq_len(nx)) { + res_jack <- t_TOST(x = x[-j], + y = y, + hypothesis = hypothesis, + paired = paired, + var.equal = var.equal, + low_eqbound = low_eqbound, + high_eqbound = high_eqbound, + eqbound_type = eqbound_type, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = FALSE, + smd_ci = "z") + jack_m[j] <- res_jack$effsize$estimate[1] + jack_d[j] <- res_jack$smd$d + } + for (j in seq_len(ny)) { + res_jack <- t_TOST(x = x, + y = y[-j], + hypothesis = hypothesis, + paired = paired, + var.equal = var.equal, + low_eqbound = low_eqbound, + high_eqbound = high_eqbound, + eqbound_type = eqbound_type, + alpha = alpha, + mu = mu, + bias_correction = bias_correction, + rm_correction = FALSE, + smd_ci = "z") + jack_m[nx + j] <- res_jack$effsize$estimate[1] + jack_d[nx + j] <- res_jack$smd$d + } + } } - boot.se = sd(m_vec) + # Pre-compute BCa parameters for p-value use + z0 <- NULL; acc <- NULL + if (boot_ci == "bca") { + bca_par <- bca_params(m_vec, nullTOST$effsize$estimate[1], jack_m) + z0 <- bca_par$z0; acc <- bca_par$acc + } + + # CI computation boot.cint <- switch(boot_ci, "stud" = stud(m_vec, boots_se = m_se_vec, @@ -512,7 +612,9 @@ boot_t_TOST.default <- function(x, se0 = nullTOST$effsize$SE[1], alpha*2), "basic" = basic(m_vec, t0 = nullTOST$effsize$estimate[1], alpha*2), - "perc" = perc(m_vec, alpha*2)) + "perc" = perc(m_vec, alpha*2), + "bca" = bca_ci(boots_est = m_vec, t0 = nullTOST$effsize$estimate[1], + jack_est = jack_m, alpha = alpha*2)) d.cint <- switch(boot_ci, "stud" = stud(d_vec, boots_se = d_se_vec, @@ -520,9 +622,42 @@ boot_t_TOST.default <- function(x, se0 = nullTOST$effsize$SE[2], alpha*2), "basic" = basic(d_vec,t0 = nullTOST$effsize$estimate[2], alpha*2), - "perc" = perc(d_vec, alpha*2)) + "perc" = perc(d_vec, alpha*2), + "bca" = bca_ci(boots_est = d_vec, t0 = nullTOST$effsize$estimate[2], + jack_est = jack_d, alpha = alpha*2)) d.se = sd(d_vec) + # P-value computation (method-consistent with CI) + raw_est <- nullTOST$effsize$estimate[1] + se_obs_raw <- nullTOST$effsize$SE[1] + low_eq <- nullTOST$eqb$low_eq[1] + high_eq <- nullTOST$eqb$high_eq[1] + + boot.pval <- boot_pvalue(bvec = m_vec, est = raw_est, null = mu, + alternative = "two.sided", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_raw, + z0 = z0, acc = acc, nboot = R) + + if(hypothesis == "EQU"){ + p_l <- boot_pvalue(bvec = m_vec, est = raw_est, null = low_eq, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_raw, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = raw_est, null = high_eq, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_raw, + z0 = z0, acc = acc, nboot = R) + } else { + p_l <- boot_pvalue(bvec = m_vec, est = raw_est, null = low_eq, + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_raw, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = raw_est, null = high_eq, + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = se_obs_raw, + z0 = z0, acc = acc, nboot = R) + } + TOST = nullTOST$TOST TOST$p.value = c(boot.pval, p_l, p_u) effsize = nullTOST$effsize @@ -628,7 +763,7 @@ boot_t_TOST.formula <- function (formula, data, subset, na.action, ...){ || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -636,7 +771,7 @@ boot_t_TOST.formula <- function (formula, data, subset, na.action, ...){ message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) diff --git a/R/boot_t_test.R b/R/boot_t_test.R index 0ffbddc..fb2adfe 100644 --- a/R/boot_t_test.R +++ b/R/boot_t_test.R @@ -2,7 +2,8 @@ #' @description #' `r lifecycle::badge('stable')` #' -#' Performs t-tests with bootstrapped p-values and confidence intervals. This function supports +#' Performs t-tests with bootstrapped p-values and confidence intervals, with optional +#' trimmed means (Yuen's approach) for robust inference. This function supports #' standard hypothesis testing alternatives as well as equivalence and minimal effect testing, #' all with the familiar `htest` output structure. #' @@ -27,6 +28,11 @@ #' * For standard alternatives: a single value (default = 0) #' * For equivalence/minimal.effect: two values representing the lower and upper bounds #' +#' @param tr the fraction (0 to 0.5) of observations to be trimmed from +#' each end before computing the mean and winsorized variance. +#' Default is 0 (no trimming). When tr > 0, the function performs +#' a bootstrapped Yuen's trimmed t-test. +#' #' @details #' This function performs bootstrapped t-tests, providing more robust inference than standard #' parametric t-tests. It supports one-sample, two-sample (independent), and paired designs, @@ -39,15 +45,31 @@ #' * Compute the p-value by comparing the original test statistic to the bootstrap distribution #' * Calculate confidence intervals using the specified bootstrap method #' -#' Three bootstrap confidence interval methods are available: -#' - *Studentized bootstrap ("stud")*: Accounts for the variability in standard error estimates -#' - *Basic bootstrap ("basic")*: Uses the empirical distribution of bootstrap estimates -#' - *Percentile bootstrap ("perc")*: Uses percentiles of the bootstrap distribution directly +#' ## Bootstrap Confidence Interval Methods +#' +#' Four bootstrap confidence interval methods are available via the `boot_ci` argument: +#' - **Studentized bootstrap ("stud")**: Uses the bootstrap distribution of pivotal +#' t-statistics to account for variability in standard error estimates. This is the +#' default and usually provides the most accurate coverage. +#' - **Basic bootstrap ("basic")**: Reflects the bootstrap distribution of estimates +#' around the observed value. +#' - **Percentile bootstrap ("perc")**: Uses percentiles of the bootstrap distribution directly. +#' - **Bias-corrected and accelerated ("bca")**: Corrects for both bias and skewness in the +#' bootstrap distribution using jackknife-based acceleration. Most accurate when the +#' bootstrap distribution is skewed, but computationally more expensive. +#' +#' ## Bootstrap P-values +#' +#' The p-value is computed using the method that matches the selected `boot_ci`, +#' ensuring that p < alpha if and only if the corresponding confidence interval +#' excludes the null value (CI inversion principle). Previously, all bootstrap +#' CI methods used the studentized (pivot) p-value, which could produce p-values +#' inconsistent with non-studentized CIs. #' #' For different alternatives, the p-values are calculated as follows: -#' * "two.sided": Proportion of bootstrap statistics at least as extreme as the observed statistic (in either direction), multiplied by 2 -#' * "less": Proportion of bootstrap statistics less than or equal to the observed statistic -#' * "greater": Proportion of bootstrap statistics greater than or equal to the observed statistic +#' * "two.sided": Two-tailed p-value from the bootstrap distribution +#' * "less": One-sided p-value for the hypothesis that the true value is less than the null +#' * "greater": One-sided p-value for the hypothesis that the true value is greater than the null #' * "equivalence": Maximum of two one-sided p-values (for lower and upper bounds) #' * "minimal.effect": Minimum of two one-sided p-values (for lower and upper bounds) #' @@ -57,6 +79,13 @@ #' wherein \eqn{z = x - y}, and the test is of \eqn{\bar z} (mean of the difference scores). #' For one-sample tests, the test is of \eqn{\bar x} (mean of x). #' +#' When `tr > 0`, the function uses Yuen's trimmed t-test approach: trimmed means +#' are computed by removing the fraction `tr` of observations from each tail, +#' and winsorized variances are used in place of standard variances. This provides +#' robustness against outliers and heavy-tailed distributions. The bootstrap +#' procedure recomputes trimmed means and winsorized standard errors for each +#' bootstrap replicate. +#' #' Unlike the `t_TOST` function, this function returns a standard `htest` object for #' compatibility with other R functions, while still providing the benefits of bootstrapping. #' @@ -115,13 +144,20 @@ #' mu = c(-3, 3), #' R = 999) #' +#' # Example 6: Bootstrapped Yuen's trimmed t-test (10% trimming) +#' boot_t_test(extra ~ group, data = sleep, tr = 0.1, R = 999) +#' #' @references #' Efron, B., & Tibshirani, R. J. (1994). An introduction to the bootstrap. CRC press. #' +#' Yuen, K. K. (1974). The two-sample trimmed t for unequal population variances. +#' Biometrika, 61(1), 165-170. +#' #' @family Robust tests #' @name boot_t_test #' @export boot_t_test +# TODO: add xname and yname arguments to allow user-specified group labels boot_t_test <- function(x, ...){ UseMethod("boot_t_test") } @@ -141,7 +177,8 @@ boot_t_test.default <- function(x, "minimal.effect"), mu = 0, alpha = 0.05, - boot_ci = c("stud","basic","perc"), + tr = 0, + boot_ci = c("stud","basic","perc","bca"), R = 1999, ...){ alternative = match.arg(alternative) boot_ci = match.arg(boot_ci) @@ -151,6 +188,11 @@ boot_t_test.default <- function(x, stop("'alpha' must be a single number between 0 and 1") } + if (!missing(tr) && (length(tr) != 1 || !is.finite(tr) || + tr < 0 || tr >= 0.5)) { + stop("'tr' must be a single number between 0 and 0.5 (exclusive)") + } + if (!is.null(y)) { dname <- paste(deparse(substitute(x)), "and", @@ -160,15 +202,34 @@ boot_t_test.default <- function(x, dname <- deparse(substitute(x)) } - null_test = simple_htest(x = x, - y = y, - test = "t.test", - var.equal = var.equal, - paired = paired, - alternative = alternative, - mu = mu, - alpha = 0.05) - mu = null_test$null.value + # When tr == 0, use simple_htest for initial statistics (backward compat) + # When tr > 0, compute initial stats directly since t.test() doesn't support trimming + if (tr == 0) { + null_test = simple_htest(x = x, + y = y, + test = "t.test", + var.equal = var.equal, + paired = paired, + alternative = alternative, + mu = mu, + alpha = 0.05) + mu = null_test$null.value + } else { + # Handle mu for equivalence/minimal.effect the same way simple_htest does + if (alternative %in% c("equivalence", "minimal.effect")) { + if (length(mu) == 1) { + if (mu == 0) { + stop("mu cannot be zero if alternative is equivalence or minimal.effect") + } + mu = c(mu, -1 * mu) + } + mu = sort(mu) + names(mu) = rep(paste0("trimmed mean difference (tr = ", tr, ")"), 2) + } else { + names(mu) = paste0("trimmed mean difference (tr = ", tr, ")") + } + } + m_vec <- rep(NA, times=length(R)) # mean difference vector m_se_vec <- rep(NA, times=length(R)) # mean difference vector if(alternative %in% c("equivalence","minimal.effect")){ @@ -177,6 +238,12 @@ boot_t_test.default <- function(x, conf.level = 1-alpha } + # CI method label for method string + ci_label <- switch(boot_ci, + "basic" = "(basic)", + "perc" = " (percentile)", + "bca" = " (BCa)", + "stud" = " (studentized)") if(!is.null(y)){ dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) @@ -194,10 +261,6 @@ boot_t_test.default <- function(x, }else{ dname <- deparse(substitute(x)) - #if (paired) { - # stop("'y' is missing for paired test") - #} - xok <- !is.na(x) yok <- NULL } @@ -207,120 +270,322 @@ boot_t_test.default <- function(x, y <- NULL } nx <- length(x) - mx <- mean(x) - vx <- var(x) + + # Sample size check for trimming + if (tr > 0) { + g <- floor(tr * nx) + effective_x <- nx - 2 * g + if (effective_x < 2) { + min_n <- ceiling(2 / (1 - 2 * tr)) + 1 + stop("Sample size too small for specified trimming proportion. ", + "With tr = ", tr, ", need at least ", min_n, + " observations, but only have ", nx, ".") + } + } + + # Compute location and scale for x + if (tr > 0) { + mx <- trimmed_mean(x, tr) + vx <- winsorized_var(x, tr) + } else { + mx <- mean(x) + vx <- var(x) + } + if (is.null(y)) { if (nx < 2) stop("not enough 'x' observations") - df <- nx - 1 - stderr <- sqrt(vx/nx) + + if (tr > 0) { + hx <- effective_n(nx, tr) + df <- hx - 1 + stderr <- sqrt((nx - 1) * vx / (hx * (hx - 1))) + } else { + df <- nx - 1 + stderr <- sqrt(vx/nx) + } + if (stderr < 10 * .Machine$double.eps * abs(mx)){ stop("data are essentially constant") } tstat <- (mx - mu)/stderr - method <- if (paired) "Bootstrapped Paired t-test" else "Bootstrapped One Sample t-test" - #estimate <- setNames(mx, if (paired) "mean of the differences" else "mean of x") - #x.cent <- x - mx # remove to have an untransformed matrix - X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) - MX <- rowMeans(X - mx) - VX <- rowSums((X - MX) ^ 2) / (nx - 1) - MZ2 = NA - VZ2 = NA - for(i in 1:R){ - zi = X[i,] - MZ2[i] = mean(zi - mx) - VZ2[i] <- sum((zi - MZ2[i]) ^ 2) / (nx - 1) #rowSums((X - MX) ^ 2) / (nx - 1) + # Method string + if (paired) { + method <- if (tr > 0) "Bootstrapped Paired Yuen t-test" else "Bootstrapped Paired t-test" + } else { + method <- if (tr > 0) "Bootstrapped One Sample Yuen t-test" else "Bootstrapped One Sample t-test" + } + + method = paste0(method, " ", ci_label) + + # Estimate labels + XNAME <- "x" + YNAME <- "y" + if (tr > 0) { + estimate <- setNames(mx, if (paired) + paste0("trimmed mean of the differences (z = ", XNAME, " - ", YNAME, ", tr = ", tr, ")") + else paste0("trimmed mean of ", XNAME)) + } else { + estimate <- setNames(mx, if (paired) + ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = TRUE) + else ttest_estimate_label(type = "t", xname = XNAME, yname = NULL, paired = FALSE)) } - STDERR <- sqrt(VX/nx) - TSTAT <- (MX)/STDERR - #TSTAT_low <- (MX-low_eqbound)/STDERR - #TSTAT_high <- (MX-high_eqbound)/STDERR - EFF <- MX+mx + if (tr == 0) { + x.cent <- x - mx + X <- matrix(sample(x.cent, size = nx*R, replace = TRUE), nrow = R) - for(i in 1:nrow(X)){ - dat = X[i,] + MX <- rowMeans(X) + VX <- rowSums((X - MX) ^ 2) / (nx - 1) - m_vec[i] <- mean(dat, na.rm=TRUE) # mean difference vector - m_se_vec[i] <- sd(dat, na.rm = TRUE)/sqrt(length(na.omit(dat))) + STDERR <- sqrt(VX/nx) + TSTAT <- MX/STDERR + EFF <- MX + mx + for(i in 1:nrow(X)){ + dat = X[i,] + mx + m_vec[i] <- mean(dat, na.rm=TRUE) + m_se_vec[i] <- sd(dat, na.rm = TRUE)/sqrt(length(na.omit(dat))) + } + } else { + # Trimmed path + X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) + TSTAT <- numeric(R) + hx <- effective_n(nx, tr) + + for (i in 1:R) { + dat <- X[i, ] + mx_boot <- trimmed_mean(dat, tr) + vx_boot <- winsorized_var(dat, tr) + se_boot <- sqrt((nx - 1) * vx_boot / (hx * (hx - 1))) + + # Centered trimmed mean (under the null) + mx_centered <- trimmed_mean(dat - mx, tr) + + if (se_boot > 10 * .Machine$double.eps) { + TSTAT[i] <- mx_centered / se_boot + } else { + TSTAT[i] <- 0 + } + + m_vec[i] <- mx_boot + m_se_vec[i] <- se_boot + } } } if(!is.null(y) && !paired){ ny <- length(y) + + # Sample size check for y with trimming + if (tr > 0) { + g_y <- floor(tr * ny) + effective_y <- ny - 2 * g_y + if (effective_y < 2) { + min_n <- ceiling(2 / (1 - 2 * tr)) + 1 + stop("Sample size too small for specified trimming proportion. ", + "With tr = ", tr, ", need at least ", min_n, + " observations, but only have ", ny, ".") + } + } + if(nx < 1 || (!var.equal && nx < 2)) stop("not enough 'x' observations") if(ny < 1 || (!var.equal && ny < 2)) stop("not enough 'y' observations") if(var.equal && nx + ny < 3) stop("not enough observations") - my <- mean(y) - vy <- var(y) - method <- paste("Bootstrapped", paste(if (!var.equal) "Welch", "Two Sample t-test")) - estimate <- c(mx, my) - names(estimate) <- c("mean of x", "mean of y") - if(var.equal){ - df <- nx + ny - 2 - v <- 0 - if (nx > 1){ - v <- v + (nx - 1) * vx - } - if (ny > 1){ - v <- v + (ny - 1) * vy - } + if (tr > 0) { + my <- trimmed_mean(y, tr) + vy <- winsorized_var(y, tr) + } else { + my <- mean(y) + vy <- var(y) + } - v <- v/df - stderr <- sqrt(v * (1/nx + 1/ny)) - z <- c(x, y) - mz <- mean(z) - #Z <- matrix(sample(z, size = (nx+ny)*R, replace = TRUE), nrow = R) - X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) - Y <- matrix(sample(y, size = ny*R, replace = TRUE), nrow = R) - MX <- rowMeans(X - mx + mz) - MY <- rowMeans(Y - my + mz) - V <- (rowSums((X-MX)^2) + rowSums((Y-MY)^2))/df - STDERR <- sqrt(V*(1/nx + 1/ny)) - EFF <- (MX+mx) - (MY+my) - - #d_vec <- rep(NA, times=length(R)) - for(i in 1:nrow(X)){ - #dat = Z[i,] - dat_x = X[i,]#dat[1:nx] - dat_y = Y[i,]#dat[(nx+1):(nx+ny)] + # Method string + if (tr > 0) { + method <- paste("Bootstrapped", + if (!var.equal) "Welch", + "Yuen Two Sample t-test") + method <- gsub("\\s+", " ", method) + } else { + method <- paste("Bootstrapped", paste(if (!var.equal) "Welch", "Two Sample t-test "), + ci_label) + } - m_vec[i] <- mean(dat_x, na.rm=TRUE) - mean(dat_y,na.rm=TRUE) # mean difference vector - m_se_vec[i] <- sqrt(sd(dat_x, na.rm=TRUE)^2/length(na.omit(dat_x)) + sd(dat_y, na.rm=TRUE)^2/length(na.omit(dat_y))) + # Estimate labels + XNAME <- "x" + YNAME <- "y" + if (tr > 0) { + estimate <- c(mx, my, mx - my) + names(estimate) <- c(paste0("trimmed mean of ", XNAME), + paste0("trimmed mean of ", YNAME), + paste0("trimmed mean difference (", XNAME, " - ", YNAME, ", tr = ", tr, ")")) + } else { + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = FALSE) + estimate <- c(mx, my) + names(estimate) <- est_labels + } + if(var.equal){ + if (tr > 0) { + hx <- effective_n(nx, tr) + hy <- effective_n(ny, tr) + df <- pooled_wins_df(nx, ny, tr) + v_pooled <- ((hx - 1) * vx + (hy - 1) * vy) / df + stderr <- sqrt(v_pooled * ((nx - 1) / (hx * (hx - 1)) + + (ny - 1) / (hy * (hy - 1)))) + } else { + df <- nx + ny - 2 + v <- 0 + if (nx > 1){ + v <- v + (nx - 1) * vx + } + if (ny > 1){ + v <- v + (ny - 1) * vy + } + v <- v/df + stderr <- sqrt(v * (1/nx + 1/ny)) } - }else{ - stderrx <- sqrt(vx/nx) - stderry <- sqrt(vy/ny) - stderr <- sqrt(stderrx^2 + stderry^2) - df <- stderr^4/(stderrx^4/(nx - 1) + stderry^4/(ny - 1)) + z <- c(x, y) - mz <- mean(z) - x.cent <- x - mx + mz - y.cent <- y - my + mz - X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) - Y <- matrix(sample(y, size = ny*R, replace = TRUE), nrow = R) - MX <- rowMeans(X - mx + mz) - MY <- rowMeans(Y - my + mz) - VX <- rowSums((X-MX)^2)/(nx-1) - VY <- rowSums((Y-MY)^2)/(ny-1) - STDERR <- sqrt(VX/nx + VY/ny) - EFF <- (MX+mx) - (MY+my) + if (tr > 0) { + mz <- trimmed_mean(z, tr) + } else { + mz <- mean(z) + } - for(i in 1:nrow(X)){ - #dat = Z[i,] - dat_x = X[i,]#dat[1:nx] - dat_y = Y[i,]#dat[(nx+1):(nx+ny)] + if (tr == 0) { + x.cent <- x - mx + mz + y.cent <- y - my + mz + X <- matrix(sample(x.cent, size = nx*R, replace = TRUE), nrow = R) + Y <- matrix(sample(y.cent, size = ny*R, replace = TRUE), nrow = R) + + MX <- rowMeans(X) + MY <- rowMeans(Y) + V <- (rowSums((X-MX)^2) + rowSums((Y-MY)^2))/df + STDERR <- sqrt(V*(1/nx + 1/ny)) + EFF <- (MX + mx) - (MY + my) + + for(i in 1:nrow(X)){ + dat_x = X[i,] + mx - mz + dat_y = Y[i,] + my - mz + m_vec[i] <- mean(dat_x, na.rm=TRUE) - mean(dat_y, na.rm=TRUE) + m_se_vec[i] <- sqrt(sd(dat_x, na.rm=TRUE)^2/length(na.omit(dat_x)) + sd(dat_y, na.rm=TRUE)^2/length(na.omit(dat_y))) + } + } else { + # Trimmed path - equal variance + X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) + Y <- matrix(sample(y, size = ny*R, replace = TRUE), nrow = R) + TSTAT <- numeric(R) + hx <- effective_n(nx, tr) + hy <- effective_n(ny, tr) + df_pool <- pooled_wins_df(nx, ny, tr) + + for (i in 1:R) { + dat_x <- X[i, ] + dat_y <- Y[i, ] + + mx_boot <- trimmed_mean(dat_x, tr) + my_boot <- trimmed_mean(dat_y, tr) + vx_boot <- winsorized_var(dat_x, tr) + vy_boot <- winsorized_var(dat_y, tr) + + v_pooled_boot <- ((hx - 1) * vx_boot + (hy - 1) * vy_boot) / df_pool + se_boot <- sqrt(v_pooled_boot * ((nx - 1) / (hx * (hx - 1)) + + (ny - 1) / (hy * (hy - 1)))) + + # Centered under the null + mx_cent <- trimmed_mean(dat_x - mx + mz, tr) + my_cent <- trimmed_mean(dat_y - my + mz, tr) + + if (se_boot > 10 * .Machine$double.eps) { + TSTAT[i] <- (mx_cent - my_cent) / se_boot + } else { + TSTAT[i] <- 0 + } + + m_vec[i] <- mx_boot - my_boot + m_se_vec[i] <- se_boot + } + } + }else{ + if (tr > 0) { + hx <- effective_n(nx, tr) + hy <- effective_n(ny, tr) + dx <- (nx - 1) * vx / (hx * (hx - 1)) + dy <- (ny - 1) * vy / (hy * (hy - 1)) + stderr <- sqrt(dx + dy) + df <- yuen_welch_df(nx, ny, vx, vy, tr) + } else { + stderrx <- sqrt(vx/nx) + stderry <- sqrt(vy/ny) + stderr <- sqrt(stderrx^2 + stderry^2) + df <- stderr^4/(stderrx^4/(nx - 1) + stderry^4/(ny - 1)) + } - m_vec[i] <- mean(dat_x, na.rm=TRUE) - mean(dat_y,na.rm=TRUE) # mean difference vector - m_se_vec[i] <- sqrt(sd(dat_x, na.rm=TRUE)^2/length(na.omit(dat_x)) + sd(dat_y, na.rm=TRUE)^2/length(na.omit(dat_y))) + z <- c(x, y) + if (tr > 0) { + mz <- trimmed_mean(z, tr) + } else { + mz <- mean(z) + } + if (tr == 0) { + x.cent <- x - mx + mz + y.cent <- y - my + mz + X <- matrix(sample(x.cent, size = nx*R, replace = TRUE), nrow = R) + Y <- matrix(sample(y.cent, size = ny*R, replace = TRUE), nrow = R) + + MX <- rowMeans(X) + MY <- rowMeans(Y) + VX <- rowSums((X-MX)^2)/(nx-1) + VY <- rowSums((Y-MY)^2)/(ny-1) + STDERR <- sqrt(VX/nx + VY/ny) + EFF <- (MX + mx) - (MY + my) + + for(i in 1:nrow(X)){ + dat_x = X[i,] + mx - mz + dat_y = Y[i,] + my - mz + m_vec[i] <- mean(dat_x, na.rm=TRUE) - mean(dat_y, na.rm=TRUE) + m_se_vec[i] <- sqrt(sd(dat_x, na.rm=TRUE)^2/length(na.omit(dat_x)) + sd(dat_y, na.rm=TRUE)^2/length(na.omit(dat_y))) + } + } else { + # Trimmed path - Welch/Yuen + X <- matrix(sample(x, size = nx*R, replace = TRUE), nrow = R) + Y <- matrix(sample(y, size = ny*R, replace = TRUE), nrow = R) + TSTAT <- numeric(R) + hx <- effective_n(nx, tr) + hy <- effective_n(ny, tr) + + for (i in 1:R) { + dat_x <- X[i, ] + dat_y <- Y[i, ] + + mx_boot <- trimmed_mean(dat_x, tr) + my_boot <- trimmed_mean(dat_y, tr) + vx_boot <- winsorized_var(dat_x, tr) + vy_boot <- winsorized_var(dat_y, tr) + + dx_boot <- (nx - 1) * vx_boot / (hx * (hx - 1)) + dy_boot <- (ny - 1) * vy_boot / (hy * (hy - 1)) + se_boot <- sqrt(dx_boot + dy_boot) + + mx_cent <- trimmed_mean(dat_x - mx + mz, tr) + my_cent <- trimmed_mean(dat_y - my + mz, tr) + + if (se_boot > 10 * .Machine$double.eps) { + TSTAT[i] <- (mx_cent - my_cent) / se_boot + } else { + TSTAT[i] <- 0 + } + + m_vec[i] <- mx_boot - my_boot + m_se_vec[i] <- se_boot + } } } if (stderr < 10 * .Machine$double.eps * max(abs(mx), abs(my))){ @@ -328,12 +593,10 @@ boot_t_test.default <- function(x, } tstat <- (mx - my - mu)/stderr - # Remember tstat[which.max( abs(tstat) )] - #TSTAT <- (MX - MY)/STDERR - TSTAT <- (MX-MY)/STDERR - #TSTAT_low <- (MX-low_eqbound)/STDERR - #TSTAT_high <- (MX-high_eqbound)/STDERR + if (tr == 0) { + TSTAT <- (MX-MY)/STDERR + } } if(is.null(y)){ @@ -342,78 +605,82 @@ boot_t_test.default <- function(x, diff = mx-my } - if(alternative %in% c("equivalence", "minimal.effect")){ - + # Jackknife for BCa (if needed) + if (boot_ci == "bca") { + if (is.null(y)) { + # One-sample or paired (paired already converted x <- x - y above) + n_jack <- nx + jack_est <- numeric(n_jack) + for (j in seq_len(n_jack)) { + jack_est[j] <- trimmed_mean(x[-j], tr) + } + } else { + # Two-sample: pooled jackknife (delete one from combined) + n_jack <- nx + ny + jack_est <- numeric(n_jack) + for (j in seq_len(nx)) { + jack_est[j] <- trimmed_mean(x[-j], tr) - trimmed_mean(y, tr) + } + for (j in seq_len(ny)) { + jack_est[nx + j] <- trimmed_mean(x, tr) - trimmed_mean(y[-j], tr) + } + } + } + if(alternative %in% c("equivalence", "minimal.effect")){ tstat_l = (diff-min(mu))/stderr tstat_u = (diff-max(mu))/stderr } - if (alternative == "less") { - - boot.pval <- mean(TSTAT < tstat) - - boot.cint <- switch(boot_ci, - "stud" = stud(m_vec, - boots_se = m_se_vec, - t0 = diff, - se0 = null_test$stderr, - alpha = alpha*2), - "basic" = basic(m_vec, t0 = diff, alpha*2), - "perc" = perc(m_vec, alpha*2)) - - } - - if(alternative == "greater") { - boot.pval <- mean(TSTAT > tstat) - boot.cint <- switch(boot_ci, - "stud" = stud(m_vec, - boots_se = m_se_vec, - t0 = diff, - se0 = null_test$stderr, - alpha*2), - "basic" = basic(m_vec, t0 = diff, alpha*2), - "perc" = perc(m_vec, alpha*2)) - } + # se0 for studentized CI: use the observed stderr + se0_val <- stderr - if(alternative == "two.sided"){ - boot.pval <- 2*min(mean(TSTAT <= tstat), mean(TSTAT > tstat)) - boot.cint <- switch(boot_ci, - "stud" = stud(m_vec, - boots_se = m_se_vec, - t0 = diff, - se0 = null_test$stderr, - alpha), - "basic" = basic(m_vec, t0 = diff, alpha), - "perc" = perc(m_vec, alpha)) + # Pre-compute BCa parameters for p-value use + z0 <- NULL; acc <- NULL + if (boot_ci == "bca") { + bca_par <- bca_params(m_vec, diff, jack_est) + z0 <- bca_par$z0; acc <- bca_par$acc } - if(alternative == "equivalence") { - p_l = mean(TSTAT > tstat_l) - p_u = mean(TSTAT < tstat_u) + # CI computation (alpha depends on alternative) + ci_alpha <- if (alternative == "two.sided") alpha else alpha * 2 + boot.cint <- switch(boot_ci, + "stud" = stud(m_vec, + boots_se = m_se_vec, + t0 = diff, + se0 = se0_val, + alpha = ci_alpha), + "basic" = basic(m_vec, t0 = diff, ci_alpha), + "perc" = perc(m_vec, ci_alpha), + "bca" = bca_ci(boots_est = m_vec, t0 = diff, + jack_est = jack_est, alpha = ci_alpha)) + + # P-value computation (method-consistent with CI) + if (alternative %in% c("two.sided", "greater", "less")) { + boot.pval <- boot_pvalue(bvec = m_vec, est = diff, null = mu, + alternative = alternative, boot_ci = boot_ci, + tvec = TSTAT, se_obs = stderr, + z0 = z0, acc = acc, nboot = R) + } else if (alternative == "equivalence") { + p_l <- boot_pvalue(bvec = m_vec, est = diff, null = min(mu), + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = stderr, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = diff, null = max(mu), + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = stderr, + z0 = z0, acc = acc, nboot = R) boot.pval <- max(p_l, p_u) - boot.cint <- switch(boot_ci, - "stud" = stud(m_vec, - boots_se = m_se_vec, - t0 = diff, - se0 = null_test$stderr, - alpha*2), - "basic" = basic(m_vec, t0 = diff, alpha*2), - "perc" = perc(m_vec, alpha*2)) - } - - if(alternative == "minimal.effect") { - p_l = mean(TSTAT < tstat_l) - p_u = mean(TSTAT > tstat_u) - boot.pval <- min(p_l,p_u) - boot.cint <- switch(boot_ci, - "stud" = stud(m_vec, - boots_se = m_se_vec, - t0 = diff, - se0 = null_test$stderr, - alpha*2), - "basic" = basic(m_vec, t0 = diff, alpha*2), - "perc" = perc(m_vec, alpha*2)) + } else if (alternative == "minimal.effect") { + p_l <- boot_pvalue(bvec = m_vec, est = diff, null = max(mu), + alternative = "greater", boot_ci = boot_ci, + tvec = TSTAT, se_obs = stderr, + z0 = z0, acc = acc, nboot = R) + p_u <- boot_pvalue(bvec = m_vec, est = diff, null = min(mu), + alternative = "less", boot_ci = boot_ci, + tvec = TSTAT, se_obs = stderr, + z0 = z0, acc = acc, nboot = R) + boot.pval <- min(p_l, p_u) } boot.se = sd(m_vec, na.rm = TRUE) @@ -444,19 +711,45 @@ boot_t_test.default <- function(x, names(tstat_report) <- "t-observed" names(df) <- "df" + # Build estimate and data.name from appropriate sources + if (tr > 0) { + rval_estimate <- estimate + rval_null <- mu + rval_dname <- dname + } else { + rval_estimate <- null_test$estimate + rval_null <- null_test$null.value + rval_dname <- null_test$data.name + } + + # Compute sample_size + if (tr > 0) { + # When tr > 0, compute directly from data + # Note: for paired, x <- x - y has already been done so y is NULL + if (is.null(y)) { + sample_size <- c(n = nx) + } else { + sample_size <- c(nx = nx, ny = ny) + } + } else { + # When tr == 0, inherit from simple_htest which now includes sample_size + sample_size <- null_test$sample_size + } + rval = list( statistic = tstat_report, parameter = df, p.value = boot.pval, stderr = boot.se, conf.int = boot.cint, - estimate = null_test$estimate, - null.value = null_test$null.value, + estimate = rval_estimate, + null.value = rval_null, alternative = alternative, method = method, boot = m_vec, - data.name = null_test$data.name, - call = match.call() + data.name = rval_dname, + call = match.call(), + sample_size = sample_size ) class(rval) = "htest" @@ -473,7 +766,7 @@ boot_t_test.formula <- function (formula, data, subset, na.action, ...){ || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -481,7 +774,7 @@ boot_t_test.formula <- function (formula, data, subset, na.action, ...){ message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) @@ -498,5 +791,38 @@ boot_t_test.formula <- function (formula, data, subset, na.action, ...){ DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("boot_t_test", c(DATA, list(...))) y$data.name <- DNAME + + # Resolve actual group labels from factor levels + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + xq <- quote_if_numeric(XNAME) + yq <- quote_if_numeric(YNAME) + + is_paired <- isTRUE(dots$paired) + tr_val <- if (!is.null(dots$tr)) dots$tr else 0 + + if (tr_val > 0) { + # Trimmed labels: substitute group names + nms <- names(y$estimate) + nms <- gsub("\\bof x\\b", paste0("of ", xq), nms) + nms <- gsub("\\bof y\\b", paste0("of ", yq), nms) + nms <- gsub("\\(x - y", paste0("(", xq, " - ", yq), nms) + nms <- gsub("\\(z = x - y", paste0("(z = ", xq, " - ", yq), nms) + names(y$estimate) <- nms + } else { + if (!is_paired && length(y$estimate) >= 2) { + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = FALSE) + diff_label <- paste0("mean difference (", xq, " - ", yq, ")") + names(y$estimate) <- c(est_labels, diff_label) + } else if (is_paired) { + names(y$estimate) <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = TRUE) + } + } + + # Relabel sample_size names + if (!is.null(y$sample_size) && length(y$sample_size) == 2) { + names(y$sample_size) <- levels(g) + } + y } diff --git a/R/brunner_munzel.R b/R/brunner_munzel.R index 7b40cdb..28b9dd3 100644 --- a/R/brunner_munzel.R +++ b/R/brunner_munzel.R @@ -2,7 +2,7 @@ #' @description #' `r lifecycle::badge("maturing")` #' -#' This is a generic function that performs a generalized asymptotic Brunner-Munzel test in a fashion similar to [t.test]. +#' This is a generic function that performs a generalized Brunner-Munzel test in a fashion similar to [t.test]. #' @param paired a logical indicating whether you want a paired test. #' @param mu a number or vector specifying the null hypothesis value(s): #' @@ -11,6 +11,25 @@ #' * For "equivalence" or "minimal.effect": two values representing the lower and upper bounds #' for the relative effect. Values must be between 0 and 1. #' +#' Note: `mu` is always specified on the probability scale regardless of the `scale` argument. +#' The `scale` argument only affects how results are reported; it does not change the hypothesis +#' being tested. +#' +#' @param scale a character string specifying the scale for the reported estimate, +#' standard error, confidence interval, and null value. The test itself always operates +#' on the probability scale internally; this argument only transforms the output. +#' +#' \describe{ +#' \item{"probability"}{(default): \eqn{p = P(X > Y) + 0.5 \cdot P(X = Y)}, range \eqn{[0, 1]}, +#' null at stochastic equality = 0.5} +#' \item{"difference"}{\eqn{P(X > Y) - P(X < Y) = 2p - 1}, range \eqn{[-1, 1]}, +#' null = 0} +#' \item{"logodds"}{\eqn{\log[p / (1 - p)]}, range \eqn{(-\infty, \infty)}, +#' null = 0} +#' \item{"odds"}{\eqn{p / (1 - p)}, range \eqn{(0, \infty)}, +#' null = 1} +#' } +#' #' @param test_method a character string specifying the test method to use: #' #' * "t" (default): approximate t-distribution with Satterthwaite-Welch degrees of freedom @@ -68,7 +87,11 @@ #' #' * "perm": A studentized permutation test following Neubert & Brunner (2007). This method #' is highly recommended when sample sizes are small (< 15 per group) as it provides better -#' control of Type I error rates in these situations. +#' control of Type I error rates in these situations. Note: when exact permutations are +#' enumerated with small or heavily tied samples, the exact p-value method (`b/R`) may +#' return p = 0 if no permuted test statistic is as extreme as the observed value. The +#' `plusone` method (`(b+1)/(R+1)`) avoids this artifact and can be selected via +#' `p_method = "plusone"`. #' #' ## Hypothesis Testing #' @@ -130,6 +153,17 @@ #' the studentized permutation distribution converges to the same limit regardless of the #' centering, following the asymptotic theory of Janssen (1997) and Neubert & Brunner (2007). #' +#' Because the equivalence bounds are specified directly on the relative effect +#' scale (i.e., as probabilities between 0 and 1), this avoids the difficulty +#' noted by Arboretti et al. (2021, point IU.7) that arises when margins must +#' be expressed in terms of rank transformations. +#' +#' These are uncalibrated (naive) procedures. For the IU direction +#' (`"equivalence"`), the procedure can be conservative when sample sizes are +#' small or when the equivalence bounds are close to 0.5. For the UI direction +#' (`"minimal.effect"`), the conservatism is less pronounced. See Arboretti +#' et al. (2021) for a detailed discussion of calibration +#' #' @return A list with class `"htest"` containing the following components: #' #' - "statistic": the value of the test statistic. @@ -170,7 +204,17 @@ #' mu = c(0.35, 0.65), #' test_method = "perm") #' +#' # Report on the difference scale: P(X>Y) - P(X low # Large test_stat_low supports H1, so p-value = P(T >= t_obs) - p_greater_low <- mean(Tperm >= test_stat_low) - + b_greater_low <- sum(Tperm >= test_stat_low) # For upper bound test: H0: p >= high vs H1: p < high # Small (negative) test_stat_high supports H1, so p-value = P(T <= t_obs) - p_less_high <- mean(Tperm <= test_stat_high) + b_less_high <- sum(Tperm <= test_stat_high) + + p_greater_low <- bm_compute_perm_pval(b_greater_low, n_perm_actual, p_method) + p_less_high <- bm_compute_perm_pval(b_less_high, n_perm_actual, p_method) if(alternative == "equivalence") { # Both conditions must be met: p > low AND p < high @@ -514,7 +569,9 @@ brunner_munzel.default = function(x, # Confidence interval quantiles from permutation distribution # Use actual number of permutations for indexing - pq1 <- sort(Tperm)[(floor((1-alpha)*n_perm_actual)+1)] + sorted_Tperm <- sort(Tperm) + idx_pq1 <- min(n_perm_actual, max(1, floor((1-alpha)*n_perm_actual)+1)) + pq1 <- sorted_Tperm[idx_pq1] pd.lower <- pd - pq1*sqrt(v/n) pd.upper <- pd + pq1*sqrt(v/n) @@ -524,14 +581,26 @@ brunner_munzel.default = function(x, # Observed test statistic centered at mu test_stat <- sqrt(n) * (pd - mu) / sqrt(v) - p1perm <- mean(Tperm <= test_stat) - pq1 <- sort(Tperm)[(floor((1-alpha/2)*n_perm_actual)+1)] - pq2 <- sort(Tperm)[(floor((1-alpha)*n_perm_actual)+1)] + # Count extreme values for p-value calculation + b_less <- sum(Tperm <= test_stat) + b_greater <- sum(Tperm >= test_stat) + b_two_sided <- sum(abs(Tperm) >= abs(test_stat)) + + sorted_Tperm <- sort(Tperm) + idx_pq1 <- min(n_perm_actual, max(1, floor((1-alpha/2)*n_perm_actual)+1)) + idx_pq2 <- min(n_perm_actual, max(1, floor((1-alpha)*n_perm_actual)+1)) + pq1 <- sorted_Tperm[idx_pq1] + pq2 <- sorted_Tperm[idx_pq2] + + # Compute p-values using selected method + p_less <- bm_compute_perm_pval(b_less, n_perm_actual, p_method) + p_greater <- bm_compute_perm_pval(b_greater, n_perm_actual, p_method) + p_two_sided <- bm_compute_perm_pval(b_two_sided, n_perm_actual, p_method) p.value = switch(alternative, - "two.sided" = min(2*p1perm, 2*(1-p1perm)), - "less" = p1perm, - "greater" = 1-p1perm) + "two.sided" = p_two_sided, + "less" = p_less, + "greater" = p_greater) pd.lower = switch(alternative, "two.sided" = pd - pq1*sqrt(v/n), @@ -544,17 +613,34 @@ brunner_munzel.default = function(x, "greater" = 1) } + # Warn if exact permutation p-value is 0 (potential artifact) + if (p_method == "exact" && p.value == 0) { + warning("Exact permutation p-value is 0. This may be an artifact of the discrete ", + "permutation distribution with heavily tied or degenerate data. Consider using ", + "p_method = 'plusone' for a more conservative estimate.") + } + # Clamp bounds to [0, 1] + if (pd.lower < 0 || pd.upper > 1) clamped_ci <- TRUE pd.lower <- ifelse(pd.lower < 0, 0, pd.lower) pd.upper <- ifelse(pd.upper > 1, 1, pd.upper) } else if(test_method == "logit") { # Logit transformation method for paired samples - METHOD = "Exact paired Brunner-Munzel test (logit)" + METHOD = "paired Brunner-Munzel test (logit)" + + # Clamp pd locally for logit transformation only + pd_logit_use <- pd + if (pd == 0 || pd == 1) { + warning("Logit method is unreliable when the estimated relative effect is exactly 0 or 1. ", + "Consider using test_method = 't' instead.") + message("Note: Estimated relative effect was clamped away from 0/1 for logit transformation.") + pd_logit_use <- ifelse(pd == 0, 0.0001, 0.9999) + } # Logit transformation for range-preserving CIs - pd_logit <- log(pd / (1 - pd)) - se_logit <- sqrt(v/n) / (pd * (1 - pd)) + pd_logit <- log(pd_logit_use / (1 - pd_logit_use)) + se_logit <- sqrt(v/n) / (pd_logit_use * (1 - pd_logit_use)) if(alternative %in% c("equivalence", "minimal.effect")) { # Test statistics for each bound on logit scale @@ -618,13 +704,14 @@ brunner_munzel.default = function(x, pd.upper <- exp(ci_logit_upper) / (1 + exp(ci_logit_upper)) } - # Handle edge cases + # Handle edge cases (paired logit) + if (is.nan(pd.lower) || pd.lower < 0 || is.nan(pd.upper) || pd.upper > 1) clamped_ci <- TRUE pd.lower <- ifelse(is.nan(pd.lower) | pd.lower < 0, 0, pd.lower) pd.upper <- ifelse(is.nan(pd.upper) | pd.upper > 1, 1, pd.upper) } else { # Asymptotic (t-distribution) approach - METHOD = "Exact paired Brunner-Munzel test" + METHOD = "Paired Brunner-Munzel test" if(alternative %in% c("equivalence", "minimal.effect")) { # Test statistics for each bound @@ -679,25 +766,31 @@ brunner_munzel.default = function(x, "less" = pd + qt(1-alpha, df.sw)*sqrt(v/n), "greater" = 1) } + + # Clamp CI bounds to [0, 1] for paired t-approx + if (pd.lower < 0 || pd.upper > 1) clamped_ci <- TRUE + pd.lower <- ifelse(pd.lower < 0, 0, pd.lower) + pd.upper <- ifelse(pd.upper > 1, 1, pd.upper) } } else { # Two-sample ------ + n.x <- as.double(length(x)) + n.y <- as.double(length(y)) + if (n.x < 3 || n.y < 3) { + stop("Brunner-Munzel test requires at least 3 observations per group.") + } rxy <- rank(c(x, y)) rx <- rank(x) ry <- rank(y) - n.x <- as.double(length(x)) - n.y <- as.double(length(y)) N = n.x + n.y pl2 <- 1/n.y*(rxy[1:n.x]-rx) pl1 <- 1/n.x*(rxy[(n.x+1):N]-ry) pd <- mean(pl2) - pd1 <- (pd == 1) - pd0 <- (pd == 0) - pd[pd1] <- 0.9999 - pd[pd0] <- 0.0001 + # Store raw pd for estimate output; clamping is applied only in logit path + pd_raw <- pd s1 <- var(pl2)/n.x s2 <- var(pl1)/n.y @@ -788,8 +881,9 @@ brunner_munzel.default = function(x, } # CI quantiles for 1-2*alpha level - c1 <- 0.5*(Tperm[1, floor((1-alpha)*R_actual)] + - Tperm[1, ceiling((1-alpha)*R_actual)]) + idx1 <- max(1, floor((1-alpha)*R_actual)) + idx2 <- min(R_actual, ceiling((1-alpha)*R_actual)) + c1 <- 0.5*(Tperm[1, idx1] + Tperm[1, idx2]) pd.lower <- pd - sqrt(V/N)*c1 pd.upper <- pd + sqrt(V/N)*c1 @@ -808,11 +902,19 @@ brunner_munzel.default = function(x, b_two_sided <- sum(abs(Tperm[1,]) >= abs(test_stat)) if(alternative == "two.sided"){ - c1<-0.5*(Tperm[1,floor((1-alpha/2)*R_actual)]+Tperm[1,ceiling((1-alpha/2)*R_actual)]) - c2<-0.5*(Tperm[1,floor(alpha/2*R_actual)]+Tperm[1,ceiling(alpha/2*R_actual)]) + idx_c1 <- max(1, floor((1-alpha/2)*R_actual)) + idx_c1b <- min(R_actual, ceiling((1-alpha/2)*R_actual)) + idx_c2 <- max(1, floor(alpha/2*R_actual)) + idx_c2b <- min(R_actual, ceiling(alpha/2*R_actual)) + c1<-0.5*(Tperm[1, idx_c1]+Tperm[1, idx_c1b]) + c2<-0.5*(Tperm[1, idx_c2]+Tperm[1, idx_c2b]) } else { - c1<-0.5*(Tperm[1, floor((1-alpha)*R_actual)]+Tperm[1, ceiling((1-alpha)*R_actual)]) - c2<-0.5*(Tperm[1, floor(alpha*R_actual)]+Tperm[1, ceiling(alpha*R_actual)]) + idx_c1 <- max(1, floor((1-alpha)*R_actual)) + idx_c1b <- min(R_actual, ceiling((1-alpha)*R_actual)) + idx_c2 <- max(1, floor(alpha*R_actual)) + idx_c2b <- min(R_actual, ceiling(alpha*R_actual)) + c1<-0.5*(Tperm[1, idx_c1]+Tperm[1, idx_c1b]) + c2<-0.5*(Tperm[1, idx_c2]+Tperm[1, idx_c2b]) } lower_ci = pd - sqrt(V/N)*c1 @@ -839,6 +941,14 @@ brunner_munzel.default = function(x, "greater" = 1) } + # Warn if exact permutation p-value is 0 (potential artifact) + if (p_method == "exact" && p.value == 0) { + warning("Exact permutation p-value is 0. This may be an artifact of the discrete ", + "permutation distribution with heavily tied or degenerate data. Consider using ", + "p_method = 'plusone' for a more conservative estimate.") + } + + if (pd.lower < 0 || pd.upper > 1) clamped_ci <- TRUE pd.lower = ifelse(pd.lower < 0, 0, pd.lower) pd.upper = ifelse(pd.upper > 1, 1, pd.upper) @@ -847,9 +957,18 @@ brunner_munzel.default = function(x, ## logit transformation ---- METHOD = "Two-sample Brunner-Munzel test (logit)" + # Clamp pd locally for logit transformation only + pd_logit_use <- pd + if (pd == 0 || pd == 1) { + warning("Logit method is unreliable when the estimated relative effect is exactly 0 or 1. ", + "Consider using test_method = 't' instead.") + message("Note: Estimated relative effect was clamped away from 0/1 for logit transformation.") + pd_logit_use <- ifelse(pd == 0, 0.0001, 0.9999) + } + # Logit transformation for range-preserving CIs - pd_logit <- log(pd / (1 - pd)) - se_logit <- sqrt(V/N) / (pd * (1 - pd)) + pd_logit <- log(pd_logit_use / (1 - pd_logit_use)) + se_logit <- sqrt(V/N) / (pd_logit_use * (1 - pd_logit_use)) if(alternative %in% c("equivalence", "minimal.effect")) { # Test statistics for each bound on logit scale @@ -913,7 +1032,8 @@ brunner_munzel.default = function(x, pd.upper <- exp(ci_logit_upper) / (1 + exp(ci_logit_upper)) } - # Handle edge cases + # Handle edge cases (unpaired logit) + if (is.nan(pd.lower) || pd.lower < 0 || is.nan(pd.upper) || pd.upper > 1) clamped_ci <- TRUE pd.lower <- ifelse(is.nan(pd.lower) | pd.lower < 0, 0, pd.lower) pd.upper <- ifelse(is.nan(pd.upper) | pd.upper > 1, 1, pd.upper) @@ -952,6 +1072,7 @@ brunner_munzel.default = function(x, # 1-2*alpha CI for TOST pd.lower <- pd - qt(1-alpha, df=df.sw)/sqrt(N)*sqrt(V) pd.upper <- pd + qt(1-alpha, df=df.sw)/sqrt(N)*sqrt(V) + if (pd.lower < 0 || pd.upper > 1) clamped_ci <- TRUE pd.lower = ifelse(pd.lower < 0, 0, pd.lower) pd.upper = ifelse(pd.upper > 1, 1, pd.upper) @@ -969,22 +1090,51 @@ brunner_munzel.default = function(x, "two.sided" = pd - qt(1-alpha/2, df=df.sw)/sqrt(N)*sqrt(V), "less" = 0, "greater" = pd - qt(1-alpha, df=df.sw)/sqrt(N)*sqrt(V)) + if (pd.lower < 0) clamped_ci <- TRUE pd.lower = ifelse(pd.lower < 0, 0, pd.lower) pd.upper = switch(alternative, "two.sided" = pd + qt(1-alpha/2, df=df.sw)/sqrt(N)*sqrt(V), "less" = pd + qt(1-alpha, df=df.sw)/sqrt(N)*sqrt(V), "greater" = 1) + if (pd.upper > 1) clamped_ci <- TRUE pd.upper = ifelse(pd.upper > 1, 1, pd.upper) } } } + # Emit clamping message at most once + if (clamped_ci) { + message("Note: Confidence interval bounds were clamped to the [0, 1] range.") + } + + # Rescale output to requested scale -------- + transformed <- trans_rank_prob( + estimate = pd, + se = std_err, + ci = c(pd.lower, pd.upper), + null = mu, + from = "probability", + to = scale + ) + + pd <- transformed$estimate + std_err <- transformed$se + pd.lower <- transformed$ci[1] + pd.upper <- transformed$ci[2] + mu <- transformed$null + # Prepare output if(alternative %in% c("equivalence", "minimal.effect")) { names(mu) <- c("lower bound", "upper bound") } else { - names(mu) <- "relative effect" + null_label <- switch(scale, + "probability" = "relative effect", + "difference" = "relative effect (difference)", + "logodds" = "relative effect (logodds)", + "odds" = "relative effect (odds)" + ) + names(mu) <- null_label } if(test_method == "perm"){ @@ -1001,9 +1151,9 @@ brunner_munzel.default = function(x, cint = c(pd.lower, pd.upper) attr(cint, "conf.level") = conf.level estimate = pd - # Use actual group names in estimate label - # XNAME and YNAME are set from input variable names or overwritten by formula method - names(estimate) = paste0("P(", XNAME, ">", YNAME, ") + .5*P(", XNAME, "=", YNAME, ")") + + # Build estimate label -------- + names(estimate) <- prob_notation_label(scale, XNAME, YNAME, paired) rval <- list(statistic = test_stat, parameter = param, @@ -1058,11 +1208,17 @@ brunner_munzel.formula = function(formula, DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("brunner_munzel", c(DATA, list(...))) y$data.name <- DNAME - # Update estimate label with actual factor level names - # First level becomes "x" (XNAME), second level becomes "y" (YNAME) + + # Reconstruct label with actual factor level names XNAME <- levels(g)[1] YNAME <- levels(g)[2] - names(y$estimate) <- paste0("P(", XNAME, ">", YNAME, ") + .5*P(", XNAME, "=", YNAME, ")") + dots <- list(...) + scale <- if (!is.null(dots$scale)) match.arg(dots$scale, + c("probability", "difference", "logodds", "odds")) else "probability" + + names(y$estimate) <- prob_notation_label(scale, XNAME, YNAME, + paired = isTRUE(dots$paired)) + y } diff --git a/R/cohend_calcs.R b/R/cohend_calcs.R index 56b0258..9a96f78 100644 --- a/R/cohend_calcs.R +++ b/R/cohend_calcs.R @@ -13,7 +13,12 @@ d_est_pair <- function(n, type = "g", denom = "z", alpha = .05, - smd_ci = "goulet"){ + smd_ci = "goulet", + tr = 0){ + + # Trimming adjustments + cg <- trim_rescale(tr) + h <- trim_h(n, tr) sdif <- sqrt(sd1 ^ 2 + sd2 ^ 2 - 2 * r12 * sd1 * sd2) if(denom == "z"){ @@ -26,13 +31,21 @@ d_est_pair <- function(n, d_denom = sd2 } - df <- n-1 + if (tr > 0) { + df <- h - 1 + } else { + df <- n - 1 + } hn <- 1 / n - cohend = abs(m1-m2) / d_denom + cohend = cg * abs(m1-m2) / d_denom if(smd_ci == "goulet"){ d_df = 2*(n)-2 } else { - d_df = n-1 + if (tr > 0) { + d_df = h - 1 + } else { + d_df = n - 1 + } } #J <- gamma(df / 2) / (sqrt(df / 2) * gamma((df - 1) / 2)) @@ -45,59 +58,57 @@ d_est_pair <- function(n, if(denom == "z"){ if (type == 'g') { - #cohend <- cohend * J smd_label = "Hedges's g(z)" } else { smd_label = "Cohen's d(z)" } } else if(denom == "rm"){ if (type == 'g') { - #cohend <- cohend * J smd_label = "Hedges's g(rm)" } else { smd_label = "Cohen's d(rm)" } } else if(denom %in% c("glass1","glass2")){ if (type == 'g') { - #cohend <- cohend * J smd_label = "Glass's delta(g)" } else { smd_label = "Glass's delta(d)" } } - d_lambda <- cohend * sqrt(n / (2*(1 - r12))) + if (tr > 0) { + # For trimmed paired, use h-based SE and noncentrality + if (denom == "z") { + # Yuen-adjusted SE for differences + SE_yuen <- d_denom / sqrt(h) * sqrt((n - 1) / (h - 1)) + d_lambda <- abs(m1 - m2) / SE_yuen + d_unscaled <- cohend / (cg * J) + d_sigma <- cg * sqrt(1 / h * ((n - 1) / (h - 1))) * + sqrt(d_unscaled^2 / (2 * (h - 1)) + 1) + d_sigma <- d_sigma * J + } else if (denom %in% c("glass1", "glass2")) { + SE_yuen <- d_denom / sqrt(h) * sqrt((n - 1) / (h - 1)) + d_lambda <- abs(m1 - m2) / SE_yuen + d_unscaled <- cohend / (cg * J) + d_s1 <- sdif^2 / (d_denom^2 * (h - 1)) + d_unscaled^2 / (2 * (h - 1)) + d_sigma <- cg * J * sqrt(d_s1) + } + } else { + d_lambda <- cohend * sqrt(n / (2*(1 - r12))) - # Equation 4b Goulet-Pelletier and Cousineau, 2018 - # ((2*(1-r12))/n) - d_sigma = sqrt((d_df/(d_df-2)) * ((2*(1-r12))/n)*(1+cohend^2*(n/(2*(1-r12)))) - cohend^2/J^2) - if(denom == "z"){ - d_sigma = d_sigma * sqrt(2*(1-r12)) - } - if(smd_ci == "nct" && denom != "rm"){ - #d_sigma = d_denom / sqrt(n) - # d_sigma = sqrt(1/n + (cohend^2/(2*n))) - # from metafor - # vi[i] <- 1/ni[i] + (1 - (mi[i]-2)/(mi[i]*cmi[i]^2)) * yi[i]^2 # Viechtbauer, 2007d, equation 26; see [c] - d_sigma2 = 1/n + (1 - (d_df-2)/(d_df*J^2)) * cohend^2 - d_sigma = sqrt(d_sigma2) - } - if(denom %in% c("glass1","glass2")){ - #sep1 = (n-1)/(n*(n-3)) - #sep2 = (2*(1-r12)+cohend^2*n) - #sep3 = cohend^2/(J)^2 - # Borenstein 2009 --- adopted from metafor - # # abadoned 22 April 2024 in favor of heteroscedastic option from Bonett (below) - #d_s1 = J^2*(2*(((1-r12)/n)+((cohend^2*J^(-1))/(2*n)))) - #sqrt(sep1*sep2-sep3) - #d_sigma = sqrt(d_s1) - ## From metafor - # vi[i] <- sddiffi[i]^2/(sd1i[i]^2*(ni[i]-1)) + yi[i]^2 / (2*(ni[i]-1)) - ## Bonett, 2008a, equation 13 - # note: Bonett (2008a) plugs the uncorrected yi into the equation for vi; - # here, the corrected value is plugged in for consistency with [a] - d_s1 = sdif^2/(d_denom^2*(df)) + cohend^2 / (2*(df)) - d_sigma = sqrt(d_s1) + # Equation 4b Goulet-Pelletier and Cousineau, 2018 + d_sigma = sqrt((d_df/(d_df-2)) * ((2*(1-r12))/n)*(1+cohend^2*(n/(2*(1-r12)))) - cohend^2/J^2) + if(denom == "z"){ + d_sigma = d_sigma * sqrt(2*(1-r12)) + } + if(smd_ci == "nct" && denom != "rm"){ + d_sigma2 = 1/n + (1 - (d_df-2)/(d_df*J^2)) * cohend^2 + d_sigma = sqrt(d_sigma2) + } + if(denom %in% c("glass1","glass2")){ + d_s1 = sdif^2/(d_denom^2*(df)) + cohend^2 / (2*(df)) + d_sigma = sqrt(d_s1) + } } if(smd_ci == "goulet"){ @@ -119,16 +130,29 @@ d_est_pair <- function(n, } if(smd_ci == "nct"){ - if(denom == "rm"){ - t_stat <- (abs(m1 - m2) / (sqrt((sd1^2 + sd2^2)-(2*r12*sd1*sd2))/sqrt(n))) * sqrt(2*(1-r12)) - }else{ - SE1 <- d_denom / sqrt(n) - t_stat = abs(m1 - m2) / SE1 - } + if (tr > 0) { + if (denom == "z") { + SE1 <- d_denom / sqrt(h) * sqrt((n - 1) / (h - 1)) + } else { + SE1 <- d_denom / sqrt(h) * sqrt((n - 1) / (h - 1)) + } + t_stat <- abs(m1 - m2) / SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + conv_factor <- cg * (1 / sqrt(h)) * sqrt((n - 1) / (h - 1)) + dlow <- ts[1] * conv_factor * J + dhigh <- ts[2] * conv_factor * J + } else { + if(denom == "rm"){ + t_stat <- (abs(m1 - m2) / (sqrt((sd1^2 + sd2^2)-(2*r12*sd1*sd2))/sqrt(n))) * sqrt(2*(1-r12)) + }else{ + SE1 <- d_denom / sqrt(n) + t_stat = abs(m1 - m2) / SE1 + } - ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) - dlow <- ts[1] * sqrt(hn) * J - dhigh <- ts[2] * sqrt(hn) * J + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + dlow <- ts[1] * sqrt(hn) * J + dhigh <- ts[2] * sqrt(hn) * J + } } else{ t_stat = NULL hn = NULL @@ -149,7 +173,11 @@ d_est_pair <- function(n, tdlow <- dlow dlow <- dhigh * -1 dhigh <- tdlow * -1 - d_lambda <- cohend * sqrt(n / (2*(1 - r12))) + if (tr > 0) { + d_lambda <- -d_lambda + } else { + d_lambda <- cohend * sqrt(n / (2*(1 - r12))) + } t_stat = -1*t_stat } if(smd_ci != "goulet"){ @@ -184,24 +212,47 @@ d_est_ind <- function(n1, var.equal = TRUE, alpha = .05, denom = "d", - smd_ci = "goulet"){ + smd_ci = "goulet", + tr = 0){ + # Trimming adjustments + cg <- trim_rescale(tr) + h1 <- trim_h(n1, tr) + h2 <- trim_h(n2, tr) + N <- n1 + n2 - if (var.equal) { + if (denom == "pooled" || (var.equal && denom %in% c("auto", "d")) ) { denomSD <- sqrt((((n1 - 1)*(sd1^2)) + (n2 - 1)*(sd2^2))/((n1+n2)-2)) #calculate sd pooled - d_df = n1 + n2 - 2 - hn <- (1 / n1 + 1 / n2) + if (tr > 0) { + d_df <- h1 + h2 - 2 + hn <- (1 / h1 + 1 / h2) * ((N - 2) / (h1 + h2 - 2)) + } else { + d_df = n1 + n2 - 2 + hn <- (1 / n1 + 1 / n2) + } } else { denomSD <- sqrt((sd1^2 + sd2^2)/2) #calculate sd root mean squared for Welch's t-test - d_df1 = (n1 - 1)*(n2 - 1)*(sd1^2+sd2^2)^2 - d_df2 = (n2-1)*sd1^4+(n1-1)*sd2^4 - d_df = d_df1/d_df2 - hn <- (2 * (n2 * sd1^2 + n1 * sd2^2)) / (n1 * n2 * (sd1^2 + sd2^2)) + if (tr > 0) { + # Welch-Satterthwaite with Winsorized variances and h + d_df1 = (sd1^2/h1 + sd2^2/h2)^2 + d_df2 = (sd1^2/h1)^2/(h1-1) + (sd2^2/h2)^2/(h2-1) + d_df = d_df1/d_df2 + hn <- (2 * (h2 * sd1^2 + h1 * sd2^2)) / (h1 * h2 * (sd1^2 + sd2^2)) + } else { + d_df1 = (n1 - 1)*(n2 - 1)*(sd1^2+sd2^2)^2 + d_df2 = (n2-1)*sd1^4+(n1-1)*sd2^4 + d_df = d_df1/d_df2 + hn <- (2 * (n2 * sd1^2 + n1 * sd2^2)) / (n1 * n2 * (sd1^2 + sd2^2)) + } } if (denom == "glass1"){ denomSD <- sd1 - d_df = n1 -1 + if (tr > 0) { + d_df = h1 - 1 + } else { + d_df = n1 - 1 + } hn <- 1 / n2 + denomSD^2 / (n1 * denomSD^2) n_glass = n1 nn_glass = n2 @@ -209,7 +260,11 @@ d_est_ind <- function(n1, } else if (denom == "glass2"){ denomSD <- sd2 hn <- 1 / n2 + denomSD^2 / (n1 * denomSD^2) - d_df = n2 - 1 + if (tr > 0) { + d_df = h2 - 1 + } else { + d_df = n2 - 1 + } n_glass = n2 nn_glass = n1 sdn_glass = sd1 @@ -218,16 +273,12 @@ d_est_ind <- function(n1, denomSD[is.na(denomSD)] <- NaN - #denomSD <- jmvcore::tryNaN(sqrt(((n1-1)*v[1]+(n2-1)*v[2])/(n1+n2-2))) - d <- abs(m1-m2)/denomSD # Cohen's d - - #d[is.na(d)] <- NaN + d <- cg * abs(m1-m2)/denomSD # Cohen's d (or robust version) cohend = d ntilde <- harm_mean(n1,n2) # Compute unbiased Hedges's g - # Use the lgamma function, and update to what Goulet-Pelletier & Cousineau used; works with larger inputs if(type == "g"){ J = hedge_J(d_df) } else { @@ -259,19 +310,46 @@ d_est_ind <- function(n1, } - - if(var.equal == TRUE && !(denom %in% c("glass1","glass2"))){ - mult_lamb = sqrt((n1*n2*(sd1^2 + sd2^2))/(2*(n2*sd1^2 + n1*sd2^2))) - d_lambda = cohend * mult_lamb - } else if(denom %in% c("glass1","glass2")){ - d_lambda <- cohend * sqrt(ntilde/2) + if (tr > 0) { + # Trimmed SE and noncentrality + d_unscaled <- cohend / (cg * J) + if (var.equal && !(denom %in% c("glass1", "glass2"))) { + # Pooled Winsorized: Yuen-Dixon adjusted variance + S_tilde2 <- (N - 2) * denomSD^2 / (h1 + h2 - 2) + S_tilde <- sqrt(S_tilde2) + SE1 <- S_tilde * sqrt(1/h1 + 1/h2) + d_lambda <- abs(m1 - m2) / SE1 + conv <- cg * sqrt((h1 + h2) * (N - 2) / (h1 * h2 * (h1 + h2 - 2))) + d_sigma <- conv * sqrt(d_unscaled^2 / (2 * (h1 + h2 - 2)) + (h1 + h2) / (h1 * h2)) + d_sigma <- d_sigma * J + } else if (denom %in% c("glass1", "glass2")) { + h_glass <- if (denom == "glass1") h1 else h2 + SE1 <- denomSD / sqrt(h_glass) * sqrt((n_glass - 1) / (h_glass - 1)) + d_lambda <- abs(m1 - m2) / SE1 + d_sigma <- cg * J * sqrt((sdn_glass^2/denomSD^2)/(nn_glass-1) + 1/(h_glass-1) + d_unscaled^2/(2*(h_glass-1))) + } else { + # avg (Welch) with trimming + se1 <- sqrt(sd1^2 / h1) + se2 <- sqrt(sd2^2 / h2) + SE1 <- sqrt(se1^2 + se2^2) + d_lambda <- abs(m1 - m2) / SE1 + d_sigma2 <- cg^2 * (d_unscaled^2 * (sd1^4 / (h1-1) + sd2^4 / (h2-1)) / (8*denomSD^4) + + (sd1^2 / (h1-1) + sd2^2 / (h2-1)) / denomSD^2) + d_sigma <- sqrt(d_sigma2) * J + } } else { - d_lambda <- cohend * sqrt(ntilde/2) + if(var.equal == TRUE && !(denom %in% c("glass1","glass2"))){ + mult_lamb = sqrt((n1*n2*(sd1^2 + sd2^2))/(2*(n2*sd1^2 + n1*sd2^2))) + d_lambda = cohend * mult_lamb + } else if(denom %in% c("glass1","glass2")){ + d_lambda <- cohend * sqrt(ntilde/2) + } else { + d_lambda <- cohend * sqrt(ntilde/2) + } } # add options for cohend here if(smd_ci == "goulet"){ - #d_sigma = sqrt((n1+n2)/(n1*n2)+(cohend^2/(2*(n1+n2)))) d_sigma = sqrt((d_df/(d_df-2)) * (2/ntilde) *(1+cohend^2*(ntilde/2)) - cohend^2/J^2) # Confidence interval of the SMD from Goulet-Pelletier & Cousineau tlow <- qt(1 / 2 - (1-alpha*2) / 2, df = d_df, ncp = d_lambda) @@ -283,61 +361,64 @@ d_est_ind <- function(n1, dlow <- tlow / d_lambda * cohend dhigh <- thigh / d_lambda * cohend } - } else{ + } else if (tr == 0) { if (denom %in% c("glass1", "glass2")) { N = n1 + n2 - # morris and deshon 2002 - # d_sigma = sqrt((1 / ntilde) * ((N - 2) / (N - 4)) * (1 + ntilde * - # cohend ^ 2) - cohend ^ 2 / J ^ 2) - # Algina, Keselman, and Penfield (2006) from Delacre et al 2021 - #d_sigma2 = d_df / (d_df -2) * (1/n_glass + sdn_glass^2/(nn_glass*denomSD^2))+ cohend^2 * (d_df/(d_df-2)-J^2) - # # Bonett, 2008a, equation 12 - ### adapted from metafor SMD1H - ### vi <- (sd1i^2/sd2i^2)/(n1i-1) + 1/(n2i-1) + yi^2/(2*(n2i-1)) d_sigma2 = (sdn_glass^2/denomSD^2)/(nn_glass-1) + 1/(n_glass-1) + cohend^2/(2*(n_glass-1)) d_sigma = sqrt(d_sigma2) } else { if (var.equal) { - #d_sigma = sqrt(((n1 + n2) / (n1 * n2) + d ^ 2 / (2 * (n1 + n2))) * J ^ 2) - #vi[i] <- 1/n1i[i] + 1/n2i[i] + (1 - (mi[i]-2)/(mi[i]*cmi[i]^2)) * yi[i]^2 # Hedges, 1983b, equation 9; see [c] d_sigma2 = 1/n1 + 1/n2 + (1 - (d_df-2)/(d_df*J^2)) * cohend^2 d_sigma = sqrt(d_sigma2) } else{ - # par1 = 2*(sd1^2/n1+sd2^2/n2)/(sd1^2+sd2^2) - # par2 = d_df/(d_df-2)-J^2 - # d_sigma = sqrt(d_df/(d_df-2)*par1+cohend^2*par2) - # Adopted from metfor - # vi[i] <- yi[i]^2 * (sd1i[i]^4 / (n1i[i]-1) + sd2i[i]^4 / (n2i[i]-1)) / (8*sdpi[i]^4) + - #(sd1i[i]^2 / (n1i[i]-1) + sd2i[i]^2 / (n2i[i]-1)) / sdpi[i]^2 # Bonett, 2008a, equation 8; Bonett, 2009, equation 5 d_sigma2 = cohend^2 * (sd1^4 / (n1-1) + sd2^4 / (n2-1)) / (8*denomSD^4) + - (sd1^2 / (n1-1) + sd2^2 / (n2-1)) / denomSD^2 # Bonett, 2008a, equation 8; Bonett, 2009, equation 5 + (sd1^2 / (n1-1) + sd2^2 / (n2-1)) / denomSD^2 d_sigma = sqrt(d_sigma2) } } - } if(smd_ci == "nct"){ - if( !(denom %in% c("glass1","glass2"))){ - #d_sigma = denomSD * sqrt(1 / n1 + 1 / n2) - if(var.equal){ - SE1 = denomSD * sqrt(1 / n1 + 1 / n2) + if (tr > 0) { + # SE1 and d_lambda already computed in trimming block above + t_stat <- abs(m1 - m2) / SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + if (var.equal && !(denom %in% c("glass1", "glass2"))) { + conv <- cg * sqrt((h1 + h2) * (N - 2) / (h1 * h2 * (h1 + h2 - 2))) + dlow <- ts[1] * conv * J + dhigh <- ts[2] * conv * J + } else if (denom %in% c("glass1", "glass2")) { + h_glass <- if (denom == "glass1") h1 else h2 + conv <- cg * (1 / sqrt(h_glass)) * sqrt((n_glass - 1) / (h_glass - 1)) + dlow <- ts[1] * conv * J + dhigh <- ts[2] * conv * J } else { - se1 <- sqrt(sd1^2 / n1) - se2 <- sqrt(sd2^2 / n2) - SE1 <- sqrt(se1^2 + se2^2) + # Welch avg + conv <- cg * SE1 / denomSD + dlow <- ts[1] * conv * J + dhigh <- ts[2] * conv * J } - - t_stat = abs(m1-m2)/SE1 - ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) } else { - SE1 = (denomSD * sqrt(1 / n_glass + sdn_glass^2 / (nn_glass * denomSD^2))) - d_df <- n1+n2 - 2 - t_stat = abs(m1-m2)/SE1 - ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + if( !(denom %in% c("glass1","glass2"))){ + if(var.equal){ + SE1 = denomSD * sqrt(1 / n1 + 1 / n2) + } else { + se1 <- sqrt(sd1^2 / n1) + se2 <- sqrt(sd2^2 / n2) + SE1 <- sqrt(se1^2 + se2^2) + } + + t_stat = abs(m1-m2)/SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + } else { + SE1 = (denomSD * sqrt(1 / n_glass + sdn_glass^2 / (nn_glass * denomSD^2))) + d_df <- n1+n2 - 2 + t_stat = abs(m1-m2)/SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + } + dlow <- ts[1] * sqrt(hn) * J + dhigh <- ts[2] * sqrt(hn) * J } - dlow <- ts[1] * sqrt(hn) * J - dhigh <- ts[2] * sqrt(hn) * J } else { t_stat = NULL hn = NULL @@ -359,13 +440,17 @@ d_est_ind <- function(n1, dlow <- dhigh * -1 dhigh <- tdlow * -1 t_stat = -1*t_stat - if(var.equal == TRUE && !(denom %in% c("glass1","glass2"))){ - mult_lamb = sqrt((n1*n2*(sd1^2 + sd2^2))/(2*(n2*sd1^2 + n1*sd2^2))) - d_lambda = cohend * mult_lamb - } else if(denom %in% c("glass1","glass2")){ - d_lambda <- cohend * sqrt(ntilde/2) + if (tr == 0) { + if(var.equal == TRUE && !(denom %in% c("glass1","glass2"))){ + mult_lamb = sqrt((n1*n2*(sd1^2 + sd2^2))/(2*(n2*sd1^2 + n1*sd2^2))) + d_lambda = cohend * mult_lamb + } else if(denom %in% c("glass1","glass2")){ + d_lambda <- cohend * sqrt(ntilde/2) + } else { + d_lambda <- cohend * sqrt(ntilde/2) + } } else { - d_lambda <- cohend * sqrt(ntilde/2) + d_lambda <- -d_lambda } } @@ -450,10 +535,19 @@ d_est_one <- function(n, testValue, type = "g", alpha = .05, - smd_ci = "goulet"){ + smd_ci = "goulet", + tr = 0){ + + # Trimming adjustments + cg <- trim_rescale(tr) + h <- trim_h(n, tr) - cohend <- abs(mu-testValue)/sd # Cohen's d - df <- n-1 + cohend <- cg * abs(mu-testValue)/sd # Cohen's d (or robust version) + if (tr > 0) { + df <- h - 1 + } else { + df <- n - 1 + } d_df = df hn <- 1 / n # Compute unbiased Hedges' g @@ -471,12 +565,25 @@ d_est_one <- function(n, smd_label = "Cohen's d" } - d_lambda <- cohend * sqrt(n) - if(smd_ci == "goulet"){ - d_sigma = sqrt((df/(df-2)) * (1/n) *(1+cohend^2*(n/1)) - cohend^2/J^2) + if (tr > 0) { + # Noncentrality: lambda = (trimmed mean diff / Winsorized SE) + # SE_trimmed = sd / sqrt(h) * sqrt((n-1)/(h-1)) for Yuen adjustment + SE_yuen <- sd / sqrt(h) * sqrt((n - 1) / (h - 1)) + d_lambda <- abs(mu - testValue) / SE_yuen + # SE of d_R: uses the noncentral-t approximation with trimming + d_unscaled <- cohend / (cg * J) # remove cg and J to get raw ratio + d_sigma <- cg * sqrt(1 / h * ((n - 1) / (h - 1))) * + sqrt(d_unscaled^2 / (2 * (h - 1)) + 1) + d_sigma <- d_sigma * J } else { - d_sigma = sqrt(1/n + (cohend^2/(2*n))) + d_lambda <- cohend * sqrt(n) + if(smd_ci == "goulet"){ + d_sigma = sqrt((df/(df-2)) * (1/n) *(1+cohend^2*(n/1)) - cohend^2/J^2) + } else { + d_sigma = sqrt(1/n + (cohend^2/(2*n))) + } } + if(smd_ci == "goulet"){ #d_sigma = sqrt((df + 1)/(df - 1)*(2/n)*(1 + cohend^2/8)) @@ -497,12 +604,21 @@ d_est_one <- function(n, } if(smd_ci == "nct"){ - SE1 <- sd / sqrt(n) - t_stat = abs(mu-testValue) / SE1 - ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) - dlow <- ts[1] * sqrt(hn)*J - dhigh <- ts[2] * sqrt(hn)*J - + if (tr > 0) { + SE1 <- sd / sqrt(h) * sqrt((n - 1) / (h - 1)) + t_stat <- abs(mu - testValue) / SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + # Convert noncentrality to delta_R + conv_factor <- cg * (1 / sqrt(h)) * sqrt((n - 1) / (h - 1)) + dlow <- ts[1] * conv_factor * J + dhigh <- ts[2] * conv_factor * J + } else { + SE1 <- sd / sqrt(n) + t_stat = abs(mu-testValue) / SE1 + ts <- get_ncp_t2(t_stat, d_df, conf.level = 1-alpha*2) + dlow <- ts[1] * sqrt(hn)*J + dhigh <- ts[2] * sqrt(hn)*J + } } else { t_stat = NULL hn = NULL @@ -770,4 +886,141 @@ get_ncp_t2 = function (ncp, df, conf.level = 0.95, return(Result) } +# Internal helper: Winsorized variance +# Replaces the g smallest and g largest observations with the nearest remaining +# values, then computes the variance of the Winsorized sample. +winvar <- function(x, tr = 0.2) { + n <- length(x) + g <- floor(tr * n) + if (g == 0) return(var(x)) + y <- sort(x) + y[seq_len(g)] <- y[g + 1L] + y[seq.int(n - g + 1L, n)] <- y[n - g] + var(y) +} + +# Internal helper: Rescaling constant for trimmed SMD +# Returns c(gamma) such that c(gamma) * (trimmed mean diff / Winsorized SD) +# equals Cohen's delta under normality. +trim_rescale <- function(tr) { + if (tr == 0) return(1) + a <- qnorm(1 - tr) + sqrt(1 - 2 * tr + 2 * tr * a^2 - 2 * a * dnorm(a)) +} + +# Internal helper: Effective sample size after trimming +# h = n - 2 * floor(tr * n) +trim_h <- function(n, tr) { + n - 2L * floor(tr * n) +} + +# Internal helper to resolve denom into concrete arguments +# Returns a list with resolved values of: glass, rm_correction, var.equal +# and a character vector of messages to emit (if any) +resolve_denom <- function(denom, + sample_type, + var.equal, + rm_correction, + glass, + var.equal_explicit = FALSE, + rm_correction_explicit = FALSE, + glass_explicit = FALSE) { + + msgs <- character(0) + + if (denom == "auto") { + # Return current values unchanged, no messages + return(list( + var.equal = var.equal, + rm_correction = rm_correction, + glass = glass, + messages = msgs + )) + } + + # --- Design-validity checks --- + paired_only <- c("rm") + paired_or_one <- c("z") + ind_only <- c("pooled", "avg") + needs_two_samples <- c("glass1", "glass2", "rm") + + if (denom %in% ind_only && sample_type != "Two Sample") { + stop(paste0("denom = '", denom, "' is only valid for independent samples designs.")) + } + if (denom %in% paired_only && sample_type != "Paired Sample") { + stop(paste0("denom = '", denom, "' is only valid for paired samples designs.")) + } + if (denom %in% paired_or_one && sample_type == "Two Sample") { + stop(paste0("denom = '", denom, "' is not valid for independent samples designs.")) + } + if (denom %in% needs_two_samples && sample_type == "One Sample") { + stop(paste0("denom = '", denom, "' is not valid for one-sample designs.")) + } + + # --- Remapping with conflict detection --- + new_glass <- glass + new_rm <- rm_correction + new_var.equal <- var.equal + + if (denom == "z") { + if (rm_correction_explicit && isTRUE(rm_correction)) { + msgs <- c(msgs, "denom = 'z' overrides rm_correction to FALSE.") + } + if (glass_explicit && !is.null(glass)) { + msgs <- c(msgs, "denom = 'z' overrides glass argument.") + } + new_rm <- FALSE + new_glass <- NULL + + } else if (denom == "rm") { + if (rm_correction_explicit && !isTRUE(rm_correction)) { + msgs <- c(msgs, "denom = 'rm' overrides rm_correction to TRUE.") + } + if (glass_explicit && !is.null(glass)) { + msgs <- c(msgs, "denom = 'rm' overrides glass argument.") + } + new_rm <- TRUE + new_glass <- NULL + + } else if (denom == "pooled") { + if (var.equal_explicit && !isTRUE(var.equal)) { + msgs <- c(msgs, "denom = 'pooled' overrides var.equal to TRUE.") + } + if (glass_explicit && !is.null(glass)) { + msgs <- c(msgs, "denom = 'pooled' overrides glass argument.") + } + new_var.equal <- TRUE + new_glass <- NULL + new_rm <- FALSE + + } else if (denom == "avg") { + if (var.equal_explicit && isTRUE(var.equal)) { + msgs <- c(msgs, "denom = 'avg' overrides var.equal to FALSE.") + } + if (glass_explicit && !is.null(glass)) { + msgs <- c(msgs, "denom = 'avg' overrides glass argument.") + } + new_var.equal <- FALSE + new_glass <- NULL + new_rm <- FALSE + + } else if (denom %in% c("glass1", "glass2")) { + if (glass_explicit && !is.null(glass) && glass != denom) { + msgs <- c(msgs, paste0("denom = '", denom, "' overrides glass argument.")) + } + if (rm_correction_explicit && isTRUE(rm_correction)) { + msgs <- c(msgs, paste0("denom = '", denom, "' overrides rm_correction to FALSE.")) + } + new_glass <- denom + new_rm <- FALSE + } + + return(list( + var.equal = new_var.equal, + rm_correction = new_rm, + glass = new_glass, + messages = msgs + )) +} + utils::globalVariables(c("sd1")) diff --git a/R/cor_test.R b/R/cor_test.R index 3ee9d3e..854f8bb 100644 --- a/R/cor_test.R +++ b/R/cor_test.R @@ -23,10 +23,15 @@ #' #' You can specify just the initial letter. #' @param alpha alpha level (default = 0.05) +#' @param se_method a character string indicating the method for computing the standard error. +#' One of "analytic" (default) or "jackknife". The jackknife SE is computed on the Fisher z scale +#' using leave-one-out resampling. #' #' @details -#' This function uses Fisher's z transformation for the correlations, but uses Fieller's -#' correction of the standard error for Spearman's \eqn{\rho} and Kendall's \eqn{\tau}. +#' This function uses Fisher's z transformation for the correlations. +#' For Spearman's \eqn{\rho}, the Bonett-Wright \eqn{\rho}-dependent SE formula +#' \eqn{\sqrt{(1 + r^2/2) / (n - 3)}} is used rather than the fixed 1.06 constant. +#' For Kendall's \eqn{\tau}, Fieller's correction is applied. #' #' The function supports both standard hypothesis testing and equivalence/minimal effect testing: #' @@ -43,6 +48,11 @@ #' * If a single value is provided for `null`, symmetric bounds ± value will be used #' * If two values are provided for `null`, they will be used as the lower and upper bounds #' +#' When `se_method = "jackknife"`, the standard error is computed via leave-one-out +#' resampling on the Fisher z scale, which can provide better calibration for small +#' samples or non-standard correlation methods. The jackknife SE is used for both +#' the test statistic and the confidence interval. +#' #' See `vignette("correlations")` for more details. #' #' @return A list with class "htest" containing the following components: @@ -51,8 +61,10 @@ #' * **statistic**: the value of the test statistic with a name describing it. #' * **parameter**: the degrees of freedom or number of observations. #' * **conf.int**: a confidence interval for the measure of association appropriate to the specified alternative hypothesis. -#' * **estimate**: the estimated measure of association, with name "cor", "tau", or "rho" corresponding to the method employed. -#' * **stderr**: the standard error of the test statistic. +#' * **estimate**: the estimated measure of association, with name "r", "tau", or "rho" corresponding to the method employed. +#' * **stderr**: a named vector with `z.se` (standard error on the Fisher z scale, used for inference) +#' and `cor.se` (delta method SE on the correlation scale, for descriptive purposes). +#' Note that `cor.se` underestimates true sampling variability as |r| approaches 1. #' * **null.value**: the value of the association measure under the null hypothesis. #' * **alternative**: character string indicating the alternative hypothesis. #' * **method**: a character string indicating how the association was measured. @@ -83,6 +95,9 @@ #' testing approach. British Journal of Mathematical and Statistical Psychology, 63(3), 527-537. #' https://doi.org/10.1348/000711009X475853, formula page 531. #' +#' Bonett, D. G., & Wright, T. A. (2000). Sample size requirements for estimating +#' Pearson, Kendall and Spearman correlations. Psychometrika, 65(1), 23-28. +#' #' @name z_cor_test #' @family Correlations #' @export z_cor_test @@ -93,9 +108,11 @@ z_cor_test = function(x, "equivalence", "minimal.effect"), method = c("pearson", "kendall", "spearman"), alpha = 0.05, - null = 0){ + null = 0, + se_method = c("analytic", "jackknife")){ alternative = match.arg(alternative) method = match.arg(method) + se_method = match.arg(se_method) #if(TOST && null <=0){ # stop("positive value for null must be supplied if using TOST.") @@ -142,38 +159,57 @@ z_cor_test = function(x, DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) NVAL = null znull = rho_to_z(null) + # capture raw method string before overwrite -------- + method_raw <- method # get se --- if (method == "pearson") { # Pearson # Fisher method <- "Pearson's product-moment correlation" names(NVAL) = rep("correlation",length(NVAL)) - rfinal = c(cor = r_xy) + rfinal = c(r = r_xy) z.se <- 1 / sqrt(n_obs - 3) - cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, - method = "pearson") + cor_correction <- "fieller" } if (method == "spearman") { method <- "Spearman's rank correlation rho" - # # Fieller adjusted + # Bonett-Wright rfinal = c(rho = r_xy) names(NVAL) = rep("rho",length(NVAL)) - z.se <- (1.06 / (n_obs - 3)) ^ 0.5 - cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, - method = "spearman", - correction = "fieller") + z.se <- sqrt((1 + r_xy^2 / 2) / (n_obs - 3)) + cor_correction <- "bw" } if (method == "kendall") { method <- "Kendall's rank correlation tau" - # # Fieller adjusted + # Fieller adjusted rfinal = c(tau = r_xy) names(NVAL) = rep("tau",length(NVAL)) z.se <- (0.437 / (n_obs - 4)) ^ 0.5 + cor_correction <- "fieller" + } - cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, - method = "kendall", - correction = "fieller") + # jackknife SE -------- + if (se_method == "jackknife") { + jk_cors <- vapply(seq_len(n_obs), function(i) { + rho_to_z(cor(x[-i], y[-i], method = method_raw)) + }, numeric(1)) + z.se <- sqrt(((n_obs - 1) / n_obs) * sum((jk_cors - mean(jk_cors))^2)) } + # append SE label to method name -------- + se_label <- if (se_method == "jackknife") "with jackknifed SE" else "with approximate SE" + method <- paste(method, se_label) + + # pass se to cor_to_ci only when jackknife -------- + se_override <- if (se_method == "jackknife") z.se else NULL + + cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, + method = method_raw, + correction = cor_correction, + se = se_override) + + # delta method SE on correlation scale -------- + cor.se <- (1 - r_xy^2) * z.se + # get absolute value if TOST #z_test = ifelse(TOST, abs(z_xy), z_xy) @@ -222,7 +258,7 @@ z_cor_test = function(x, parameter = N, conf.int = cint, estimate = rfinal, - stderr = c(z.se = z.se), + stderr = c(z.se = z.se, cor.se = cor.se), null.value = NVAL, alternative = alternative, method = method, diff --git a/R/corr_calcs.R b/R/corr_calcs.R index 62572f8..e2f34cb 100644 --- a/R/corr_calcs.R +++ b/R/corr_calcs.R @@ -1,6 +1,7 @@ cor_to_ci <- function(cor, n, ci = 0.95, method = "pearson", - correction = "fieller", ...) { + correction = "fieller", + se = NULL, ...) { method <- match.arg(tolower(method), c("pearson", "kendall", "spearman"), several.ok = FALSE) @@ -8,13 +9,15 @@ cor_to_ci <- function(cor, n, ci = 0.95, if (method == "kendall") { out <- .cor_to_ci_kendall(cor, n, ci = ci, - correction = correction, ...) + correction = correction, + se = se, ...) } else if (method == "spearman") { out <- .cor_to_ci_spearman(cor, n, ci = ci, - correction = correction, ...) + correction = correction, + se = se, ...) } else { - out <- .cor_to_ci_pearson(cor, n, ci = ci, ...) + out <- .cor_to_ci_pearson(cor, n, ci = ci, se = se, ...) } out @@ -24,10 +27,13 @@ cor_to_ci <- function(cor, n, ci = 0.95, #' @importFrom stats qnorm .cor_to_ci_kendall <- function(cor, n, ci = 0.95, - correction = "fieller", ...) { + correction = "fieller", + se = NULL, ...) { # by @tsbaguley (https://rpubs.com/seriousstats/616206) - if (correction == "fieller") { + if (!is.null(se)) { + tau.se <- se + } else if (correction == "fieller") { tau.se <- (0.437 / (n - 4))^0.5 } else { tau.se <- 1 / (n - 3)^0.5 @@ -48,10 +54,13 @@ cor_to_ci <- function(cor, n, ci = 0.95, # Spearman ----------------------------------------------------------------- .cor_to_ci_spearman <- function(cor, n, ci = 0.95, - correction = "fieller", ...) { + correction = "fieller", + se = NULL, ...) { # by @tsbaguley (https://rpubs.com/seriousstats/616206) - if (correction == "fieller") { + if (!is.null(se)) { + zrs.se <- se + } else if (correction == "fieller") { zrs.se <- (1.06 / (n - 3))^0.5 } else if (correction == "bw") { zrs.se <- ((1 + (cor^2) / 2) / (n - 3))^0.5 @@ -73,9 +82,11 @@ cor_to_ci <- function(cor, n, ci = 0.95, # Pearson ----------------------------------------------------------------- -.cor_to_ci_pearson <- function(cor, n, ci = 0.95, ...) { +.cor_to_ci_pearson <- function(cor, n, ci = 0.95, se = NULL, ...) { z <- atanh(cor) - se <- 1 / sqrt(n - 3) # Sample standard error + if (is.null(se)) { + se <- 1 / sqrt(n - 3) # Sample standard error + } # CI alpha <- 1 - (1 - ci) / 2 @@ -215,3 +226,161 @@ pbcor <- function(x, y, beta=.2){ res <- pbcor(x[isub], y[isub], ...) res } + +# Studentized bootstrap CI for correlations ----- + +#' Studentized bootstrap CI on the correlation scale +#' +#' Computes a studentized (bootstrap-t) confidence interval by pivoting on the +#' Fisher z scale and then back-transforming. +#' +#' @param tvec Numeric vector of bootstrap pivots: (z_star - z_obs) / se_star +#' @param t0_z Observed Fisher z value: atanh(est) +#' @param se_obs Analytical SE of z_obs +#' @param alpha Two-tailed significance level (e.g., 0.05 for 95% CI) +#' @return Numeric vector of length 2: c(lower, upper) on the correlation scale +#' @keywords internal +stud_ci <- function(tvec, t0_z, se_obs, alpha) { + qs <- quantile(tvec, probs = c(1 - alpha / 2, alpha / 2), names = FALSE) + z_bounds <- t0_z - qs * se_obs + tanh(z_bounds) +} + +# Bootstrap p-value dispatch ----- + +#' Compute a bootstrap p-value consistent with the selected CI method +#' +#' Dispatches to the appropriate p-value calculation based on the CI method, +#' ensuring that p < alpha if and only if the corresponding CI excludes the null. +#' Used by all bootstrap functions in the package (correlations, t-tests, SMD, +#' SES, TOST, and log-TOST). +#' +#' @param bvec Numeric vector of bootstrap estimates (on the working scale) +#' @param est Observed estimate (on the same scale as bvec) +#' @param null Null hypothesis value (single numeric, on the same scale as bvec) +#' @param alternative One of "two.sided", "greater", "less" +#' @param boot_ci One of "perc", "basic", "bca", "stud" +#' @param tvec Bootstrap pivots (required for "stud"): +#' typically `(bvec - est) / bootstrap_se` +#' @param se_obs Observed standard error on the working scale (required for "stud") +#' @param z0 BCa bias correction from `bca_params()` (required for "bca") +#' @param acc BCa acceleration from `bca_params()` (required for "bca") +#' @param nboot Number of bootstrap replicates +#' @param z_transform Logical indicating whether to apply Fisher z transformation +#' (used for correlation estimates; default FALSE) +#' @return A single p-value +#' @keywords internal +boot_pvalue <- function(bvec, est, null, alternative, + boot_ci, tvec = NULL, se_obs = NULL, + z0 = NULL, acc = NULL, nboot, + z_transform = FALSE) { + + boot_ci <- match.arg(boot_ci, c("perc", "basic", "bca", "stud")) + + if (boot_ci == "perc") { + sig <- .pval_perc(bvec, null, alternative, nboot) + } else if (boot_ci == "basic") { + sig <- .pval_basic(bvec, est, null, alternative, nboot) + } else if (boot_ci == "bca") { + sig <- .pval_bca(bvec, est, null, alternative, nboot, + z0 = z0, acc = acc) + } else if (boot_ci == "stud") { + sig <- .pval_stud(tvec, est, null, alternative, se_obs, nboot, + z_transform = z_transform) + } + + sig +} + +# Percentile p-value (Wilcox method) ----- +# Note on tie handling: the two-sided case uses the standard 0.5 continuity +# correction for ties at the null (Wilcox, 2022). For one-sided tests, the +# strict inequality convention (>= / <=) is used without tie correction, +# following the standard percentile bootstrap p-value definition. This is a +# deliberate methodological choice; see .pval_basic() for an alternative +# that applies tie correction in the one-sided cases. +.pval_perc <- function(bvec, null, alternative, nboot) { + if (alternative == "two.sided") { + phat <- (sum(bvec < null) + 0.5 * sum(bvec == null)) / nboot + sig <- 2 * min(phat, 1 - phat) + } else if (alternative == "greater") { + sig <- 1 - sum(bvec >= null) / nboot + } else { # less + sig <- 1 - sum(bvec <= null) / nboot + } + sig +} + +# Basic (reflected) p-value ----- +.pval_basic <- function(bvec, est, null, alternative, nboot) { + reflected <- 2 * est - bvec + if (alternative == "two.sided") { + phat <- (sum(reflected < null) + 0.5 * sum(reflected == null)) / nboot + sig <- 2 * min(phat, 1 - phat) + } else if (alternative == "greater") { + sig <- (sum(reflected < null) + 0.5 * sum(reflected == null)) / nboot + } else { # less + sig <- (sum(reflected > null) + 0.5 * sum(reflected == null)) / nboot + } + sig +} + +# BCa inverted p-value ----- +.pval_bca <- function(bvec, est, null, alternative, nboot, + z0, acc) { + # Continuity-corrected proportion below null + p0 <- (sum(bvec < null) + 0.5) / (nboot + 1) + + z_p0 <- qnorm(p0) + + # BCa-adjusted cumulative probability at the null + u <- z_p0 - z0 + p_bca <- pnorm((u * (1 - acc * z0) - z0) / (1 + acc * u)) + + if (alternative == "two.sided") { + sig <- 2 * min(p_bca, 1 - p_bca) + } else if (alternative == "greater") { + sig <- p_bca + } else { # less + sig <- 1 - p_bca + } + sig +} + +# Studentized (pivot) p-value ----- +.pval_stud <- function(tvec, est, null, alternative, se_obs, nboot, z_transform = FALSE) { + if(z_transform){ + t_obs <- (atanh(est) - atanh(null)) / se_obs + } else{ + t_obs <- (est - null) / se_obs + } + + + if (alternative == "two.sided") { + sig <- 2 * min(mean(tvec >= t_obs), mean(tvec <= t_obs)) + } else if (alternative == "greater") { + sig <- mean(tvec >= t_obs) + } else { # less + sig <- mean(tvec <= t_obs) + } + sig +} + +# SE on Fisher z scale for studentized bootstrap ----- + +#' Analytical SE on the Fisher z scale for a given correlation method +#' +#' @param r_star Correlation estimate (can be a vector for bootstrap replicates) +#' @param n Sample size +#' @param method One of "pearson", "kendall", "spearman" +#' @return SE on the Fisher z scale +#' @keywords internal +.fisher_z_se <- function(r_star, n, method) { + if (method == "pearson") { + 1 / sqrt(n - 3) + } else if (method == "spearman") { + sqrt((1 + r_star^2 / 2) / (n - 3)) + } else if (method == "kendall") { + sqrt(0.437 / (n - 4)) + } +} diff --git a/R/corsum_test.R b/R/corsum_test.R index 07d7432..0c8dc3c 100644 --- a/R/corsum_test.R +++ b/R/corsum_test.R @@ -4,7 +4,7 @@ #' #' Test for association between paired samples using only the correlation coefficient and sample size. #' Supports Pearson's product moment correlation, Kendall's \eqn{\tau} (tau), or Spearman's \eqn{\rho} (rho). -#' This is the updated version of the `TOSTr` function. +#' This is the updated version of the `TOSTr` function. This test is only an approximation and should be used with extreme care. #' #' @param r correlation coefficient (the estimated value) #' @param n sample size (number of pairs) @@ -12,8 +12,10 @@ #' @inheritParams z_cor_test #' #' @details -#' This function uses Fisher's z transformation for the correlations, -#' but uses Fieller's correction of the standard error for Kendall's \eqn{\tau} or Spearman's \eqn{\rho}. +#' This function uses Fisher's z transformation for the correlations. +#' For Spearman's \eqn{\rho}, the Bonett-Wright \eqn{\rho}-dependent SE formula +#' \eqn{\sqrt{(1 + r^2/2) / (n - 3)}} is used rather than the fixed 1.06 constant. +#' For Kendall's \eqn{\tau}, Fieller's correction is applied. #' #' Unlike `z_cor_test`, which requires raw data, this function only needs the correlation value #' and sample size. This is particularly useful when: @@ -42,8 +44,10 @@ #' * **p.value**: the p-value of the test. #' * **parameter**: the sample size with name "N". #' * **conf.int**: a confidence interval for the correlation appropriate to the specified alternative hypothesis. -#' * **estimate**: the estimated correlation coefficient, with name "cor", "tau", or "rho" corresponding to the method employed. -#' * **stderr**: the standard error of the test statistic. +#' * **estimate**: the estimated correlation coefficient, with name "r", "tau", or "rho" corresponding to the method employed. +#' * **stderr**: a named vector with `z.se` (standard error on the Fisher z scale, used for inference) +#' and `cor.se` (delta method SE on the correlation scale, for descriptive purposes). +#' Note that `cor.se` underestimates true sampling variability as |r| approaches 1. #' * **null.value**: the value(s) of the correlation coefficient under the null hypothesis. #' * **alternative**: character string indicating the alternative hypothesis. #' * **method**: a character string indicating how the correlation was measured. @@ -78,6 +82,9 @@ #' testing approach. British Journal of Mathematical and Statistical Psychology, 63(3), 527-537. #' https://doi.org/10.1348/000711009X475853, formula page 531. #' +#' Bonett, D. G., & Wright, T. A. (2000). Sample size requirements for estimating +#' Pearson, Kendall and Spearman correlations. Psychometrika, 65(1), 23-28. +#' #' @family Correlations #' @export @@ -143,20 +150,20 @@ corsum_test = function(r, # Pearson # Fisher method <- "Pearson's product-moment correlation" names(NVAL) = rep("correlation",length(NVAL)) - rfinal = c(cor = r_xy) + rfinal = c(r = r_xy) z.se <- 1 / sqrt(n_obs - 3) cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, method = "pearson") } if (method == "spearman") { method <- "Spearman's rank correlation rho" - # # Fieller adjusted + # Bonett-Wright rfinal = c(rho = r_xy) names(NVAL) = rep("rho",length(NVAL)) - z.se <- (1.06 / (n_obs - 3)) ^ 0.5 + z.se <- sqrt((1 + r_xy^2 / 2) / (n_obs - 3)) cint = cor_to_ci(cor = r_xy, n = n_obs, ci = ci, method = "spearman", - correction = "fieller") + correction = "bw") } if (method == "kendall") { method <- "Kendall's rank correlation tau" @@ -169,6 +176,13 @@ corsum_test = function(r, method = "kendall", correction = "fieller") } + + # append SE label to method name -------- + method <- paste(method, "with approximate SE") + + # delta method SE on correlation scale -------- + cor.se <- (1 - r_xy^2) * z.se + if(alternative %in% c("equivalence", "minimal.effect")){ if(alternative == "equivalence"){ zlo = z_xy-min(znull) @@ -214,7 +228,7 @@ corsum_test = function(r, parameter = N, conf.int = cint, estimate = rfinal, - stderr = c(z.se = z.se), + stderr = c(z.se = z.se, cor.se = cor.se), null.value = NVAL, alternative = alternative, method = method, diff --git a/R/globals.R b/R/globals.R index b6c5254..d7e029d 100644 --- a/R/globals.R +++ b/R/globals.R @@ -3,4 +3,5 @@ utils::globalVariables(c("mu","sigma","param","lambda", "low","high", "n", "y", "p.value", "Effect", "val","Z","group", - "estimate", "lower.ci", "upper.ci")) + "estimate", "lower.ci", "upper.ci", + "high_eq","low_eq")) diff --git a/R/hodges_lehmann.R b/R/hodges_lehmann.R index b121b6f..ba767ba 100644 --- a/R/hodges_lehmann.R +++ b/R/hodges_lehmann.R @@ -8,12 +8,11 @@ #' #' @section Purpose: #' The Hodges-Lehmann estimator provides a robust alternative to the mean for testing -#' location differences. It has a breakdown point of approximately 29.3%, meaning it -#' remains stable even when nearly 30% of the data are outliers. This function offers: +#' location differences. It is arguably a more stable option in the presence of outliers. This function offers: #' #' * Exact permutation tests for small samples #' * Randomization tests (permutation with replacement) for larger samples -#' * Asymptotic tests using kernel density estimation +#' * Asymptotic tests using kernel density estimation of the scale parameter #' * Support for equivalence and minimal effect testing #' * An interface that mirrors `wilcox.test` and `perm_t_test` #' @@ -31,7 +30,9 @@ #' has level 1-2*alpha (90% when alpha = 0.05). #' @param R the number of permutations. Default is `NULL`, which uses the asymptotic test. #' If `R >= max_perms` (the maximum number of possible permutations), exact permutation -#' is computed. Otherwise, Monte Carlo (permutation with replacement; i.e., randomization testing) sampling is used. +#' is computed. Otherwise, Monte Carlo (permutation with replacement; i.e., randomization +#' testing) sampling is used. Note: permutation tests are not supported for +#' `alternative = "equivalence"` or `alternative = "minimal.effect"` (see Details). #' @param scale the scale estimator for standardizing the test statistic in permutation #' tests. Options are: #' * `"S2"` (default): Median of absolute pairwise differences from the median-corrected @@ -68,7 +69,7 @@ #' #' ## Test Methods #' -#' **Asymptotic test (R = NULL):** Uses kernel density estimation to estimate the +#' **Asymptotic test (R = NULL):** Uses kernel density estimation (Fried & Dehling, 2011) to estimate the #' variance of the Hodges-Lehmann estimator (note: this generates confidence intervals that will differ from [stats::wilcox.test()]). The test statistic follows an approximate #' normal distribution. This method may have issues with very heavy-tailed distributions, #' very skewed distributions, or small sample sizes (n < 30 per group). In these cases, @@ -96,6 +97,34 @@ #' #' where Z is the median-corrected combined sample. #' +#' ## Permutation Tests with Non-Zero Null Values +#' +#' For standard alternatives (`two.sided`, `less`, `greater`) with `mu != 0`, +#' the permutation test uses an approximate approach: the observed test statistic +#' is centered at `mu`, but the permutation distribution is generated under +#' exchangeability (effectively `mu = 0`). Because the Hodges-Lehmann statistic +#' divided by the S1/S2 scale estimator is not a true pivot, this comparison is +#' approximate rather than exact. The approximation is generally adequate when +#' `mu` is moderate relative to the scale of the data, but may lose accuracy for +#' extreme null values. For the two-sample case, the scale estimator is +#' recomputed for each permutation, which partially mitigates this issue. +#' +#' ## Equivalence and Minimal Effect Testing +#' +#' Equivalence and minimal effect tests are only available with the asymptotic +#' method (`R = NULL`). Permutation tests are not supported for these +#' alternatives because the scale estimators (S1, S2) from Fried & Dehling +#' (2011) do not produce a pivotal test statistic for the Hodges-Lehmann +#' estimator. Without pivotality, the permutation distribution generated under +#' the exchangeability null is not a valid reference distribution for testing +#' at the equivalence bounds, and the resulting p-values can be unreliable. +#' This limitation compounds with the inherent conservatism of the naive +#' intersection-union procedure, potentially yielding substantial power loss. +#' +#' The asymptotic method uses kernel density estimation to approximate the +#' standard error, which provides a proper pivot and valid boundary-null +#' inference. +#' #' ## Alternatives #' #' The function supports five alternative hypotheses: @@ -142,8 +171,8 @@ #' after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) #' hodges_lehmann(before, after, paired = TRUE) #' -#' # Equivalence test -#' hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1), R = 999) +#' # Equivalence test (asymptotic only) +#' hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1)) #' #' # Formula interface #' hodges_lehmann(extra ~ group, data = sleep) @@ -166,6 +195,7 @@ #' @name hodges_lehmann #' @export hodges_lehmann +# TODO: add xname and yname arguments to allow user-specified group labels hodges_lehmann <- function(x, ...) { UseMethod("hodges_lehmann") } @@ -378,6 +408,22 @@ hodges_lehmann.default <- function(x, } } + # Permutation not supported for equivalence/minimal.effect + # The S1/S2 scale estimators do not produce a pivotal test statistic for the + # Hodges-Lehmann estimator, so the permutation distribution under + # exchangeability is not a valid reference distribution for boundary-null + # testing. The asymptotic test is recommended for these alternatives. + if (!is.null(R) && alternative %in% c("equivalence", "minimal.effect")) { + stop( + "Permutation tests (R != NULL) are not supported for equivalence or ", + "minimal.effect alternatives in hodges_lehmann(). The scale estimators ", + "(S1, S2) do not produce a pivotal statistic for the Hodges-Lehmann ", + "estimator, so the permutation reference distribution is not valid for ", + "boundary-null testing. Use the asymptotic test (R = NULL) instead.", + call. = FALSE + ) + } + # Data name extraction if (!is.null(y)) { dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) @@ -463,8 +509,14 @@ hodges_lehmann.default <- function(x, if (is.null(y)) { # Compute observed estimate + XNAME <- "x" + YNAME <- "y" estimate <- hl1_est(x) - names(estimate) <- if (paired) "pseudomedian of differences" else "pseudomedian" + names(estimate) <- if (paired) { + ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = TRUE) + } else { + ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = NULL, paired = FALSE) + } if (test_method == "asymptotic") { # ----- Asymptotic test ----- @@ -587,26 +639,6 @@ hodges_lehmann.default <- function(x, b <- sum(TSTAT >= obs_stat) pval <- hl_perm_pval(b, R.used, p_method) cint <- c(stats::quantile(EFF, 1 - ci_level, names = FALSE), Inf) - } else if (alternative == "equivalence") { - obs_stat_low <- (estimate - low_bound) / scale_est - obs_stat_high <- (estimate - high_bound) / scale_est - b_low <- sum(TSTAT >= obs_stat_low) - b_high <- sum(TSTAT <= obs_stat_high) - p_low <- hl_perm_pval(b_low, R.used, p_method) - p_high <- hl_perm_pval(b_high, R.used, p_method) - pval <- max(p_low, p_high) - cint <- stats::quantile(EFF, c(alpha, 1 - alpha), names = FALSE) - obs_stat <- if (p_low >= p_high) obs_stat_low else obs_stat_high - } else if (alternative == "minimal.effect") { - obs_stat_low <- (estimate - low_bound) / scale_est - obs_stat_high <- (estimate - high_bound) / scale_est - b_low <- sum(TSTAT <= obs_stat_low) - b_high <- sum(TSTAT >= obs_stat_high) - p_low <- hl_perm_pval(b_low, R.used, p_method) - p_high <- hl_perm_pval(b_high, R.used, p_method) - pval <- min(p_low, p_high) - cint <- stats::quantile(EFF, c(alpha, 1 - alpha), names = FALSE) - obs_stat <- if (p_low <= p_high) obs_stat_low else obs_stat_high } tstat_report <- obs_stat @@ -620,8 +652,10 @@ hodges_lehmann.default <- function(x, n <- length(y) # Compute observed estimate + XNAME <- "x" + YNAME <- "y" estimate <- hl2_est(x, y) - names(estimate) <- "difference in location" + names(estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = FALSE) if (test_method == "asymptotic") { # ----- Asymptotic test ----- @@ -744,7 +778,10 @@ hodges_lehmann.default <- function(x, if (is.na(scale_perm) || scale_perm <= 0) scale_perm <- scale_est TSTAT[i] <- hl_perm / scale_perm - EFF[i] <- hl_perm + # Store effect on the estimate-centered scale (hl_perm is null-centered, + # so adding estimate back gives the permutation distribution centered + # around the observed estimate, consistent with the one-sample case) + EFF[i] <- hl_perm + estimate } # Observed test statistic @@ -764,26 +801,6 @@ hodges_lehmann.default <- function(x, b <- sum(TSTAT >= obs_stat) pval <- hl_perm_pval(b, R.used, p_method) cint <- c(stats::quantile(EFF, 1 - ci_level, names = FALSE), Inf) - } else if (alternative == "equivalence") { - obs_stat_low <- (estimate - low_bound) / scale_est - obs_stat_high <- (estimate - high_bound) / scale_est - b_low <- sum(TSTAT >= obs_stat_low) - b_high <- sum(TSTAT <= obs_stat_high) - p_low <- hl_perm_pval(b_low, R.used, p_method) - p_high <- hl_perm_pval(b_high, R.used, p_method) - pval <- max(p_low, p_high) - cint <- stats::quantile(EFF, c(alpha, 1 - alpha), names = FALSE) - obs_stat <- if (p_low >= p_high) obs_stat_low else obs_stat_high - } else if (alternative == "minimal.effect") { - obs_stat_low <- (estimate - low_bound) / scale_est - obs_stat_high <- (estimate - high_bound) / scale_est - b_low <- sum(TSTAT <= obs_stat_low) - b_high <- sum(TSTAT >= obs_stat_high) - p_low <- hl_perm_pval(b_low, R.used, p_method) - p_high <- hl_perm_pval(b_high, R.used, p_method) - pval <- min(p_low, p_high) - cint <- stats::quantile(EFF, c(alpha, 1 - alpha), names = FALSE) - obs_stat <- if (p_low <= p_high) obs_stat_low else obs_stat_high } tstat_report <- obs_stat @@ -795,6 +812,8 @@ hodges_lehmann.default <- function(x, # ========================================================================== # Null value + # TODO: Consider updating null.value names to indicate direction + # (e.g., "location (x - y)") for consistency with estimate labels if (alternative %in% c("equivalence", "minimal.effect")) { null.value <- mu names(null.value) <- rep("location", 2) @@ -827,6 +846,17 @@ hodges_lehmann.default <- function(x, names(tstat_report) <- "Z" + # Compute sample_size + # Note: for paired, x <- x - y has already been done so y is NULL + # In hodges_lehmann, two-sample sizes are m and n (not nx/ny) + if (is.null(y)) { + # n is in scope from line ~440 (one-sample/paired) + sample_size <- c(n = n) + } else { + # m and n are in scope from lines ~447-448 (two-sample) + sample_size <- c(nx = m, ny = n) + } + rval <- list( statistic = tstat_report, p.value = pval, @@ -838,7 +868,8 @@ hodges_lehmann.default <- function(x, data.name = dname, call = match.call(), R = R, - R.used = R.used + R.used = R.used, + sample_size = sample_size ) if (keep_perm && !is.null(TSTAT)) { @@ -891,5 +922,18 @@ hodges_lehmann.formula <- function(formula, data, subset, na.action, ...) { DATA <- stats::setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("hodges_lehmann", c(DATA, list(...))) y$data.name <- DNAME + + # Resolve actual group labels from factor levels + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + is_paired <- isTRUE(dots$paired) + + names(y$estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = is_paired) + + # Relabel sample_size names + if (!is.null(y$sample_size) && length(y$sample_size) == 2) { + names(y$sample_size) <- levels(g) + } + y } diff --git a/R/htest_helpers.R b/R/htest_helpers.R index 4c8ecf1..239206e 100644 --- a/R/htest_helpers.R +++ b/R/htest_helpers.R @@ -386,6 +386,32 @@ describe_htest = function(htest,alpha = NULL,digits = 3){ return(print_state) } +#' @keywords internal +#' @noRd +# Substitute generic "x"/"y" labels with actual group level names +# in estimate names and sample_size names for formula interface methods +relabel_for_formula <- function(result, lvls) { + # Quote numeric-looking factor levels for display consistency + lq <- c(quote_if_numeric(lvls[1]), quote_if_numeric(lvls[2])) + + # Relabel estimate names + if (!is.null(names(result$estimate))) { + nms <- names(result$estimate) + nms <- gsub("\\bof x\\b", paste0("of ", lq[1]), nms) + nms <- gsub("\\bof y\\b", paste0("of ", lq[2]), nms) + nms <- gsub("\\(x - y", paste0("(", lq[1], " - ", lq[2]), nms) + nms <- gsub("\\(z = x - y", paste0("(z = ", lq[1], " - ", lq[2]), nms) + names(result$estimate) <- nms + } + + # Relabel sample_size names + if (!is.null(result$sample_size) && length(result$sample_size) == 2) { + names(result$sample_size) <- lvls + } + + result +} + rounder_stat = function(number, digits = 3){ if(is.na(number) || !is.numeric(number)){ diff --git a/R/htest_labels.R b/R/htest_labels.R new file mode 100644 index 0000000..6960736 --- /dev/null +++ b/R/htest_labels.R @@ -0,0 +1,119 @@ +# Internal label helpers for htest-returning functions -------- +# +# Shared utilities that build names(estimate) labels and SMD notation +# strings across TOSTER's t-test, Wilcoxon, and SMD functions. +# The core principle: default methods use generic group names ("x"/"y"); +# formula methods resolve actual factor level names; numeric-looking +# names get quoted via quote_if_numeric() (defined in trans_rank_prob.R). + +# Internal: Build estimate labels for t-test style htest objects -------- +# +# Constructs names(estimate) labels for t-test, Wilcoxon, bootstrap, +# and permutation test functions. Follows the same XNAME/YNAME resolution +# pattern as brunner_munzel(). +# +# @param type character; one of "t" (t-test), "wilcoxon" (Wilcoxon/Mann-Whitney) +# @param xname character; label for the first group (default: "x") +# @param yname character or NULL; label for the second group (default: "y", NULL for one-sample) +# @param paired logical; whether the test is paired +# @return character vector of label(s) for names(estimate) +# @noRd +ttest_estimate_label <- function(type = c("t", "wilcoxon"), + xname = "x", + yname = "y", + paired = FALSE) { + type <- match.arg(type) + + xq <- quote_if_numeric(xname) + + if (is.null(yname)) { + # One-sample + qty <- switch(type, + "t" = "mean", + "wilcoxon" = "(pseudo)median" + ) + return(paste(qty, "of", xq)) + } + + yq <- quote_if_numeric(yname) + + if (type == "t") { + if (paired) { + # Paired t-test: single estimate (test on difference scores z = x - y) + paste0("mean of the differences (z = ", xq, " - ", yq, ")") + } else { + # Two-sample t-test: two estimates (group means) + c(paste("mean of group", xq), + paste("mean of group", yq)) + } + } else { + # Wilcoxon: single Hodges-Lehmann estimate of location shift + if (paired) { + # Paired: test on difference scores z = x - y + paste0("Hodges-Lehmann estimate (z = ", xq, " - ", yq, ")") + } else { + # Two-sample + paste0("Hodges-Lehmann estimate (", xq, " - ", yq, ")") + } + } +} + +# Internal: Build SMD notation label -------- +# +# Constructs the ((XNAME-YNAME)/SD_*) notation string for SMD method descriptions. +# Used by smd_calc() and boot_smd_calc(). +# +# @param xname character; label for the first group (default: "x") +# @param yname character or NULL; label for the second group (NULL for one-sample) +# @param denom_label character; the SD subscript label (e.g., "pooled", "z", or a group name for Glass) +# @return character string like "((x-y)/SD_pooled)" +# @noRd +smd_notation_label <- function(xname = "x", + yname = NULL, + denom_label = "pooled") { + xq <- quote_if_numeric(xname) + + if (is.null(yname)) { + # One-sample: numerator is just the variable + numerator <- xq + } else { + yq <- quote_if_numeric(yname) + numerator <- paste0(xq, "-", yq) + } + + paste0("(", numerator, ")/SD_", denom_label) +} + +# Internal: Resolve SD subscript label for SMD notation -------- +# +# Maps the resolved denominator state to a human-readable subscript. +# +# @param denom character; the user-facing denom argument value +# @param int_denom character; the internally resolved denominator code ("z", "rm", "d", "glass1", "glass2") +# @param xname character; first group label (used for glass1) +# @param yname character; second group label (used for glass2) +# @return character string for the SD subscript +# @noRd +resolve_sd_label <- function(denom, int_denom, xname = "x", yname = "y", + var.equal = TRUE) { + if (denom != "auto") { + # User explicitly chose denom - use it directly (except glass -> group name) + switch(denom, + "z" = "z", + "rm" = "rm", + "pooled" = "pooled", + "avg" = "avg", + "glass1" = quote_if_numeric(xname), + "glass2" = quote_if_numeric(yname) + ) + } else { + # Auto-resolved - map from int_denom + switch(int_denom, + "z" = "z", + "rm" = "rm", + "d" = if (var.equal) "pooled" else "avg", + "glass1" = quote_if_numeric(xname), + "glass2" = quote_if_numeric(yname) + ) + } +} diff --git a/R/methods.TOSTt.R b/R/methods.TOSTt.R index 0f63a79..f5782f5 100644 --- a/R/methods.TOSTt.R +++ b/R/methods.TOSTt.R @@ -97,6 +97,10 @@ print.TOSTt <- function(x, cat("Note: studentized bootstrap ci method utilized.") } + if(x$call$boot_ci == "bca"){ + cat("Note: BCa (bias-corrected and accelerated) bootstrap ci method utilized.") + } + }else{ cat("Note: SMD confidence intervals are an approximation. See vignette(\"SMD_calcs\").") } diff --git a/R/others.R b/R/others.R index f7192f3..f02458b 100644 --- a/R/others.R +++ b/R/others.R @@ -52,35 +52,89 @@ tost_decision = function(hypothesis = "EQU", # Bootstrap CI functions ------ -## only an approximation... rather useless -# bca <- function(boots_est, alpha = 0.05){ -# conf.level = 1-alpha -# if(var(boots_est)==0){ -# lower <- mean(boots_est) -# upper <- mean(boots_est) -# return(c(lower, upper)) -# } -# -# if(max(boots_est)==Inf | min(boots_est)==-Inf){ -# stop("bca bootstrap CIs do not work when some values are infinite") -# } -# -# low <- (1 - conf.level)/2 -# high <- 1 - low -# sims <- length(boots_est) -# z.inv <- length(boots_est[boots_est < mean(boots_est)])/sims -# z <- qnorm(z.inv) -# U <- (sims - 1) * (mean(boots_est, na.rm=TRUE) - boots_est) -# top <- sum(U^3) -# under <- 6 * (sum(U^2))^{3/2} -# a <- top / under -# lower.inv <- pnorm(z + (z + qnorm(low))/(1 - a * (z + qnorm(low)))) -# lower <- quantile(boots_est, lower.inv, names=FALSE) -# upper.inv <- pnorm(z + (z + qnorm(high))/(1 - a * (z + qnorm(high)))) -# upper <- quantile(boots_est, upper.inv, names=FALSE) -# return(c(lower, upper)) -# } +#' BCa bootstrap confidence interval (internal) +#' +#' Computes a bias-corrected and accelerated (BCa) bootstrap confidence interval. +#' The BCa method provides second-order accuracy by correcting for both bias and +#' skewness in the bootstrap distribution, using jackknife estimates to compute +#' the acceleration factor. +#' +#' @param boots_est Numeric vector of bootstrap estimates (on the working scale) +#' @param t0 Original estimate (on the same working scale as boots_est) +#' @param jack_est Numeric vector of jackknife (leave-one-out) estimates (on the same working scale) +#' @param alpha Significance level (e.g., 0.05 for 95% CI) +#' @return Numeric vector of length 2: c(lower, upper) +#' @keywords internal +bca_ci <- function(boots_est, t0, jack_est, alpha) { + # Bias correction + z0 <- qnorm(mean(boots_est < t0)) + + # Check for infinite z0 (all boots on one side of t0) + if (!is.finite(z0)) { + stop( + "BCa bias correction is infinite (all bootstrap estimates are on one side of ", + "the original estimate). This may indicate a degenerate bootstrap distribution. ", + "Consider using boot_ci = 'perc' instead.", + call. = FALSE + ) + } + + # Acceleration via jackknife + L <- mean(jack_est) - jack_est + denom <- 6 * sum(L^2)^(3/2) + + if (denom == 0) { + stop( + "BCa acceleration factor is degenerate (all jackknife estimates are identical). ", + "This typically occurs with constant data or extreme boundary cases. ", + "Consider using boot_ci = 'perc' instead.", + call. = FALSE + ) + } + a <- sum(L^3) / denom + + # Adjusted quantiles + z_alpha <- qnorm(c(alpha / 2, 1 - alpha / 2)) + numer <- z0 + z_alpha + adj <- pnorm(z0 + numer / (1 - a * numer)) + + if (any(adj <= 0) || any(adj >= 1)) { + stop( + "BCa adjusted quantiles are outside (0, 1), indicating extreme bias or skewness ", + "in the bootstrap distribution. Consider using boot_ci = 'perc' instead.", + call. = FALSE + ) + } + c(quantile(boots_est, adj[1], names = FALSE), + quantile(boots_est, adj[2], names = FALSE)) +} + +#' Compute BCa bias-correction and acceleration parameters +#' +#' Extracts z0 (bias correction) and acc (acceleration) from bootstrap and +#' jackknife estimates for use with both \code{bca_ci} and \code{boot_pvalue}. +#' +#' @param boots_est Numeric vector of bootstrap estimates +#' @param t0 Original estimate (on the same scale as boots_est) +#' @param jack_est Numeric vector of jackknife (leave-one-out) estimates +#' @return A list with components \code{z0} and \code{acc} +#' @keywords internal +bca_params <- function(boots_est, t0, jack_est) { + z0 <- qnorm(mean(boots_est < t0)) + if (!is.finite(z0)) { + warning( + "BCa bias correction is infinite (all bootstrap estimates are on one ", + "side of the original estimate). BCa p-values may be unreliable. ", + "Consider using boot_ci = 'perc' instead.", + call. = FALSE + ) + } + L <- mean(jack_est) - jack_est + denom <- 6 * sum(L^2)^(3/2) + acc <- if (denom != 0) sum(L^3) / denom else 0 + list(z0 = z0, acc = acc) +} basic <- function(boots_est, t0, alpha){ conf = 1-alpha diff --git a/R/perm_t_test.R b/R/perm_t_test.R index 833b54c..95123a3 100644 --- a/R/perm_t_test.R +++ b/R/perm_t_test.R @@ -97,6 +97,42 @@ #' If the number of possible permutations is less than R, all exact permutations are computed #' and a message is printed to the console. #' +#' ## Permutation Approach to Equivalence and Minimal Effect Testing +#' +#' When `alternative = "equivalence"` or `alternative = "minimal.effect"`, the +#' function performs two one-sided permutation tests and combines them following +#' the nonparametric combination (NPC) framework of Arboretti, Pesarin, and +#' Salmaso (2021). +#' +#' The `"equivalence"` alternative implements the **intersection-union (IU)** +#' approach: the null hypothesis is non-equivalence and the alternative is +#' equivalence. Two one-sided p-values are computed and the global p-value is +#' their maximum. The `"minimal.effect"` alternative implements the +#' **union-intersection (UI)** approach: the null hypothesis is equivalence and +#' the alternative is non-equivalence. The global p-value is the minimum of the +#' two one-sided p-values. Both partial tests are evaluated against the same +#' permutation distribution (i.e., the same set of permuted samples), which +#' preserves the negative dependence between the two test statistics as required +#' by the NPC theory. +#' +#' The permutation distribution is constructed under the exchangeability null +#' (i.e., by permuting the unshifted data), while the observed test statistics +#' are centered at the equivalence bounds. This differs from the shifted-data +#' algorithm described in Arboretti et al. (2021), which permutes margin-shifted +#' pooled samples. Under the default studentized permutation approach +#' (`perm_se = TRUE`), the two methods are asymptotically equivalent +#' (Janssen, 1997; Chung & Romano, 2013). The exchangeability-based approach +#' avoids the computational cost of constructing and permuting two separate +#' shifted datasets. +#' +#' Note that these are *uncalibrated* (naive) procedures in the terminology of +#' Arboretti et al. (2021). For the IU direction (`"equivalence"`), the naive +#' approach can be conservative when sample sizes or equivalence margins are +#' small relative to the variability in the data. For the UI direction +#' (`"minimal.effect"`), the impact of not calibrating is smaller because the +#' calibrated critical value lies in the narrower interval +#' \eqn{[\alpha/2, \alpha]} rather than \eqn{[\alpha, (1+\alpha)/2)}. +#' #' @section Comparison with Other Packages: #' Results from `perm_t_test` may differ slightly from other permutation test implementations #' such as `MKinfer::perm.t.test` or `coin::oneway_test`. These differences arise from @@ -161,6 +197,10 @@ #' #' #' @references +#' +#' Arboretti, R., Pesarin, F. & Salmaso, L. (2021). A unified approach to permutation testing for equivalence. +#' Stat Methods Appl 30, 1033-1052. doi: 10.1007/s10260-020-00548-0 +#' #' Efron, B., & Tibshirani, R. J. (1993). An Introduction to the Bootstrap. Chapman and Hall/CRC. #' #' Janssen, A. (1997). Studentized permutation tests for non-i.i.d. hypotheses and the @@ -180,6 +220,7 @@ #' @name perm_t_test #' @export perm_t_test +# TODO: add xname and yname arguments to allow user-specified group labels perm_t_test <- function(x, ...) { UseMethod("perm_t_test") } @@ -520,10 +561,14 @@ perm_t_test.default <- function(x, tstat <- (mx - mu) / stderr } + XNAME <- "x" + YNAME <- "y" estimate <- setNames(mx, if (paired) { - if (tr > 0) "trimmed mean of the differences" else "mean of the differences" + if (tr > 0) paste0("trimmed mean of the differences (z = ", XNAME, " - ", YNAME, ", tr = ", tr, ")") + else ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = TRUE) } else { - if (tr > 0) "trimmed mean of x" else "mean of x" + if (tr > 0) paste0("trimmed mean of ", XNAME) + else ttest_estimate_label(type = "t", xname = XNAME, yname = NULL, paired = FALSE) }) # Generate permutation distribution @@ -649,12 +694,17 @@ perm_t_test.default <- function(x, tstat <- (diff_means - mu) / stderr } + XNAME <- "x" + YNAME <- "y" if (tr > 0) { - estimate <- c(mx, my) - names(estimate) <- c("trimmed mean of x", "trimmed mean of y") + estimate <- c(mx, my, mx - my) + names(estimate) <- c(paste0("trimmed mean of ", XNAME), + paste0("trimmed mean of ", YNAME), + paste0("trimmed mean difference (", XNAME, " - ", YNAME, ", tr = ", tr, ")")) } else { - estimate <- c(mx, my) - names(estimate) <- c("mean of x", "mean of y") + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = FALSE) + estimate <- c(mx, my, mx - my) + names(estimate) <- c(est_labels, paste0("mean difference (", XNAME, " - ", YNAME, ")")) } # Generate permutation distribution @@ -786,6 +836,8 @@ perm_t_test.default <- function(x, } # Set up null value + # TODO: Consider updating null.value names to indicate direction + # (e.g., "difference in means (x - y)") for consistency with estimate labels if (alternative %in% c("equivalence", "minimal.effect")) { null.value <- mu names(null.value) <- rep("difference in means", 2) @@ -846,6 +898,14 @@ perm_t_test.default <- function(x, names(tstat_report) <- "t-observed" names(df) <- "df" + # Compute sample_size + # Note: for paired, x <- x - y has already been done so y is NULL and nx is n_pairs + if (is.null(y)) { + sample_size <- c(n = nx) + } else { + sample_size <- c(nx = nx, ny = ny) + } + # Build output rval <- list( statistic = tstat_report, @@ -860,7 +920,8 @@ perm_t_test.default <- function(x, data.name = dname, call = match.call(), R = R, - R.used = R_used + R.used = R_used, + sample_size = sample_size ) if (keep_perm) { @@ -912,5 +973,38 @@ perm_t_test.formula <- function(formula, data, subset, na.action, ...) { DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("perm_t_test", c(DATA, list(...))) y$data.name <- DNAME + + # Resolve actual group labels from factor levels + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + xq <- quote_if_numeric(XNAME) + yq <- quote_if_numeric(YNAME) + + is_paired <- isTRUE(dots$paired) + tr_val <- if (!is.null(dots$tr)) dots$tr else 0 + + if (tr_val > 0) { + # Trimmed labels: substitute group names + nms <- names(y$estimate) + nms <- gsub("\\bof x\\b", paste0("of ", xq), nms) + nms <- gsub("\\bof y\\b", paste0("of ", yq), nms) + nms <- gsub("\\(x - y", paste0("(", xq, " - ", yq), nms) + nms <- gsub("\\(z = x - y", paste0("(z = ", xq, " - ", yq), nms) + names(y$estimate) <- nms + } else { + if (!is_paired && length(y$estimate) >= 2) { + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = FALSE) + diff_label <- paste0("mean difference (", xq, " - ", yq, ")") + names(y$estimate) <- c(est_labels, diff_label) + } else if (is_paired) { + names(y$estimate) <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = TRUE) + } + } + + # Relabel sample_size names + if (!is.null(y$sample_size) && length(y$sample_size) == 2) { + names(y$sample_size) <- levels(g) + } + y } diff --git a/R/rank_diff.R b/R/rank_diff.R new file mode 100644 index 0000000..b1deb7c --- /dev/null +++ b/R/rank_diff.R @@ -0,0 +1,120 @@ +#' @title Rank Difference Transformation for Paired Data +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Applies the Kornbrot (1990) rank difference transformation to paired data. +#' All 2n observations are jointly ranked using midranks for ties, and the +#' ranks corresponding to each condition are returned. The transformed data +#' can then be passed to [ses_calc()] or [boot_ses_calc()] +#' for effect size estimation that is invariant under monotone transformations +#' of the original scale. +#' +#' @param x numeric vector of observations from condition 1. +#' @param y numeric vector of observations from condition 2, same length as x. +#' Pairs are defined positionally: \code{x[i]} is paired with \code{y[i]}. +#' @param names optional character vector of length 2 giving column names for +#' the returned data frame. Default is \code{c("x", "y")}. +#' +#' @details +#' The standard Wilcoxon signed-rank procedure for paired data computes +#' differences \eqn{d_i = x_i - y_i}, then ranks the absolute values +#' \eqn{|d_i|}. This is meaningful only when the differences themselves are +#' on an interval scale (i.e., when it makes sense to say that one difference +#' is "larger" than another). +#' +#' For purely ordinal data, the differences may not be rankable. The Kornbrot +#' (1990) rank difference procedure addresses this by: +#' \enumerate{ +#' \item Pooling all 2n observations from both conditions into a single vector. +#' \item Ranking the pooled vector using standard midranks for ties. +#' \item Returning the ranks corresponding to each condition. +#' } +#' +#' The resulting rank differences \eqn{R(x_i) - R(y_i)} are then suitable +#' for paired signed-rank effect size computation. Because the transformation +#' uses only the ordinal information in the data, the effect size is invariant +#' under any monotone (order-preserving) transformation of the original scale. +#' +#' ## Usage with ses_calc +#' +#' Pass the transformed columns directly to \code{ses_calc(..., paired = TRUE)}: +#' +#' \preformatted{ +#' rd <- rank_diff(x, y) +#' ses_calc(x = rd$x, y = rd$y, paired = TRUE, ses = "rb") +#' } +#' +#' Because \code{mu} has no meaningful interpretation on the joint-rank scale, +#' always use \code{mu = 0} (the default) when analysing rank-difference data. +#' +#' @return A data frame with two columns (named by \code{names}) containing +#' the joint ranks for condition 1 and condition 2, respectively. The number +#' of rows equals the number of complete pairs. Missing-value pairs (where +#' either \code{x[i]} or \code{y[i]} is \code{NA}) are removed before +#' ranking, and a message is printed if any pairs are dropped. +#' +#' @examples +#' # Kornbrot (1990) Tables 1-2: time vs rate give different +#' # standard Wilcoxon results but identical rank difference results +#' time_plac <- c(4.6, 4.3, 6.7, 5.8, 5.0, 4.2, 6.0, +#' 2.0, 2.6, 10.0, 3.4, 7.1, 8.6) +#' time_drug <- c(2.9, 2.8, 12.0, 3.8, 5.9, 6.5, 3.3, +#' 2.3, 2.1, 14.3, 2.4, 14.0, 4.9) +#' +#' # Standard approach: different results for time vs rate +#' ses_calc(time_plac, time_drug, paired = TRUE, ses = "rb") +#' ses_calc(60 / time_plac, 60 / time_drug, paired = TRUE, ses = "rb") +#' +#' # Rank difference approach: identical results +#' rd_time <- rank_diff(time_plac, time_drug) +#' rd_rate <- rank_diff(60 / time_plac, 60 / time_drug) +#' ses_calc(rd_time$x, rd_time$y, paired = TRUE, ses = "rb") +#' ses_calc(rd_rate$x, rd_rate$y, paired = TRUE, ses = "rb") +#' +#' @references +#' Kornbrot, D. E. (1990). The rank difference test: A new and meaningful +#' alternative to the Wilcoxon signed ranks test for ordinal data. +#' *British Journal of Mathematical and Statistical Psychology*, 43, 241-264. +#' +#' @family effect sizes +#' @export +rank_diff <- function(x, y, names = c("x", "y")) { + + if (!is.numeric(x) || !is.numeric(y)) { + stop("x and y must be numeric vectors.") + } + + if (length(x) != length(y)) { + stop("x and y must have the same length (paired data).") + } + + if (length(names) != 2) { + stop("names must be a character vector of length 2.") + } + + # Remove pairs with any NA + complete <- complete.cases(x, y) + n_dropped <- sum(!complete) + if (n_dropped > 0) { + message(n_dropped, " pairs with missing values removed before ranking.") + x <- x[complete] + y <- y[complete] + } + + if (length(x) == 0) { + stop("No complete pairs remaining after removing missing values.") + } + + # Pool all 2n observations and rank with midranks for ties + n_pairs <- length(x) + all_vals <- c(x, y) + all_ranks <- rank(all_vals) + + # Return data frame with ranks for each condition + out <- data.frame( + all_ranks[1:n_pairs], + all_ranks[(n_pairs + 1):(2 * n_pairs)] + ) + colnames(out) <- names + out +} diff --git a/R/rbs_calcs.R b/R/rbs_calcs.R index 8066f66..c3a1c03 100644 --- a/R/rbs_calcs.R +++ b/R/rbs_calcs.R @@ -3,6 +3,8 @@ rbs_calc = function (x, y, # adapted from effectsize R package if (paired) { z <- (x-y) - mu + z <- z[z != 0] + if (length(z) == 0) return(0) abs_z = abs(z) RR = -1 * rank(abs_z) * sign(z) Rplus = sum(RR[RR > 0]) @@ -123,6 +125,7 @@ rho_to_z <- function(x){ #' @return value on the log-odds scale #' @noRd to_logodds <- function(value, scale) { + switch(scale, "rb" = { p <- (value + 1) / 2 @@ -140,6 +143,378 @@ to_logodds <- function(value, scale) { ) } +#' Convert effect size value to cstat (concordance probability) scale +#' @param value the value to convert +#' @param from_scale character: "rb", "cstat", "odds", or "logodds" +#' @return value on cstat scale +#' @noRd +to_cstat <- function(value, from_scale) { + switch(from_scale, + "cstat" = value, + "rb" = (value + 1) / 2, + "odds" = value / (1 + value), + "logodds" = plogis(value) + ) +} + +# === Score-type functions for paired/one-sample designs === + +#' Extract paired rank information for score-based inference +#' +#' Computes the key quantities from paired/one-sample data needed for +#' score-based inference: N (non-zero differences), S, Q, T+, p_hat. +#' +#' @param x numeric vector (first sample or one-sample data) +#' @param y numeric vector (second sample), or NULL for one-sample +#' @param mu hypothesized difference (default 0) +#' @return list with n_eff, S, Q, T_plus, p_hat +#' @noRd +paired_rank_info <- function(x, y = NULL, mu = 0) { + if (is.null(y)) { + d <- x - mu + } else { + d <- x - y - mu + } + + # Remove zeros (ties with mu) + d <- d[d != 0] + N <- length(d) + + if (N == 0) { + return(list(n_eff = 0, S = 0, Q = 0, T_plus = 0, p_hat = 0.5)) + } + + # Rank absolute differences (average ties) + r <- rank(abs(d)) + + # T+ = sum of ranks where d > 0 + T_plus <- sum(r[d > 0]) + + S <- N * (N + 1) / 2 + Q <- sum(r^2) + p_hat <- T_plus / S + + list( + n_eff = N, + S = S, + Q = Q, + T_plus = T_plus, + p_hat = p_hat + ) +} + +#' Score CI for paired designs (Wilson-type) +#' +#' Computes a Wilson-score-type confidence interval for the concordance +#' probability (cstat) from paired/one-sample signed-rank data. +#' +#' The CI inverts the score test, yielding a quadratic in pi0 with +#' closed-form solution (no root-finding needed). +#' +#' @param p_hat concordance estimate (T_plus / S) +#' @param n_eff number of non-zero differences +#' @param Q sum of squared (average) ranks +#' @param conf.level confidence level +#' @param correct logical; apply continuity correction? +#' @return numeric vector of length 2: (lower, upper) on cstat scale +#' @noRd +score_ci_paired <- function(p_hat, n_eff, Q, + conf.level = 0.95, + correct = FALSE) { + + S <- n_eff * (n_eff + 1) / 2 + + if (n_eff < 1 || Q == 0) { + return(c(0, 1)) + } + + alpha <- 1 - conf.level + z_crit <- qnorm(1 - alpha / 2) + z2 <- z_crit^2 + + # Ratio that appears in Wilson formula + c_val <- z2 * Q / S^2 + + # Helper: solve the Wilson quadratic for a given "center" a + # Returns (lower_root, upper_root) + wilson_roots <- function(a) { + A <- 1 + c_val + B <- -(2 * a + c_val) + C <- a^2 + + disc <- B^2 - 4 * A * C + if (disc < 0) disc <- 0 + + lo <- (-B - sqrt(disc)) / (2 * A) + hi <- (-B + sqrt(disc)) / (2 * A) + c(lo, hi) + } + + if (!correct) { + roots <- wilson_roots(p_hat) + lower <- roots[1] + upper <- roots[2] + } else { + # Continuity correction: shift p_hat by h = 0.5/S toward pi0 + # Lower bound: use a' = min(p_hat + h, 1), take smaller root + # Upper bound: use a'' = max(p_hat - h, 0), take larger root + h <- 0.5 / S + + roots_low <- wilson_roots(min(p_hat + h, 1)) + roots_high <- wilson_roots(max(p_hat - h, 0)) + + lower <- roots_low[1] + upper <- roots_high[2] + } + + # Clamp to [0, 1] + lower <- max(0, lower) + upper <- min(1, upper) + + c(lower, upper) +} + +#' Score p-value for paired designs +#' +#' Computes a score-type p-value for testing H0: pi = pi0, +#' where pi is the concordance probability. +#' At pi0 = 0.5 this matches wilcox.test(..., exact = FALSE). +#' +#' @param p_hat concordance estimate +#' @param pi0 null hypothesis value on cstat scale +#' @param n_eff number of non-zero differences +#' @param Q sum of squared (average) ranks +#' @param alternative "two.sided", "less", or "greater" +#' @param correct apply continuity correction? +#' @return list with z.statistic and p.value +#' @noRd +score_pvalue_paired <- function(p_hat, pi0, n_eff, Q, + alternative = "two.sided", + correct = FALSE) { + + S <- n_eff * (n_eff + 1) / 2 + + if (n_eff < 1 || Q == 0) { + return(list(z.statistic = NA_real_, p.value = NA_real_)) + } + + # Variance under H0 + var_null <- pi0 * (1 - pi0) * Q / S^2 + se_null <- sqrt(var_null) + + if (se_null < .Machine$double.eps) { + return(list(z.statistic = NA_real_, p.value = NA_real_)) + } + + if (correct) { + h <- 0.5 / S + numer <- max(abs(p_hat - pi0) - h, 0) + z <- numer / se_null * sign(p_hat - pi0) + # Edge case: if p_hat == pi0 after correction, z = 0 + if (p_hat == pi0) z <- 0 + } else { + z <- (p_hat - pi0) / se_null + } + + p_val <- switch(alternative, + "two.sided" = 2 * pnorm(-abs(z)), + "less" = pnorm(z), + "greater" = pnorm(z, lower.tail = FALSE) + ) + + list(z.statistic = z, p.value = p_val) +} + +#' Descriptive SE for paired score method +#' +#' Computes descriptive standard errors evaluated at p_hat. +#' These are for reporting; the CI comes from test inversion, not SE +/- z. +#' +#' @param p_hat concordance estimate +#' @param n_eff number of non-zero differences +#' @param Q sum of squared (average) ranks +#' @return list with se_cstat, se_rb, se_logodds, se_odds +#' @noRd +score_se_paired <- function(p_hat, n_eff, Q) { + + S <- n_eff * (n_eff + 1) / 2 + + # Boundary-safe p_hat for SE computation + p_safe <- pmin(pmax(p_hat, 1e-10), 1 - 1e-10) + + se_cstat <- sqrt(p_safe * (1 - p_safe) * Q / S^2) + se_rb <- 2 * se_cstat + se_logodds <- se_cstat / (p_safe * (1 - p_safe)) + se_odds <- se_cstat / (1 - p_safe)^2 + + list( + se_cstat = se_cstat, + se_rb = se_rb, + se_logodds = se_logodds, + se_odds = se_odds + ) +} + +# === Score-type CI functions (Fay & Malinovsky 2018) === + +#' Compute tie adjustment factor for WMW variance +#' +#' Computes the tie correction factor used in the variance of the +#' Wilcoxon-Mann-Whitney statistic. +#' +#' @param x numeric vector, group 1 +#' @param y numeric vector, group 2 +#' @return scalar tie factor in 0, 1; equals 1 when no ties +#' @noRd +wmw_tie_factor <- function(x, y) { + r <- rank(c(x, y)) + N <- length(r) + NTIES <- table(r) + tf <- 1 - sum(NTIES^3 - NTIES) / (N * (N + 1) * (N - 1)) + tf +} + +#' Score-type variance of the Mann-Whitney parameter (V_LAPH) +#' +#' Computes V_LAPH(phi) from Fay & Malinovsky (2018), which is the +#' variance of the Mann-Whitney estimator under the proportional odds +#' model, evaluated at a candidate parameter value phi. +#' +#' @param phi candidate value of the Mann-Whitney parameter (scalar in (0,1)) +#' @param tf tie adjustment factor from wmw_tie_factor() +#' @param n1 sample size for group 1 (x) +#' @param n2 sample size for group 2 (y) +#' @return scalar variance +#' @references +#' Fay, M.P. and Malinovsky, Y. (2018). Confidence Intervals of the +#' Mann-Whitney Parameter that are Compatible with the Wilcoxon-Mann-Whitney +#' Test. Statistics in Medicine, 37, 3991-4006. +#' @noRd +v_laph <- function(phi, tf, n1, n2) { + tf * (phi * (1 - phi) / (n1 * n2)) * + (1 + ((n1 + n2 - 2) / 2) * + ((1 - phi) / (2 - phi) + phi / (1 + phi))) +} + +#' Score-type p-value for the Mann-Whitney parameter +#' +#' Computes a p-value testing H0: phi = phi_null using the score statistic +#' with optional continuity correction. +#' +#' @param phi_hat observed Mann-Whitney estimate (concordance probability) +#' @param phi_null null hypothesis value on the cstat scale +#' @param tf tie adjustment factor +#' @param n1 sample size for group 1 +#' @param n2 sample size for group 2 +#' @param alternative character: "two.sided", "less", or "greater" +#' @param correct logical: apply continuity correction? +#' @return list with elements: p.value, z.statistic +#' @noRd +score_pvalue_wmw <- function(phi_hat, phi_null, tf, n1, n2, + alternative = "two.sided", correct = FALSE) { + + # Continuity corrections (separate for each direction) + corr_less <- 0 + corr_greater <- 0 + if (correct) { + corr_less <- -0.5 / (n1 * n2) + corr_greater <- 0.5 / (n1 * n2) + } + + V_null <- v_laph(phi_null, tf, n1, n2) + + # Handle degenerate case (all values equal -> tf = 0 -> V = 0) + if (V_null <= 0) { + return(list(p.value = 1, z.statistic = 0)) + } + + se_null <- sqrt(V_null) + + z_less <- (phi_hat - phi_null - corr_less) / se_null + z_greater <- (phi_hat - phi_null - corr_greater) / se_null + + p_val <- switch(alternative, + "two.sided" = 2 * min(pnorm(z_less), pnorm(z_greater, lower.tail = FALSE)), + "less" = pnorm(z_less), + "greater" = pnorm(z_greater, lower.tail = FALSE) + ) + + # For reporting, use the z closer to the observed direction + z_stat <- switch(alternative, + "two.sided" = if (phi_hat >= phi_null) z_greater else z_less, + "less" = z_less, + "greater" = z_greater + ) + + list(p.value = min(1, p_val), z.statistic = z_stat) +} + +#' Score-type confidence interval for the Mann-Whitney parameter +#' +#' Constructs a CI by inverting the score test: finds the values of phi +#' where the score statistic equals the critical value. +#' +#' @param phi_hat observed Mann-Whitney estimate (concordance probability) +#' @param tf tie adjustment factor +#' @param n1 sample size for group 1 +#' @param n2 sample size for group 2 +#' @param conf.level confidence level (e.g. 0.95) +#' @param correct logical: apply continuity correction? +#' @param epsilon small number for uniroot bounds (default 1e-8) +#' @return numeric vector of length 2: c(lower, upper) on cstat scale +#' @noRd +score_ci_wmw <- function(phi_hat, tf, n1, n2, conf.level = 0.95, + correct = FALSE, epsilon = 1e-8) { + + alpha <- 1 - conf.level + + # Continuity corrections + corr_less <- 0 + corr_greater <- 0 + if (correct) { + corr_less <- -0.5 / (n1 * n2) + corr_greater <- 0.5 / (n1 * n2) + } + + # The score function: at the true phi_null, this should equal zq + wfunc <- function(phi_null, zq, correction = 0) { + V <- v_laph(phi_null, tf, n1, n2) + if (V <= 0) return(-Inf) + (phi_hat - phi_null - correction) / sqrt(V) - zq + } + + phimin <- epsilon + phimax <- 1 - epsilon + + root <- function(zq, corr) { + f.lower <- wfunc(phimin, zq, corr) + if (f.lower <= 0) return(phimin) + f.upper <- wfunc(phimax, zq, corr) + if (f.upper >= 0) return(phimax) + uniroot(wfunc, c(phimin, phimax), + f.lower = f.lower, f.upper = f.upper, + tol = epsilon, zq = zq, correction = corr)$root + } + + # Two-sided CI + # Lower bound: find phi_L where score stat = z_{1-alpha/2} + # Upper bound: find phi_U where score stat = z_{alpha/2} + + lower <- if (phi_hat == 0) { + 0 + } else { + root(zq = qnorm(alpha / 2, lower.tail = FALSE), corr = corr_greater) + } + + upper <- if (phi_hat == 1) { + 1 + } else { + root(zq = qnorm(alpha / 2), corr = corr_less) + } + + c(lower, upper) +} + # === New variance estimation functions (Agresti/Lehmann method) === #' Compute placement values for two-sample comparison @@ -229,9 +604,12 @@ var_concordance_paired <- function(d) { #' @param y numeric vector (group 2 or post-treatment), NULL for one-sample #' @param paired logical, TRUE for paired samples #' @param mu hypothesized difference (default 0) +#' @param use_score_fallback logical, if TRUE and two-sample boundary is hit, use score CI +#' @param conf.level confidence level for score CI fallback (default 0.95) #' @return list with point estimates and SEs for all effect sizes, including boundary_corrected flag #' @noRd -ses_compute_agresti <- function(x, y = NULL, paired = FALSE, mu = 0) { +ses_compute_agresti <- function(x, y = NULL, paired = FALSE, mu = 0, + use_score_fallback = TRUE, conf.level = 0.95) { if (is.null(y)) { # One-sample: compare x to mu (treat as paired with y = mu) @@ -241,18 +619,23 @@ ses_compute_agresti <- function(x, y = NULL, paired = FALSE, mu = 0) { } # Track if continuity correction was applied - boundary_corrected <- FALSE + boundary_used_score_ci <- FALSE + score_ci_cstat <- NULL + + # Store original p_hat before any correction (needed for score fallback) + p_hat_original <- NULL if (paired) { # === PAIRED SAMPLES === # Use rbs_calc to get the point estimate (ensures consistency) - # Note: rbs_calc expects x and y swapped for paired (it computes x - y) - r_hat <- rbs_calc(x = y, y = x, mu = mu, paired = TRUE) + # Natural order: P(X - Y > 0) + r_hat <- rbs_calc(x = x, y = y, mu = mu, paired = TRUE) p_hat <- rb_to_cstat(r_hat) + p_hat_original <- p_hat # Compute variance using Agresti method - d <- y - x - mu + d <- x - y - mu d_nonzero <- d[d != 0] n_nonzero <- length(d_nonzero) @@ -261,49 +644,79 @@ ses_compute_agresti <- function(x, y = NULL, paired = FALSE, mu = 0) { return(NULL) } - # Continuity correction for boundary cases (paired/one-sample) - # S = total rank sum, analogous to n1 * n2 in the two-sample case - S_total <- n_nonzero * (n_nonzero + 1) / 2 - if (p_hat <= 0) { - p_hat <- 0.5 / S_total - boundary_corrected <- TRUE - } else if (p_hat >= 1) { - p_hat <- 1 - 0.5 / S_total - boundary_corrected <- TRUE - } + # Haldane-type boundary correction for paired/one-sample + # N_pairs = N*(N+1)/2 is the maximum possible Wilcoxon signed-rank statistic + N_pairs <- n_nonzero * (n_nonzero + 1) / 2 - # Recompute r_hat from corrected p_hat if needed - if (boundary_corrected) { + if (p_hat <= 0 || p_hat >= 1) { + boundary_corrected <- TRUE + # Concordance count: C = p_hat * N_pairs (will be 0 or N_pairs at boundary) + C <- p_hat * N_pairs + # Haldane-type shrinkage correction + p_hat <- (C + 0.5) / (N_pairs + 1) r_hat <- 2 * p_hat - 1 } # Variance using Agresti method (based on non-zero differences) + # At boundary, recompute variance with corrected p_hat var_p <- var_concordance_paired(d) - se_p <- sqrt(var_p) + + # If variance is degenerate at boundary, use a fallback based on corrected p_hat + if (boundary_corrected && (is.na(var_p) || var_p <= 0)) { + # Use approximate variance based on (1 - p^2) / n structure + var_p <- (1 - p_hat^2) * (2 * n_nonzero + 1) / (6 * N_pairs^2) + } + + se_p <- sqrt(max(var_p, 0)) + n1 <- n_nonzero + n2 <- NULL } else { # === TWO INDEPENDENT SAMPLES === x <- na.omit(x) y <- na.omit(y) + n1 <- length(x) + n2 <- length(y) + # Compute placements and variance placements <- compute_placements(x - mu, y) p_hat <- placements$p_hat - n_pairs <- placements$n1 * placements$n2 + p_hat_original <- p_hat + N_pairs <- n1 * n2 - # Continuity correction for boundary cases (two-sample) - if (p_hat <= 0) { - p_hat <- 0.5 / n_pairs - boundary_corrected <- TRUE - } else if (p_hat >= 1) { - p_hat <- 1 - 0.5 / n_pairs + if (p_hat <= 0 || p_hat >= 1) { boundary_corrected <- TRUE + # Concordance count: C = p_hat * N_pairs (will be 0 or N_pairs at boundary) + C <- p_hat * N_pairs + # Haldane-type shrinkage correction + p_hat <- (C + 0.5) / (N_pairs + 1) + + # For two-sample, optionally fall back to score CI for better boundary behavior + if (use_score_fallback) { + tf <- wmw_tie_factor(x - mu, y) + score_ci_cstat <- score_ci_wmw(phi_hat = p_hat_original, tf = tf, + n1 = n1, n2 = n2, + conf.level = conf.level, correct = FALSE) + boundary_used_score_ci <- TRUE + } } r_hat <- 2 * p_hat - 1 - var_p <- var_concordance_twosample(placements) - se_p <- sqrt(var_p) + # Recompute variance with corrected p_hat + # At boundary, placement values are all identical, so need to use corrected p_hat + if (boundary_corrected) { + # At complete separation, the placement-based variance formula fails + # (all V_i and W_j are 0 or 1, leading to negative variance). + # Use the V_LAPH variance formula evaluated at the corrected p_hat. + tf <- wmw_tie_factor(x - mu, y) + var_p <- v_laph(p_hat, tf, n1, n2) + } else { + var_p <- var_concordance_twosample(placements) + } + + se_p <- sqrt(max(var_p, 0)) } # Safeguard for extreme values @@ -332,8 +745,14 @@ ses_compute_agresti <- function(x, y = NULL, paired = FALSE, mu = 0) { se_logodds = se_logodds, # Design info paired = paired, - # Boundary correction flag - boundary_corrected = boundary_corrected + n1 = n1, + n2 = n2, + # Boundary correction flags + boundary_corrected = boundary_corrected, + boundary_used_score_ci = boundary_used_score_ci, + score_ci_cstat = score_ci_cstat, + # Original uncorrected p_hat (for reference) + p_hat_original = p_hat_original ) } diff --git a/R/ses_calc.R b/R/ses_calc.R index 7a1ade7..f5acd12 100644 --- a/R/ses_calc.R +++ b/R/ses_calc.R @@ -25,11 +25,33 @@ #' or shift (for independent samples) is to be estimated (default = 0). #' @param se_method a character string specifying the method for computing standard errors and #' confidence intervals: -#' - "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation with +#' - "score": (default) Uses a score-type approach where confidence intervals are +#' constructed by test inversion (finding the values of the concordance +#' probability where the score statistic equals the critical value), then +#' transformed to the requested effect size scale. This method has +#' better small-sample coverage than the Wald-based methods and +#' produces confidence intervals that are coherent with the corresponding +#' rank-based test. Available for all designs. +#' For two-sample independent designs, uses the Fay-Malinovsky approach +#' based on the proportional odds model (see Fay and Malinovsky, 2018). +#' For paired/one-sample designs, uses a Wilson score approach based on +#' the independent-signs model for the signed-rank statistic, producing +#' p-values that match `wilcox.test(..., paired = TRUE, exact = FALSE)` +#' at the standard null of 0.5. +#' - "agresti": Uses the Agresti/Lehmann placement-based variance estimation with #' confidence intervals computed on the log-odds scale and back-transformed. This method -#' has better asymptotic properties and faster convergence to normality. +#' has better asymptotic properties and faster convergence to normality. Available for +#' all designs (one-sample, paired, and two-sample independent). +#' However, this method can produce degenerate intervals at the boundaries +#' (when all pairwise comparisons favor one group), +#' in which case a Haldane-type shrinkage correction is applied to enable interval construction. #' - "fisher": Uses the legacy Fisher z-transformation method for confidence intervals. #' This method is retained for backward compatibility. +#' @param correct logical; whether to apply a continuity correction to the +#' test statistic and confidence interval. When `se_method = "score"`, +#' setting `correct = TRUE` produces p-values that match +#' `wilcox.test(..., exact = FALSE, correct = TRUE)`. +#' Default is `FALSE`. Only used with `se_method = "score"`. #' @param output a character string specifying the output format: #' - "htest": (default) Returns an object of class "htest" compatible with standard R output. #' - "data.frame": Returns a data frame with effect size estimates and confidence intervals. @@ -74,7 +96,7 @@ #' #' ## Standard Error Methods #' -#' Two methods are available for computing standard errors and confidence intervals: +#' Three methods are available for computing standard errors and confidence intervals: #' #' - **Agresti method** (`se_method = "agresti"`): This method computes the variance of the #' concordance probability \eqn{\hat{p} = \Pr(X > Y)} using the Lehmann/Agresti placement-based @@ -101,28 +123,64 @@ #' requested effect size scale. This ensures that intervals respect the natural bounds of each #' measure (e.g., \eqn{[0, 1]} for cstat, \eqn{[-1, 1]} for rb). #' +#' - **Score method** (`se_method = "score"`): Uses a score-type approach where the variance +#' is evaluated at the candidate parameter value, not the estimate. Confidence intervals are +#' constructed via test inversion: finding the values of \eqn{\phi} (concordance probability) +#' where the score statistic equals the critical value. This method has better small-sample +#' coverage than Wald-type methods and guarantees CI/p-value coherence for equivalence testing. +#' +#' For **two-sample independent** designs, uses the Fay-Malinovsky V_LAPH variance function +#' from the proportional odds model. The reported SE is descriptive (from V_LAPH at +#' \eqn{\hat{\phi}}), and the CI comes from root-finding. +#' +#' For **paired/one-sample** designs, uses a Wilson score approach based on the independent +#' signs model. Under this model, each pair's sign is Bernoulli(\eqn{\pi}) independent of rank, +#' giving \eqn{T^+} known mean \eqn{\pi S} and variance \eqn{\pi(1-\pi)Q}, where +#' \eqn{S = N(N+1)/2} and \eqn{Q = \sum r_i^2}. The CI has a closed-form Wilson-score +#' solution (no root-finding needed). At \eqn{\pi_0 = 0.5}, the score test reproduces the +#' Wilcoxon signed-rank z exactly. +#' +#' The reported standard error is descriptive, but the confidence interval is **not** computed +#' as estimate ± z × SE. Instead, it comes from test inversion. +#' +#' When `correct = TRUE`, a continuity correction is applied that makes p-values match +#' `wilcox.test(..., exact = FALSE, correct = TRUE)`. +#' #' - **Fisher method** (`se_method = "fisher"`): This legacy method uses Fisher's z-transformation #' (arctanh) for the rank-biserial correlation. Confidence intervals for other effect sizes #' are obtained by simple transformation of the rank-biserial CI bounds. #' -#' ## Continuity Correction for Boundary Cases +#' ## Boundary Case Handling (Complete Separation) +#' +#' When there is complete separation between groups (i.e., all pairwise comparisons favor +#' one group), the concordance probability \eqn{\hat{p}} equals exactly 0 or 1. +#' This leads to undefined odds and log-odds, and a degenerate (zero) placement-based +#' variance. #' -#' When there is complete separation between groups (i.e., all observations in one group exceed all -#' observations in the other), the concordance probability \eqn{\hat{p}} equals exactly 0 or 1. -#' This leads to undefined odds (0 or \eqn{\infty}) and log-odds (\eqn{-\infty} or \eqn{\infty}). +#' For `se_method = "agresti"`, a Haldane-type shrinkage correction is applied: +#' \deqn{\tilde{p} = \frac{C + 0.5}{N_{\mathrm{pairs}} + 1}} +#' where \eqn{C} is the concordance count and \eqn{N_{\mathrm{pairs}}} is the total +#' number of pairwise comparisons (\eqn{n_1 n_2} for two-sample designs, or +#' \eqn{N(N+1)/2} for paired/one-sample designs where \eqn{N} is the number of +#' non-zero differences). This corresponds to the posterior mean under a Jeffreys +#' Beta(0.5, 0.5) prior and shrinks the estimate toward 0.5, with stronger shrinkage +#' for smaller samples. #' -#' In this case, a continuity correction is applied (for `se_method = "agresti"` only): -#' - **Two-sample**: \eqn{\hat{p}} is corrected to \eqn{0.5 / (n_1 \cdot n_2)} or -#' \eqn{1 - 0.5 / (n_1 \cdot n_2)}, where \eqn{n_1 \cdot n_2} is the total number of pairwise -#' comparisons. -#' - **Paired/one-sample**: \eqn{\hat{p}} is corrected to \eqn{0.5 / S} or \eqn{1 - 0.5 / S}, -#' where \eqn{S = N(N+1)/2} is the maximum possible Wilcoxon signed-rank statistic and \eqn{N} -#' is the number of non-zero differences. +#' The Agresti placement variance is then evaluated at the corrected estimate. A message +#' is printed when this correction is applied. For more reliable inference at boundaries, +#' consider `se_method = "score"` for score-type intervals that handle +#' boundaries naturally without correction. #' -#' A message is printed when this correction is applied. Point estimates and hypothesis tests -#' should be interpreted as approximate in these cases. For bootstrap inference with complete -#' separation, see [boot_ses_calc()], which will detect this condition and stop with an -#' informative error. +#' For `se_method = "score"`, no correction is needed. The score-type +#' CI is constructed via test inversion, where the variance function is +#' evaluated at candidate parameter values in the interior of (0, 1). When +#' \eqn{\hat{p} = 1}, the upper CI bound is trivially 1 and the lower bound is found +#' by the score inversion. No modification of the point estimate is required. +#' This applies to both two-sample (via root-finding) and paired/one-sample +#' (via the closed-form Wilson quadratic) designs. +#' +#' For two-sample designs using the Agresti method, a score-type CI is automatically +#' used as a fallback at boundaries for better interval coverage. #' #' ## Hypothesis Testing #' @@ -210,12 +268,23 @@ #' # Example 6: Using Fisher method for backward compatibility #' ses_calc(x = group1, y = group2, ses = "rb", se_method = "fisher") #' +#' # Example 7: Using score method for WMW-compatible CIs (two-sample only) +#' ses_calc(x = group1, y = group2, ses = "cstat", se_method = "score") +#' +#' # Example 8: Score method with continuity correction (matches wilcox.test) +#' ses_calc(x = group1, y = group2, ses = "cstat", se_method = "score", +#' correct = TRUE, alternative = "two.sided", null.value = 0.5) +#' #' @references #' Agresti, A. (1980). Generalized odds ratios for ordinal data. *Biometrics*, 36, 59-67. #' #' Bamber, D. (1975). The area above the ordinal dominance graph and the area below the receiver #' operating characteristic graph. *Journal of Mathematical Psychology*, 12, 387-415. #' +#' Fay, M.P. and Malinovsky, Y. (2018). Confidence Intervals of the Mann-Whitney Parameter +#' that are Compatible with the Wilcoxon-Mann-Whitney Test. *Statistics in Medicine*, +#' 37, 3991-4006. \doi{10.1002/sim.7890} +#' #' Kerby, D. S. (2014). The simple difference formula: An approach to teaching nonparametric #' correlation. *Comprehensive Psychology*, 3, 11-IT. #' @@ -229,12 +298,14 @@ #' @export ses_calc +# TODO: add xname and yname arguments to allow user-specified group labels #ses_calc <- setClass("ses_calc") ses_calc <- function(x, ..., paired = FALSE, ses = "rb", alpha = 0.05, - se_method = c("agresti", "fisher"), + se_method = c("score", "agresti", "fisher"), + correct = FALSE, output = c("htest", "data.frame"), null.value = NULL, alternative = c("none", "two.sided", "less", "greater", @@ -254,7 +325,8 @@ ses_calc.default = function(x, ses = c("rb","odds","logodds","cstat"), alpha = 0.05, mu = 0, - se_method = c("agresti", "fisher"), + se_method = c("score", "agresti", "fisher"), + correct = FALSE, output = c("htest", "data.frame"), null.value = NULL, alternative = c("none", "two.sided", "less", "greater", @@ -266,6 +338,18 @@ ses_calc.default = function(x, output = match.arg(output) alternative = match.arg(alternative) + if(!is.numeric(alpha) || alpha <=0 || alpha >=1){ + stop("alpha must be a numeric value between 0 and 1") + } + + # Determine design type + is_two_sample <- !is.null(y) && !paired + + # Continuity correction only used with score method + if (correct && se_method != "score") { + message("Continuity correction (correct = TRUE) is only used with se_method = 'score'. Ignoring.") + } + # Track whether user provided null.value (for messaging about log-odds transformation) null.value_original <- null.value @@ -310,12 +394,15 @@ ses_calc.default = function(x, if (!is.null(y)) { dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) + # Use simple generic names for default method since variable names + # may be expressions (e.g., 1:10, c(7:20, 200)) which look messy. + # Formula method will overwrite these with actual factor level names. + XNAME <- "X" + YNAME <- "Y" } else { dname <- deparse(substitute(x)) - } - - if(!is.numeric(alpha) || alpha <=0 || alpha >=1){ - stop("The alpha must be a numeric value between 0 and 1") + XNAME <- "X" + YNAME <- NULL } # Handle NA removal @@ -338,15 +425,14 @@ ses_calc.default = function(x, } # Compute point estimate using existing function - # Note: rbs_calc for paired/one-sample expects x and y swapped - # For one-sample: rbs() sets y=rep(0,n), paired=TRUE, then swaps to x=zeros, y=original - # For paired: we pass y as first arg, x as second (see rbs() lines 92-100) + # Note: rbs_calc for paired computes z = x - y - mu and uses signed ranks. + # We pass x, y in the natural order so that the estimate represents P(X - Y > 0). if (is.null(y)) { - # One-sample: match rbs() convention - zeros first, then data - r_rbs <- rbs_calc(x = rep(0, length(x)), y = x, mu = mu, paired = TRUE) + # One-sample: compare x to mu (zeros represent the reference) + r_rbs <- rbs_calc(x = x, y = rep(0, length(x)), mu = mu, paired = TRUE) } else if (paired) { - # Paired: match rbs() convention - swap x and y - r_rbs <- rbs_calc(x = y, y = x, mu = mu, paired = TRUE) + # Paired: natural order, P(X - Y > 0) + r_rbs <- rbs_calc(x = x, y = y, mu = mu, paired = TRUE) } else { # Two-sample: no swap r_rbs <- rbs_calc(x = x, y = y, mu = mu, paired = FALSE) @@ -359,36 +445,206 @@ ses_calc.default = function(x, # Compute SE and CI based on method if (se_method == "agresti") { - # New Agresti/Lehmann method - est_results <- ses_compute_agresti(x = x, y = y, paired = paired, mu = mu) + # Agresti/Lehmann method with Haldane boundary correction + est_results <- ses_compute_agresti(x = x, y = y, paired = paired, mu = mu, + use_score_fallback = TRUE, + conf.level = conf.level) if (is.null(est_results)) { stop("Unable to compute effect size - check that data has sufficient non-zero differences") } - # Message if continuity correction was applied + # Message if boundary correction was applied if (est_results$boundary_corrected) { - message( - "Complete separation detected (p = 0 or 1). ", - "A continuity correction of 0.5/(number of pairs) was applied. ", - "Point estimates and hypothesis tests are approximate." + msg <- paste0( + "Complete separation detected (all pairwise comparisons favor one group). ", + "A Haldane-type shrinkage correction was applied to enable confidence ", + "interval construction on the log-odds scale." ) + + # If two-sample and score CI fallback was used, note that + if (est_results$boundary_used_score_ci) { + msg <- paste0(msg, " Score-type CIs used for better boundary behavior.") + } else if (!paired && !is.null(y)) { + msg <- paste0(msg, " For more reliable inference at boundaries, consider ", + "se_method = 'score' for score-type intervals.") + } else { + msg <- paste0(msg, " For more reliable inference at boundaries, consider ", + "boot_ses_calc() for bootstrap-based p-values and intervals.") + } + + message(msg) } - ci_results <- ses_ci_logodds(est_results, conf.level = conf.level) + # If score CI fallback was used, use those CIs; otherwise use standard log-odds CIs + if (est_results$boundary_used_score_ci && !is.null(est_results$score_ci_cstat)) { + # Transform score CI bounds to all scales + ci_cstat <- est_results$score_ci_cstat + ci_rb <- 2 * ci_cstat - 1 + ci_odds <- ci_cstat / (1 - ci_cstat) + ci_logodds <- log(ci_cstat / (1 - ci_cstat)) + + ci_val <- switch(ses, + "rb" = ci_rb, + "cstat" = ci_cstat, + "odds" = ci_odds, + "logodds" = ci_logodds) + } else { + ci_results <- ses_ci_logodds(est_results, conf.level = conf.level) + + ci_val <- switch(ses, + "rb" = ci_results$ci_rb, + "cstat" = ci_results$ci_cstat, + "odds" = ci_results$ci_odds, + "logodds" = ci_results$ci_logodds) + } - # Extract results for requested effect size + # Extract SE for requested effect size se_val <- switch(ses, "rb" = est_results$se_rb, "cstat" = est_results$se_cstat, "odds" = est_results$se_odds, "logodds" = est_results$se_logodds) - ci_val <- switch(ses, - "rb" = ci_results$ci_rb, - "cstat" = ci_results$ci_cstat, - "odds" = ci_results$ci_odds, - "logodds" = ci_results$ci_logodds) + } else if (se_method == "score") { + + if (is_two_sample) { + # Fay-Malinovsky score-type method (two-sample) + + # Compute tie factor + tf <- wmw_tie_factor(x - mu, y) + + # Handle degenerate case: all values in both groups identical + if (tf == 0) { + warning("All values in both groups are identical. ", + "Effect size is undefined (phi = 0.5 with zero variance).") + se_val <- NA + ci_val <- c(0, 1) + # p_hat is already 0.5 from rbs_calc + } else { + # Compute CI on cstat scale via test inversion + ci_cstat <- score_ci_wmw(phi_hat = p_hat, tf = tf, n1 = n1, n2 = n2, + conf.level = conf.level, correct = correct) + + # Compute descriptive SE from V_LAPH evaluated at phi_hat + # Use boundary-safe phi for SE computation + p_hat_safe <- pmin(pmax(p_hat, 1e-10), 1 - 1e-10) + se_cstat <- sqrt(v_laph(p_hat_safe, tf, n1, n2)) + + # Delta method SEs for other scales (descriptive only; CIs come from + # transforming the cstat CI bounds, not from SE +/- z) + se_rb <- 2 * se_cstat + se_odds <- se_cstat / (1 - p_hat_safe)^2 + se_logodds <- se_cstat / (p_hat_safe * (1 - p_hat_safe)) + + # Transform CI bounds to all scales + ci_rb <- 2 * ci_cstat - 1 + ci_odds <- ci_cstat / (1 - ci_cstat) + ci_logodds <- log(ci_cstat / (1 - ci_cstat)) + + # Extract for requested scale + se_val <- switch(ses, + "rb" = se_rb, + "cstat" = se_cstat, + "odds" = se_odds, + "logodds" = se_logodds) + + ci_val <- switch(ses, + "rb" = ci_rb, + "cstat" = ci_cstat, + "odds" = ci_odds, + "logodds" = ci_logodds) + } + + # Create est_results for consistency (used in hypothesis testing) + est_results <- list( + cstat = p_hat, + rb = r_rbs, + odds = alpha_hat, + logodds = eta_hat, + se_cstat = if(exists("se_cstat")) se_cstat else NA, + se_rb = if(exists("se_rb")) se_rb else NA, + se_odds = if(exists("se_odds")) se_odds else NA, + se_logodds = if(exists("se_logodds")) se_logodds else NA, + paired = FALSE, + n1 = n1, + n2 = n2, + boundary_corrected = FALSE, + tf = tf + ) + + } else { + # Wilson score-type method (paired/one-sample) + + # Get paired rank information + # Use original x, y order so that d = x - y - mu and + # p_hat = P(X - Y > 0), matching the label convention. + if (is.null(y)) { + pri <- paired_rank_info(x, mu = mu) + } else { + pri <- paired_rank_info(x, y, mu = mu) + } + + n_eff <- pri$n_eff + S_paired <- pri$S + Q_paired <- pri$Q + p_hat_pri <- pri$p_hat + + # Handle degenerate case + if (n_eff < 1 || Q_paired == 0) { + warning("Insufficient non-zero differences for score-type inference.") + se_val <- NA + ci_val <- c(0, 1) + } else { + # Compute CI on cstat scale via Wilson-score inversion + ci_cstat <- score_ci_paired(p_hat = p_hat_pri, n_eff = n_eff, + Q = Q_paired, conf.level = conf.level, + correct = correct) + + # Compute descriptive SEs + se_list <- score_se_paired(p_hat_pri, n_eff, Q_paired) + se_cstat <- se_list$se_cstat + se_rb <- se_list$se_rb + se_odds <- se_list$se_odds + se_logodds <- se_list$se_logodds + + # Transform CI bounds to all scales + ci_rb <- 2 * ci_cstat - 1 + ci_odds <- ci_cstat / (1 - ci_cstat) + ci_logodds <- log(ci_cstat / (1 - ci_cstat)) + + # Extract for requested scale + se_val <- switch(ses, + "rb" = se_rb, + "cstat" = se_cstat, + "odds" = se_odds, + "logodds" = se_logodds) + + ci_val <- switch(ses, + "rb" = ci_rb, + "cstat" = ci_cstat, + "odds" = ci_odds, + "logodds" = ci_logodds) + } + + # Create est_results for consistency (used in hypothesis testing) + est_results <- list( + cstat = p_hat, + rb = r_rbs, + odds = alpha_hat, + logodds = eta_hat, + se_cstat = if(exists("se_cstat")) se_cstat else NA, + se_rb = if(exists("se_rb")) se_rb else NA, + se_odds = if(exists("se_odds")) se_odds else NA, + se_logodds = if(exists("se_logodds")) se_logodds else NA, + paired = TRUE, + n1 = n_eff, + n2 = NULL, + boundary_corrected = FALSE, + # Store paired rank info for hypothesis testing + paired_rank_info = pri + ) + } } else { # Legacy Fisher method @@ -406,20 +662,56 @@ ses_calc.default = function(x, "cstat" = ci_results_fisher$ci_cstat, "odds" = ci_results_fisher$ci_odds, "logodds" = ci_results_fisher$ci_logodds) + + # Create est_results for consistency + est_results <- list( + cstat = p_hat, + rb = r_rbs, + odds = alpha_hat, + logodds = eta_hat, + se_cstat = ci_results_fisher$se_cstat, + se_rb = ci_results_fisher$se_rb, + se_odds = ci_results_fisher$se_odds, + se_logodds = ci_results_fisher$se_logodds, + paired = paired || is.null(y), + boundary_corrected = FALSE + ) } # Get point estimate for requested effect size - est_val <- switch(ses, - "rb" = r_rbs, - "cstat" = p_hat, - "odds" = alpha_hat, - "logodds" = eta_hat) - - ses_name <- switch(ses, - "rb" = "Rank-Biserial Correlation", - "odds" = "WMW Odds", - "logodds" = "WMW Log-Odds", - "cstat" = "Concordance") + # For Agresti method with boundary correction, use the corrected estimates + if (se_method == "agresti" && est_results$boundary_corrected) { + est_val <- switch(ses, + "rb" = est_results$rb, + "cstat" = est_results$cstat, + "odds" = est_results$odds, + "logodds" = est_results$logodds) + } else { + est_val <- switch(ses, + "rb" = r_rbs, + "cstat" = p_hat, + "odds" = alpha_hat, + "logodds" = eta_hat) + } + + # Map ses type to scale for label construction -------- + ses_scale <- switch(ses, + "cstat" = "probability", + "rb" = "difference", + "logodds" = "logodds", + "odds" = "odds" + ) + + ses_name <- prob_notation_label(ses_scale, XNAME, YNAME, paired, + paired_style = "difference") + + # Human-readable name for method string -------- + method_name <- switch(ses, + "rb" = "Rank-Biserial Correlation", + "cstat" = "Concordance", + "odds" = "WMW Odds", + "logodds" = "WMW Log-Odds" + ) # Build output if (output == "data.frame") { @@ -430,7 +722,7 @@ ses_calc.default = function(x, upper.ci = ci_val[2], conf.level = conf.level, se_method = se_method, - row.names = ses_name + row.names = method_name ) return(effsize) @@ -439,14 +731,28 @@ ses_calc.default = function(x, # Method string: " " method_suffix <- if (alternative != "none") "test" else "estimate with CI" - method_desc <- paste0(sample_type, " ", ses_name, " ", method_suffix) + method_desc <- paste0(sample_type, " ", method_name, " ", method_suffix) # Note: SE/CI methodology details if (se_method == "agresti") { - note_text <- "SE: Agresti/Lehmann placement; CI: log-odds back-transform" + if (exists("est_results") && isTRUE(est_results$boundary_used_score_ci)) { + note_text <- "SE: Agresti/Lehmann placement (Haldane-corrected); CI: score-type test inversion (boundary fallback)" + } else { + note_text <- "SE: Agresti/Lehmann placement; CI: log-odds back-transform" + } if (alternative != "none") { note_text <- paste0(note_text, "; hypothesis test conducted on log-odds scale") } + } else if (se_method == "score") { + if (is_two_sample) { + note_text <- "SE: Fay-Malinovsky V_LAPH; CI: score-type test inversion" + } else { + note_text <- "SE: Wilson score variance; CI: Wilson score interval" + } + if (correct) note_text <- paste0(note_text, " with continuity correction") + if (alternative != "none") { + note_text <- paste0(note_text, "; score-type hypothesis test on cstat scale") + } } else { note_text <- "SE: Fisher z-transform" } @@ -585,6 +891,109 @@ ses_calc.default = function(x, rval$null.value <- null_val } + # Score method hypothesis testing + if (alternative != "none" && se_method == "score") { + + if (is_two_sample) { + # Two-sample: use Fay-Malinovsky score test + tf <- est_results$tf + + if (alternative %in% c("equivalence", "minimal.effect")) { + phi_low <- to_cstat(low_bound, ses) + phi_high <- to_cstat(high_bound, ses) + + res_low <- score_pvalue_wmw(p_hat, phi_low, tf, n1, n2, + alternative = "greater", correct = correct) + res_high <- score_pvalue_wmw(p_hat, phi_high, tf, n1, n2, + alternative = "less", correct = correct) + + if (alternative == "equivalence") { + p_val <- max(res_low$p.value, res_high$p.value) + z_stat <- if (abs(res_low$z.statistic) < abs(res_high$z.statistic)) { + res_low$z.statistic + } else { + res_high$z.statistic + } + } else { + p_val <- min(res_low$p.value, res_high$p.value) + z_stat <- if (abs(res_low$z.statistic) < abs(res_high$z.statistic)) { + res_low$z.statistic + } else { + res_high$z.statistic + } + } + + null_val <- c(low_bound, high_bound) + names(null_val) <- c("lower bound", "upper bound") + + } else { + phi_null <- to_cstat(null.value, ses) + + res <- score_pvalue_wmw(p_hat, phi_null, tf, n1, n2, + alternative = alternative, correct = correct) + + z_stat <- res$z.statistic + p_val <- res$p.value + + null_val <- null.value + names(null_val) <- ses_name + } + + } else { + # Paired/one-sample: use Wilson score test + pri <- est_results$paired_rank_info + p_hat_pri <- pri$p_hat + n_eff <- pri$n_eff + Q_paired <- pri$Q + + if (alternative %in% c("equivalence", "minimal.effect")) { + phi_low <- to_cstat(low_bound, ses) + phi_high <- to_cstat(high_bound, ses) + + res_low <- score_pvalue_paired(p_hat_pri, phi_low, n_eff, Q_paired, + alternative = "greater", correct = correct) + res_high <- score_pvalue_paired(p_hat_pri, phi_high, n_eff, Q_paired, + alternative = "less", correct = correct) + + if (alternative == "equivalence") { + p_val <- max(res_low$p.value, res_high$p.value) + z_stat <- if (abs(res_low$z.statistic) < abs(res_high$z.statistic)) { + res_low$z.statistic + } else { + res_high$z.statistic + } + } else { + p_val <- min(res_low$p.value, res_high$p.value) + z_stat <- if (abs(res_low$z.statistic) < abs(res_high$z.statistic)) { + res_low$z.statistic + } else { + res_high$z.statistic + } + } + + null_val <- c(low_bound, high_bound) + names(null_val) <- c("lower bound", "upper bound") + + } else { + phi_null <- to_cstat(null.value, ses) + + res <- score_pvalue_paired(p_hat_pri, phi_null, n_eff, Q_paired, + alternative = alternative, correct = correct) + + z_stat <- res$z.statistic + p_val <- res$p.value + + null_val <- null.value + names(null_val) <- ses_name + } + } + + names(z_stat) <- "z" + rval$statistic <- z_stat + rval$p.value <- p_val + rval$null.value <- null_val + } + class(rval) <- "htest" return(rval) } @@ -628,10 +1037,33 @@ ses_calc.formula = function(formula, DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("ses_calc", c(DATA, list(...))) + # Update data.name and relabel estimate with actual group names + if (inherits(y, "htest")) { + y$data.name <- DNAME + + # Reconstruct label with actual factor level names + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + dots <- list(...) + ses <- if (!is.null(dots$ses)) match.arg(dots$ses, + c("rb", "odds", "logodds", "cstat")) else "rb" + + ses_scale <- switch(ses, + "cstat" = "probability", + "rb" = "difference", + "logodds" = "logodds", + "odds" = "odds" + ) - # Update data.name for htest output + names(y$estimate) <- prob_notation_label(ses_scale, XNAME, YNAME, + paired = isTRUE(dots$paired), + paired_style = "difference") - if (inherits(y, "htest")) { + # Also update null.value names if they used ses_name + if (!is.null(y$null.value) && length(y$null.value) == 1) { + names(y$null.value) <- names(y$estimate) + } + } else if (is.data.frame(y)) { y$data.name <- DNAME } diff --git a/R/simple_htest.R b/R/simple_htest.R index b38d636..2ffd2de 100644 --- a/R/simple_htest.R +++ b/R/simple_htest.R @@ -99,6 +99,7 @@ #' @export simple_htest +# TODO: add xname and yname arguments to allow user-specified group labels #simple_htest <- setClass("simple_htest") simple_htest <- function(x, ..., paired = FALSE, @@ -138,7 +139,7 @@ simple_htest.default = function(x, when = "0.9.0", what = "simple_htest(test = 'brunner_munzel')", with = "brunner_munzel()", - details = "The Brunner-Munzel test has been removed from simple_htest(). Please use brunner_munzel() directly for full functionality including permutation tests and improved output labeling." + details = "The Brunner-Munzel test has been deprecated from simple_htest(). Please use brunner_munzel() directly for full functionality including permutation tests and improved output labeling." ) } @@ -152,6 +153,16 @@ simple_htest.default = function(x, } } + # Compute sample sizes for output + if (is.null(y)) { + sample_size <- c(n = sum(!is.na(x))) + } else if (paired) { + complete <- complete.cases(x, y) + sample_size <- c(n = sum(complete)) + } else { + sample_size <- c(nx = sum(!is.na(x)), ny = sum(!is.na(y))) + } + if(alternative %in% c("equivalence","minimal.effect")){ if(length(mu) == 1){ @@ -267,6 +278,7 @@ simple_htest.default = function(x, name_val = names(ci_test$null.value) rval$conf.int = ci_test$conf.int + rval$estimate = ci_test$estimate rval$alternative = alternative rval$null.value = c(lo_bound, hi_bound) names(rval$null.value) = rep(name_val,2) @@ -361,6 +373,7 @@ simple_htest.default = function(x, name_val = names(ci_test$null.value) rval$conf.int = ci_test$conf.int + rval$estimate = ci_test$estimate rval$alternative = alternative rval$null.value = c(lo_bound, hi_bound) names(rval$null.value) = rep(name_val,2) @@ -403,6 +416,43 @@ simple_htest.default = function(x, } + # Augment estimate labels and add mean difference for two-sample t-tests + XNAME <- "x" + YNAME <- if (!is.null(y)) "y" else NULL + if (test == "t.test") { + if (!is.null(y) && !paired) { + # Two-sample: relabel group means and append mean difference as third element + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = FALSE) + names(rval$estimate) <- est_labels + mdiff <- rval$estimate[1] - rval$estimate[2] + names(mdiff) <- paste0("mean difference (", XNAME, " - ", YNAME, ")") + rval$estimate <- c(rval$estimate, mdiff) + } else if (paired) { + # Paired: relabel to indicate differencing + names(rval$estimate) <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = TRUE) + } + # One-sample: relabel + if (is.null(y) && !paired) { + names(rval$estimate) <- ttest_estimate_label(type = "t", xname = XNAME, yname = NULL, paired = FALSE) + } + } + + if (test == "wilcox.test") { + if (is.null(y)) { + # One-sample + names(rval$estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = NULL, paired = FALSE) + } else if (paired) { + names(rval$estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = TRUE) + } else { + names(rval$estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = FALSE) + } + } + + # TODO: Consider updating null.value names to indicate direction + # (e.g., "difference in means (x - y)") for consistency with estimate labels + + rval$sample_size <- sample_size + return(rval) } @@ -420,7 +470,7 @@ simple_htest.formula = function(formula, || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -428,7 +478,7 @@ simple_htest.formula = function(formula, message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) @@ -445,6 +495,34 @@ simple_htest.formula = function(formula, DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("simple_htest", c(DATA, list(...))) y$data.name <- DNAME + + # Resolve actual group labels from factor levels + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + + # Determine which test was used + dots <- list(...) + test_arg <- if (!is.null(dots$test)) match.arg(dots$test, c("t.test", "wilcox.test", "brunner_munzel")) else "t.test" + is_paired <- isTRUE(dots$paired) + + if (test_arg == "t.test") { + est_labels <- ttest_estimate_label(type = "t", xname = XNAME, yname = YNAME, paired = is_paired) + if (!is_paired) { + # Two-sample: 3 elements (group means + difference) + diff_label <- paste0("mean difference (", quote_if_numeric(XNAME), " - ", quote_if_numeric(YNAME), ")") + names(y$estimate) <- c(est_labels, diff_label) + } else { + names(y$estimate) <- est_labels + } + } else if (test_arg == "wilcox.test") { + names(y$estimate) <- ttest_estimate_label(type = "wilcoxon", xname = XNAME, yname = YNAME, paired = is_paired) + } + + # Relabel sample_size names + if (!is.null(y$sample_size) && length(y$sample_size) == 2) { + names(y$sample_size) <- levels(g) + } + y } diff --git a/R/smd_calc.R b/R/smd_calc.R index 72f3fc9..fcfaa97 100644 --- a/R/smd_calc.R +++ b/R/smd_calc.R @@ -3,8 +3,7 @@ #' `r lifecycle::badge('stable')` #' #' Calculates standardized mean difference (SMD) effect sizes and their confidence intervals -#' from raw data. This function focuses solely on effect size estimation without performing -#' hypothesis tests. +#' from raw data, with optional hypothesis testing. #' #' @section Purpose: #' Use this function when: @@ -12,11 +11,47 @@ #' * You want confidence intervals for your effect size estimates #' * You need effect sizes for meta-analysis or reporting #' * You want to compare effect sizes across different studies or measures -#' * You don't need the hypothesis testing components of the TOST functions +#' * You want to test hypotheses about effect size magnitudes (e.g., equivalence testing) #' #' @inheritParams t_TOST #' @inheritParams boot_t_TOST #' @param ... further arguments to be passed to or from methods. +#' @param output a character string specifying the output format: +#' - "htest": (default) Returns an object of class "htest" compatible with standard R output. +#' - "data.frame": Returns a data frame for backward compatibility. +#' @param null.value a number or vector specifying the null hypothesis value(s) on the SMD scale: +#' - For standard alternatives: a single value (default = 0) +#' - For equivalence/minimal.effect: two values representing the lower and upper bounds +#' @param alternative a character string specifying the alternative hypothesis: +#' - "none": (default) No hypothesis test is performed; only effect size and CI are returned. +#' - "two.sided": Test whether SMD differs from null.value +#' - "less": Test whether SMD is less than null.value +#' - "greater": Test whether SMD is greater than null.value +#' - "equivalence": Test whether SMD is between specified bounds +#' - "minimal.effect": Test whether SMD is outside specified bounds +#' @param denom a character string specifying the denominator for standardization: +#' - "auto": (default) Uses the standard denominator based on design and other arguments +#' (glass, rm_correction, var.equal). +#' - "z": SD of differences (Cohen's d_z). Valid for paired and one-sample designs. +#' - "rm": Repeated-measures corrected (Cohen's d_rm). Valid for paired designs only. +#' - "pooled": Pooled SD (Cohen's d_s). Valid for independent samples only. +#' - "avg": Root-mean-square SD (Cohen's d_av). Valid for independent samples only. +#' - "glass1": First group's (x) SD (Glass's delta). Valid for paired and independent designs. +#' - "glass2": Second group's (y) SD (Glass's delta). Valid for paired and independent designs. +#' +#' When set to any value other than "auto", this overrides the glass, rm_correction, +#' and var.equal arguments. The bias_correction argument is not affected. +#' @param test_method a character string specifying the method for hypothesis testing: +#' - "z": Use z-statistic (normal distribution) +#' - "t": Use t-statistic with degrees of freedom from the SMD calculation +#' @param tr a numeric value specifying the proportion of observations to trim from each +#' tail when computing trimmed means and Winsorized variances (default = 0, no trimming). +#' Must be in the range \[0, 0.5). Common choices are 0.1 (10\% trimming) and 0.2 +#' (20\% trimming). When tr > 0, the effect size uses trimmed means for the numerator +#' and the rescaled Winsorized standard deviation for the denominator, following +#' Algina, Keselman, and Penfield (2005). The rescaling ensures the robust effect +#' size equals Cohen's delta when data are normally distributed. +#' Note: tr > 0 is not compatible with denom = "rm" or smd_ci = "goulet". #' #' @details #' This function calculates standardized mean differences (SMD) for various study designs: @@ -37,17 +72,50 @@ #' * "t": Uses the central t-distribution #' * "z": Uses the normal distribution #' -#' Note that unlike the t_TOST and related functions, smd_calc only calculates effect sizes and -#' their confidence intervals without performing hypothesis tests. +#' The `denom` parameter provides a direct way to select the standardization denominator. +#' When `denom` is not "auto", it takes precedence over the `glass`, `rm_correction`, and +#' `var.equal` arguments, which are overridden as needed. A message is emitted if any +#' explicitly provided arguments are overridden. The `bias_correction` argument is always +#' respected regardless of `denom`. +#' +#' When \code{tr > 0}, the function computes a robust standardized mean difference +#' using trimmed means and Winsorized variances. The trimmed mean removes a proportion +#' \code{tr} of observations from each tail before computing the mean. The Winsorized +#' variance replaces trimmed observations with the nearest remaining values before +#' computing the variance. A rescaling constant ensures the robust effect size equals +#' Cohen's delta under normality. This approach is recommended when distributions +#' are heavy-tailed or contain outliers, as the robust effect size better reflects +#' the separation between distributions than the standard Cohen's d (Algina et al., 2005). #' #' For detailed information on calculation methods, see `vignette("SMD_calcs")`. #' -#' @return A data frame containing the following information: -#' * estimate: The standardized mean difference estimate (Cohen's d, Hedges' g, or Glass's delta) -#' * SE: Standard error of the estimate -#' * lower.ci: Lower bound of the confidence interval -#' * upper.ci: Upper bound of the confidence interval -#' * conf.level: Confidence level (1-alpha) +#' @references +#' Algina, J., Keselman, H. J., & Penfield, R. D. (2005). An alternative to Cohen's +#' standardized mean difference effect size: A robust parameter and confidence interval +#' in the two independent groups case. \emph{Psychological Methods}, \emph{10}(3), 317-328. +#' +#' Yuen, K. K., & Dixon, W. J. (1973). The approximate behaviour and performance of +#' the two-sample trimmed t. \emph{Biometrika}, \emph{60}(2), 369-374. +#' +#' @return +#' If `output = "htest"` (default), returns a list with class `"htest"` containing: +#' - estimate: The SMD estimate (Cohen's d, Hedges' g, or Glass's delta) +#' - stderr: Standard error of the estimate +#' - conf.int: Confidence interval with conf.level attribute +#' - alternative: A character string describing the alternative hypothesis +#' - method: A character string indicating what type of test was performed +#' - data.name: A character string giving the name(s) of the data +#' - statistic: Test statistic (only if alternative != "none") +#' - parameter: Degrees of freedom (only if test_method = "t" and alternative != "none") +#' - p.value: P-value for the test (only if alternative != "none") +#' - null.value: The specified hypothesized value(s) (only if alternative != "none") +#' +#' If `output = "data.frame"`, returns a data frame containing: +#' - estimate: The SMD estimate +#' - SE: Standard error of the estimate +#' - lower.ci: Lower bound of the confidence interval +#' - upper.ci: Upper bound of the confidence interval +#' - conf.level: Confidence level (1-alpha) #' #' @examples #' # Example 1: Independent groups comparison (Cohen's d) @@ -71,10 +139,33 @@ #' # Example 4: Glass's delta (using only first group's SD) #' smd_calc(x = group1, y = group2, glass = "glass1") #' +#' # Example 5: Two-sided test against null of 0 +#' smd_calc(x = group1, y = group2, +#' alternative = "two.sided", null.value = 0) +#' +#' # Example 6: Equivalence test (TOST) +#' smd_calc(x = group1, y = group2, +#' alternative = "equivalence", null.value = c(-0.5, 0.5)) +#' +#' # Example 7: Using t-distribution for test +#' smd_calc(x = group1, y = group2, +#' alternative = "two.sided", null.value = 0, +#' test_method = "t", smd_ci = "t") +#' +#' # Example 8: Direct denominator selection +#' smd_calc(x = group1, y = group2, denom = "pooled") +#' smd_calc(x = group1, y = group2, denom = "avg") +#' smd_calc(x = before, y = after, paired = TRUE, denom = "rm") +#' smd_calc(x = group1, y = group2, denom = "glass1", bias_correction = TRUE) +#' +#' # Example 9: Legacy data.frame output +#' smd_calc(x = group1, y = group2, output = "data.frame") +#' #' @family effect sizes #' @name smd_calc #' @export smd_calc +# TODO: add xname and yname arguments to allow user-specified group labels #smd_calc <- setClass("smd_calc") smd_calc <- function(x, ..., paired = FALSE, @@ -83,12 +174,20 @@ smd_calc <- function(x, ..., bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - smd_ci = c("nct", "goulet", "t", "z")){ + denom = c("auto", "z", "rm", "pooled", "avg", + "glass1", "glass2"), + smd_ci = c("nct", "goulet", "t", "z"), + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", + "equivalence", "minimal.effect"), + test_method = c("z", "t"), + tr = 0){ UseMethod("smd_calc") } #' @rdname smd_calc -#' @importFrom stats sd cor na.omit setNames t.test terms nlm optim optimize +#' @importFrom stats sd cor na.omit setNames t.test terms nlm optim optimize pt pnorm #' @method smd_calc default #' @export @@ -102,13 +201,59 @@ smd_calc.default = function(x, bias_correction = TRUE, rm_correction = FALSE, glass = NULL, + denom = c("auto", "z", "rm", "pooled", "avg", + "glass1", "glass2"), smd_ci = c("nct", "goulet", "t", "z"), + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", + "equivalence", "minimal.effect"), + test_method = c("z", "t"), + tr = 0, ...) { + denom = match.arg(denom) + + # Capture explicit-pass status before modifying defaults + var.equal_explicit <- !missing(var.equal) + rm_correction_explicit <- !missing(rm_correction) + glass_explicit <- !missing(glass) + + if((denom == "auto" & (!is.null(glass))) || denom == "glass1" || denom == "glass2" ){ + if(bias_correction){ + origin_author_text = "bias-corrected Glass's" + } else{ + origin_author_text = "Glass's" + } + } else { + if(bias_correction){ + origin_author_text = "Hedges's" + } else{ + origin_author_text = "Cohen's" + } + } + if(is.null(glass)){ glass = "no" } + + + smd_ci = match.arg(smd_ci) + output = match.arg(output) + alternative = match.arg(alternative) + test_method = match.arg(test_method) + + # Validate tr + if (!is.numeric(tr) || length(tr) != 1 || tr < 0 || tr >= 0.5) { + stop("'tr' must be a single numeric value in [0, 0.5)") + } + + # tr > 0 with goulet CI + if (tr > 0 && smd_ci == "goulet") { + stop("The Goulet-Pelletier CI method (smd_ci = 'goulet') is not supported with trimming (tr > 0). ", + "Consider using smd_ci = 'nct' or smd_ci = 'z' instead.") + } if(bias_correction){ smd_type = 'g' @@ -124,30 +269,73 @@ smd_calc.default = function(x, sample_type = "Two Sample" } + # Resolve denom and remap arguments + # Pass glass as NULL when it was not explicitly provided by the user + resolved <- resolve_denom( + denom = denom, + sample_type = sample_type, + var.equal = var.equal, + rm_correction = rm_correction, + glass = if (glass_explicit) glass else NULL, + var.equal_explicit = var.equal_explicit, + rm_correction_explicit = rm_correction_explicit, + glass_explicit = glass_explicit + ) + + # Emit any override messages + for (msg in resolved$messages) message(msg) + + # Apply resolved values + var.equal <- resolved$var.equal + rm_correction <- resolved$rm_correction + glass <- resolved$glass + if(is.null(glass)){ + glass = "no" + } + if(glass == "glass1" || glass == "glass2"){ if(glass == "glass1"){ - denom = "glass1" + int_denom = "glass1" } if(glass == "glass2"){ - denom = "glass2" + int_denom = "glass2" } } else{ if(sample_type != "Two Sample" ){ if(rm_correction){ - denom = "rm" + int_denom = "rm" } else { - denom = "z" + int_denom = "z" } } else{ - denom = "d" + int_denom = "d" } } + # Derive denom_tag for estimate label subscript -------- + denom_tag <- if (int_denom == "d") { + if (var.equal) "s" else "av" + } else if (int_denom %in% c("z", "rm")) { + int_denom + } else if (int_denom == "glass1") { + "x" + } else if (int_denom == "glass2") { + "y" + } else { + NULL + } + if(!is.numeric(alpha) || alpha <=0 || alpha >=1){ stop("The alpha must be a numeric value between 0 and 1") } + # tr > 0 with rm denom + if (tr > 0 && (int_denom == "rm" || (denom == "auto" && rm_correction))) { + stop("The repeated measures denominator (denom = 'rm') is not currently supported with trimming (tr > 0). ", + "Consider using denom = 'z' for paired designs with trimming.") + } + if (!is.null(y)) { dname <- paste(deparse(substitute(x)), "and", deparse(substitute(y))) @@ -156,6 +344,30 @@ smd_calc.default = function(x, dname <- deparse(substitute(x)) } + # Handle equivalence/minimal.effect bounds + if (alternative %in% c("equivalence", "minimal.effect")) { + if (length(null.value) != 2) { + stop("For equivalence or minimal.effect testing, null.value must be a vector of two values") + } + low_bound <- min(null.value) + high_bound <- max(null.value) + conf.level <- 1 - alpha * 2 + } else { + if (length(null.value) > 1) { + warning("null.value has length > 1; only the first element will be used") + null.value <- null.value[1] + } + low_bound <- null.value + high_bound <- null.value + conf.level <- 1 - alpha + } + + # Warn if test_method and smd_ci mismatch + if (alternative != "none" && test_method != smd_ci && smd_ci %in% c("nct", "goulet", "t", "z")) { + warning("test_method ('", test_method, "') differs from smd_ci ('", smd_ci, + "'). Consider aligning these for consistency.") + } + if(paired == TRUE && !missing(y)){ i1 <- x i2 <- y @@ -168,10 +380,28 @@ smd_calc.default = function(x, n <- nrow(data) i1 <- data$i1 i2 <- data$i2 - m1 <- mean(i1) - m2 <- mean(i2) + mu - sd1 <- sd(i1) - sd2 <- sd(i2) + + # Validate trimming does not remove too many observations + if (tr > 0) { + h_check <- trim_h(n, tr) + if (h_check < 2) { + stop("Trimming proportion tr = ", tr, + " removes too many observations from a group of size ", n, + ". At least 2 observations must remain after trimming.") + } + } + + if (tr > 0) { + m1 <- mean(i1, trim = tr) + m2 <- mean(i2, trim = tr) + mu + sd1 <- sqrt(winvar(i1, tr = tr)) + sd2 <- sqrt(winvar(i2, tr = tr)) + } else { + m1 <- mean(i1) + m2 <- mean(i2) + mu + sd1 <- sd(i1) + sd2 <- sd(i2) + } r12 <- cor(i1, i2) # Calculate Cohens d @@ -183,9 +413,10 @@ smd_calc.default = function(x, sd2 = sd2, r12 = r12, type = smd_type, - denom = denom, + denom = int_denom, alpha = alpha/2, - smd_ci = smd_ci + smd_ci = smd_ci, + tr = tr ) } else if(!missing(y)){ @@ -194,10 +425,29 @@ smd_calc.default = function(x, y1 = na.omit(y) n1 = length(x1) n2 = length(y1) - m1 = mean(x1) - m2 = mean(y1) + mu - sd1 = sd(x1) - sd2 = sd(y1) + + # Validate trimming does not remove too many observations + if (tr > 0) { + min_group_n <- min(n1, n2) + h_check <- trim_h(min_group_n, tr) + if (h_check < 2) { + stop("Trimming proportion tr = ", tr, + " removes too many observations from a group of size ", min_group_n, + ". At least 2 observations must remain after trimming.") + } + } + + if (tr > 0) { + m1 = mean(x1, trim = tr) + m2 = mean(y1, trim = tr) + mu + sd1 = sqrt(winvar(x1, tr = tr)) + sd2 = sqrt(winvar(y1, tr = tr)) + } else { + m1 = mean(x1) + m2 = mean(y1) + mu + sd1 = sd(x1) + sd2 = sd(y1) + } cohen_res = d_est_ind( n1 = n1, @@ -209,16 +459,33 @@ smd_calc.default = function(x, type = smd_type, var.equal = var.equal, alpha = alpha/2, - denom = denom, - smd_ci = smd_ci + denom = int_denom, + smd_ci = smd_ci, + tr = tr ) } else { x1 = na.omit(x) n1 = length(x1) - m1 = mean(x1) + mu - sd1 = sd(x1) + + # Validate trimming does not remove too many observations + if (tr > 0) { + h_check <- trim_h(n1, tr) + if (h_check < 2) { + stop("Trimming proportion tr = ", tr, + " removes too many observations from a group of size ", n1, + ". At least 2 observations must remain after trimming.") + } + } + + if (tr > 0) { + m1 = mean(x1, trim = tr) + mu + sd1 = sqrt(winvar(x1, tr = tr)) + } else { + m1 = mean(x1) + mu + sd1 = sd(x1) + } cohen_res = d_est_one( n = n1, @@ -227,22 +494,152 @@ smd_calc.default = function(x, type = smd_type, testValue = 0, alpha = alpha/2, - smd_ci = smd_ci + smd_ci = smd_ci, + tr = tr + ) + + } + + # Legacy data.frame output + if (output == "data.frame") { + effsize = data.frame( + estimate = c(cohen_res$d), + SE = c(cohen_res$d_sigma), + lower.ci = c(cohen_res$dlow), + upper.ci = c( cohen_res$dhigh), + conf.level = c((1-alpha)), + row.names = c(cohen_res$smd_label) ) + return(effsize) + } + + # htest output + est_val <- cohen_res$d + se_val <- cohen_res$d_sigma + df <- cohen_res$d_df + + # Determine SMD label -------- + smd_type_letter <- if (bias_correction) "g" else "d" + trim_note <- if (tr > 0) paste0(", ", tr * 100, "% trimmed") else "" + smd_label <- paste0("SMD (", smd_type_letter, "[", denom_tag, "]", trim_note, ")") + # Construct method description with notation label + XNAME <- "x" + YNAME <- if (!is.null(y)) "y" else NULL + sd_label <- resolve_sd_label(denom, int_denom, + xname = XNAME, + yname = if (!is.null(y)) "y" else "x", + var.equal = var.equal) + notation <- smd_notation_label(xname = XNAME, yname = YNAME, denom_label = sd_label) + + # Merge notation into the SMD label: "SMD (g[av]=(x-y)/SD_avg)" + smd_method_label <- paste0("Standardized Mean Difference (SMD; ", origin_author_text, " ", smd_type_letter, "[", denom_tag, "]=", notation, trim_note, ")") + + #method_suffix <- if (alternative != "none") "test" else "estimate with CI" + # removed suffix to avoid redundancy with method description in htest output, which already indicates the test type and CI level + method_desc <- paste0(sample_type, " ", smd_method_label) + + # Set up estimate with name + estimate <- est_val + names(estimate) <- smd_label + + # Recalculate CI for equivalence (90% CI when alpha=0.05) + if (alternative %in% c("equivalence", "minimal.effect")) { + # Need to recalculate CI with conf.level = 1 - 2*alpha + if(paired == TRUE && !missing(y)){ + cohen_res_ci = d_est_pair( + n = n, m1 = m1, m2 = m2, sd1 = sd1, sd2 = sd2, r12 = r12, + type = smd_type, denom = int_denom, alpha = alpha, smd_ci = smd_ci, + tr = tr + ) + } else if(!missing(y)){ + cohen_res_ci = d_est_ind( + n1 = n1, n2 = n2, m1 = m1, m2 = m2, sd1 = sd1, sd2 = sd2, + type = smd_type, var.equal = var.equal, alpha = alpha, denom = int_denom, smd_ci = smd_ci, + tr = tr + ) + } else { + cohen_res_ci = d_est_one( + n = n1, mu = m1, sd = sd1, type = smd_type, testValue = 0, + alpha = alpha, smd_ci = smd_ci, + tr = tr + ) + } + conf.int <- c(cohen_res_ci$dlow, cohen_res_ci$dhigh) + } else { + conf.int <- c(cohen_res$dlow, cohen_res$dhigh) } + attr(conf.int, "conf.level") <- conf.level - effsize = data.frame( - estimate = c(cohen_res$d), - SE = c(cohen_res$d_sigma), - lower.ci = c(cohen_res$dlow), - upper.ci = c( cohen_res$dhigh), - conf.level = c((1-alpha)), - row.names = c(cohen_res$smd_label) + # Build basic htest structure + rval <- list( + estimate = estimate, + stderr = se_val, + conf.int = conf.int, + alternative = alternative, + method = method_desc, + data.name = dname ) + # Add hypothesis test components only if alternative != "none" + if (alternative != "none") { + if (alternative %in% c("equivalence", "minimal.effect")) { + # Two one-sided tests + stat_low <- (est_val - low_bound) / se_val + stat_high <- (est_val - high_bound) / se_val - return(effsize) + if (test_method == "t") { + p_low <- pt(stat_low, df = df, lower.tail = FALSE) + p_high <- pt(stat_high, df = df, lower.tail = TRUE) + } else { + p_low <- pnorm(stat_low, lower.tail = FALSE) + p_high <- pnorm(stat_high, lower.tail = TRUE) + } + + if (alternative == "equivalence") { + p_val <- max(p_low, p_high) + test_stat <- if (abs(stat_low) < abs(stat_high)) stat_low else stat_high + } else { # minimal.effect + p_val <- min(p_low, p_high) + test_stat <- if (abs(stat_low) < abs(stat_high)) stat_low else stat_high + } + + null_val <- c(low_bound, high_bound) + names(null_val) <- c("lower bound", "upper bound") + + } else { + # Standard alternatives + test_stat <- (est_val - null.value) / se_val + + if (test_method == "t") { + p_val <- switch(alternative, + "two.sided" = 2 * pt(-abs(test_stat), df = df), + "less" = pt(test_stat, df = df), + "greater" = pt(test_stat, df = df, lower.tail = FALSE)) + } else { + p_val <- switch(alternative, + "two.sided" = 2 * pnorm(-abs(test_stat)), + "less" = pnorm(test_stat), + "greater" = pnorm(test_stat, lower.tail = FALSE)) + } + + null_val <- null.value + names(null_val) <- "SMD" + } + + names(test_stat) <- test_method + rval$statistic <- test_stat + if (test_method == "t") { + df_named <- df + names(df_named) <- "df" + rval$parameter <- df_named + } + rval$p.value <- p_val + rval$null.value <- null_val + } + + class(rval) <- "htest" + return(rval) } @@ -259,7 +656,7 @@ smd_calc.formula = function(formula, || (length(formula) != 3L) || (length(attr(terms(formula[-2L]), "term.labels")) != 1L)) stop("'formula' missing or incorrect") - + # Check for paired argument in ... and warn user dots <- list(...) if("paired" %in% names(dots)){ @@ -267,7 +664,7 @@ smd_calc.formula = function(formula, message("Using 'paired = TRUE' with the formula interface is not recommended. Please ensure your data is sorted appropriately to make the correct paired comparison.") } } - + m <- match.call(expand.dots = FALSE) if(is.matrix(eval(m$data, parent.frame()))) m$data <- as.data.frame(data) @@ -283,8 +680,32 @@ smd_calc.formula = function(formula, stop("grouping factor must have exactly 2 levels") DATA <- setNames(split(mf[[response]], g), c("x", "y")) y <- do.call("smd_calc", c(DATA, list(...))) - #y$data.name <- DNAME + + # Update data.name and relabel notation in method string for htest output + if (inherits(y, "htest")) { + y$data.name <- DNAME + + # Replace generic "(x"/"(y" notation with actual group names + XNAME <- levels(g)[1] + YNAME <- levels(g)[2] + xq <- quote_if_numeric(XNAME) + yq <- quote_if_numeric(YNAME) + y$method <- gsub("=\\(x-y\\)", paste0("=(", xq, "-", yq, ")"), y$method) + y$method <- gsub("=\\(x\\)", paste0("=(", xq, ")"), y$method) + y$method <- gsub("/SD_x\\)", paste0("/SD_", xq, ")"), y$method) + y$method <- gsub("/SD_y\\)", paste0("/SD_", yq, ")"), y$method) + + # Replace generic group names in estimate label and method string + # (Glass bracket notation: [x] -> [A], [y] -> [B]) + est_name <- names(y$estimate) + est_name <- gsub("\\[x\\]", paste0("[", xq, "]"), est_name) + est_name <- gsub("\\[y\\]", paste0("[", yq, "]"), est_name) + names(y$estimate) <- est_name + + y$method <- gsub("\\[x\\]", paste0("[", xq, "]"), y$method) + y$method <- gsub("\\[y\\]", paste0("[", yq, "]"), y$method) + } + y } - diff --git a/R/trans_rank_prob.R b/R/trans_rank_prob.R new file mode 100644 index 0000000..730fd35 --- /dev/null +++ b/R/trans_rank_prob.R @@ -0,0 +1,219 @@ +#' @title Rescale a Probability-Scale Effect Size +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Transforms a probability-scale effect size (and, optionally, its standard +#' error, confidence interval, and null value) between four scales: +#' `"probability"`, `"difference"`, `"logodds"`, and `"odds"`. +#' +#' This function serves as both a standalone utility and the internal engine +#' for `brunner_munzel(scale = ...)`. +#' +#' @param estimate numeric; the point estimate to transform. +#' @param se numeric or `NULL`; standard error of `estimate`. +#' Transformed via the delta method. +#' @param ci numeric vector of length 2 or `NULL`; confidence interval +#' endpoints. +#' Because every scale conversion is monotonic, CI endpoints are transformed +#' directly (coverage is preserved without the delta method). +#' @param null numeric (scalar or vector) or `NULL`; the null-hypothesis +#' value(s) to transform (e.g., a single null, or two equivalence bounds). +#' @param from character; the scale `estimate` is currently on. +#' One of `"probability"`, `"difference"`, `"logodds"`, `"odds"`. +#' @param to character; the target scale. +#' One of `"probability"`, `"difference"`, `"logodds"`, `"odds"`. +#' +#' @details +#' The four scales and their relationship to a probability \eqn{p} are: +#' +#' | Scale | Domain | Formula | Null at stochastic equality | +#' |-------|--------|---------|-----------------------------| +#' | probability | \eqn{(0, 1)} | \eqn{p} | 0.5 | +#' | difference | \eqn{(-1, 1)} | \eqn{2p - 1} | 0 | +#' | logodds | \eqn{(-\infty, \infty)} | \eqn{\log[p / (1-p)]} | 0 | +#' | odds | \eqn{(0, \infty)} | \eqn{p / (1-p)} | 1 | +#' +#' All conversions are routed through the probability scale internally. +#' +#' **Standard errors** are transformed via the delta method: +#' +#' \deqn{\mathrm{SE}_{\mathrm{target}} = +#' \mathrm{SE}_{\mathrm{original}} \times +#' \left|\frac{dp}{dx}\right| \times +#' \left|\frac{dy}{dp}\right|} +#' +#' where \eqn{x} is the original scale and \eqn{y} is the target scale. +#' +#' **Confidence intervals** are transformed by applying the monotonic mapping +#' directly to each endpoint, which preserves coverage exactly. +#' +#' At the boundaries (\eqn{p = 0} or \eqn{p = 1}), transformations to the +#' logodds scale return \eqn{\pm\infty}, and the delta-method SE is infinite. +#' This is mathematically correct behaviour; no clamping or warning is applied. +#' +#' @return A list with components: +#' \describe{ +#' \item{estimate}{transformed point estimate} +#' \item{se}{transformed standard error (or `NULL`)} +#' \item{ci}{transformed CI endpoints (or `NULL`)} +#' \item{null}{transformed null value(s) (or `NULL`)} +#' \item{from}{the `from` scale (echoed back)} +#' \item{to}{the `to` scale (echoed back)} +#' } +#' +#' @examples +#' # Probability to difference (rank-biserial) +#' trans_rank_prob(0.7, se = 0.05, ci = c(0.6, 0.8), +#' null = 0.5, from = "probability", to = "difference") +#' +#' # Probability to odds +#' trans_rank_prob(0.7, from = "probability", to = "odds") +#' +#' # Round-trip: logodds -> probability -> logodds +#' lo <- trans_rank_prob(0.8473, from = "logodds", to = "probability") +#' trans_rank_prob(lo$estimate, from = "probability", to = "logodds") +#' +#' # Apply to brunner_munzel output +#' res <- brunner_munzel(mpg ~ am, data = mtcars) +#' trans_rank_prob(as.numeric(res$estimate), +#' se = res$stderr, +#' ci = as.numeric(res$conf.int), +#' null = as.numeric(res$null.value), +#' from = "probability", to = "logodds") +#' +#' @seealso [brunner_munzel()], [ses_calc()] +#' @family effect sizes +#' @importFrom stats dlogis +#' @export +trans_rank_prob <- function(estimate, + se = NULL, + ci = NULL, + null = NULL, + from = c("probability", "difference", + "logodds", "odds"), + to = c("probability", "difference", + "logodds", "odds")) { + + from <- match.arg(from) + to <- match.arg(to) + + # Identity: return early + if (from == to) { + return(list(estimate = estimate, se = se, ci = ci, + null = null, from = from, to = to)) + } + + # Step 1: Convert to probability scale + p <- to_probability(estimate, from) + p_ci <- if (!is.null(ci)) to_probability(ci, from) else NULL + p_null <- if (!is.null(null)) to_probability(null, from) else NULL + p_se <- if (!is.null(se)) se * abs(d_to_probability(estimate, from)) else NULL + + # Step 2: Convert from probability to target scale + est_out <- from_probability(p, to) + ci_out <- if (!is.null(p_ci)) from_probability(p_ci, to) else NULL + null_out <- if (!is.null(p_null)) from_probability(p_null, to) else NULL + se_out <- if (!is.null(p_se)) p_se * abs(d_from_probability(p, to)) else NULL + + list(estimate = est_out, se = se_out, ci = ci_out, + null = null_out, from = from, to = to) +} + +# Internal helpers -------- +# These are non-exported internal functions. + +# Transform a value on `scale` to the probability scale +to_probability <- function(x, scale) { + switch(scale, + "probability" = x, + "difference" = (x + 1) / 2, + "logodds" = plogis(x), + "odds" = x / (1 + x) + ) +} + +# Transform a value on the probability scale to `scale` +from_probability <- function(p, scale) { + switch(scale, + "probability" = p, + "difference" = 2 * p - 1, + "logodds" = qlogis(p), + "odds" = p / (1 - p) + ) +} + +# Derivative of to_probability(x, scale) w.r.t. x +# se_p = se_x * |d/dx to_probability(x)| +d_to_probability <- function(x, scale) { + switch(scale, + "probability" = 1, + "difference" = 0.5, + "logodds" = dlogis(x), + "odds" = 1 / (1 + x)^2 + ) +} + +# Derivative of from_probability(p, scale) w.r.t. p +# se_target = se_p * |d/dp from_probability(p)| +d_from_probability <- function(p, scale) { + switch(scale, + "probability" = 1, + "difference" = 2, + "logodds" = 1 / (p * (1 - p)), + "odds" = 1 / (1 - p)^2 + ) +} + +# Internal: Quote group names that look numeric -------- +# +# Wraps a name in single quotes if it parses as a number. +# Prevents ambiguity in estimate labels (e.g., factor level "0" vs the number 0). +# Used by prob_notation_label() and ttest_estimate_label(). +# +# @param nm character; the name to possibly quote +# @return character +# @noRd +quote_if_numeric <- function(nm) { + if (grepl("^-?\\d*\\.?\\d+$", nm)) paste0("'", nm, "'") else nm +} + +# Build probability-notation estimate labels -------- +# +# Constructs the probability-notation label for an estimate on a given scale. +# Used by brunner_munzel() and ses_calc() to produce consistent labels. +# +# @param scale character; one of "probability", "difference", "logodds", "odds" +# @param xname character; quoted name for the first group/variable +# @param yname character; quoted name for the second group/variable (or NULL for one-sample) +# @param paired logical; whether the comparison is paired +# @return character string label +prob_notation_label <- function(scale, xname, yname = NULL, paired = FALSE, + paired_style = c("direct", "difference")) { + paired_style <- match.arg(paired_style) + + xq <- quote_if_numeric(xname) + + if (is.null(yname)) { + # One-sample: compare against 0 + prob_label <- paste0("P(", xq, ">0) + .5*P(", xq, "=0)") + diff_label <- paste0("P(", xq, ">0) - P(", xq, "<0)") + } else if (paired && paired_style == "difference") { + # Paired with difference-score notation: P(X - Y>0) + yq <- quote_if_numeric(yname) + d_expr <- paste0(xq, " - ", yq) + prob_label <- paste0("P(", d_expr, ">0) + .5*P(", d_expr, "=0)") + diff_label <- paste0("P(", d_expr, ">0) - P(", d_expr, "<0)") + } else { + # Two-sample independent (or paired with direct notation): P(X>Y) + yq <- quote_if_numeric(yname) + prob_label <- paste0("P(", xq, ">", yq, ") + .5*P(", xq, "=", yq, ")") + diff_label <- paste0("P(", xq, ">", yq, ") - P(", xq, "<", yq, ")") + } + + switch(scale, + "probability" = prob_label, + "difference" = diff_label, + "logodds" = paste0("logodds(", prob_label, ")"), + "odds" = paste0("odds(", prob_label, ")") + ) +} diff --git a/R/wilcox_TOST.R b/R/wilcox_TOST.R index 2c97299..a7e8369 100644 --- a/R/wilcox_TOST.R +++ b/R/wilcox_TOST.R @@ -16,6 +16,13 @@ #' correlation. Options also include "cstat" for concordance probability, or #' "odds" for Wilcoxon-Mann-Whitney odds (otherwise known as Agresti's #' generalized odds ratio). Note that `ses` only determines which effect size is calculated and does not affect the equivalence bounds (`eqb`). +#' @param se_method a character string specifying the method for computing standard errors and +#' confidence intervals for the effect size: +#' - "score": (default) Uses a score-type approach with test-inversion CIs. For two-sample +#' designs, uses the Fay-Malinovsky approach. For paired/one-sample, uses a Wilson score +#' approach. Produces CIs coherent with the Wilcoxon-Mann-Whitney / signed-rank test. +#' - "agresti": Uses the Agresti/Lehmann placement-based variance estimation. +#' - "fisher": Uses the legacy Fisher z-transformation method. #' @details #' For details on the calculations in this function see `vignette("robustTOST")`. For details on the Wilcoxon-Mann-Whitney tests see [stats::wilcox.test]. #' @@ -62,7 +69,8 @@ wilcox_TOST <- function(x, ..., low_eqbound, high_eqbound, ses = "rb", - alpha = 0.05){ + alpha = 0.05, + se_method = c("score", "agresti", "fisher")){ UseMethod("wilcox_TOST") } @@ -82,9 +90,12 @@ wilcox_TOST.default = function(x, ses = c("rb","odds", "logodds", "cstat"), alpha = 0.05, mu = 0, + se_method = c("score", "agresti", "fisher"), ...) { ses = match.arg(ses) + se_method = match.arg(se_method) + if(is.null(y)){ sample_type = "One Sample" } else if(paired == TRUE) { @@ -169,7 +180,7 @@ wilcox_TOST.default = function(x, mu = mu, alpha = alpha * 2, ses = ses, - se_method = "fisher", + se_method = se_method, output = "data.frame" ) diff --git a/_pkgdown.yml b/_pkgdown.yml index 20eb844..764c049 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -24,7 +24,7 @@ reference: contents: - t_TOST - tsum_TOST - - extract_r_paired + - subtitle: "Correlations" desc: > @@ -35,18 +35,24 @@ reference: - corsum_test -- subtitle: "Robust" +- subtitle: "Robust tests of the mean" desc: > Functions that are robust alternatives to the t-test contents: - - wilcox_TOST - boot_t_TOST - log_TOST - boot_log_TOST - - brunner_munzel - perm_t_test - boot_t_test +- subtitle: "Robust tests of stochastic dominance" + desc: > + Functions that are robust alternatives to testing for means or mean difference using rank-based methods + contents: + - wilcox_TOST + - brunner_munzel + - hodges_lehmann + - subtitle: "ANOVA" desc: > Functions for ANOVAs @@ -66,12 +72,21 @@ reference: - TOSTt-methods - TOSTnp-methods +- subtitle: "Miscellaneous Helpers" + desc: > + Functions for helping with various tasks, usually for data preparation + contents: + - extract_r_paired + - rank_diff + - trans_rank_prob + - subtitle: "Hypothesis Test Helpers" desc: > Functions for simple hypothesis tests or aide in interpreting these simple tests contents: - htest-helpers - simple_htest + - plot_htest_est - title: "Standardized Effect Sizes" @@ -84,6 +99,7 @@ reference: - boot_smd_calc - ses_calc - boot_ses_calc + - boot_ses_test - rbs - np_ses diff --git a/junk/check_installed.R b/junk/check_installed.R new file mode 100644 index 0000000..c389b39 --- /dev/null +++ b/junk/check_installed.R @@ -0,0 +1,7 @@ +library(TOSTER) +data(sleep) +x <- sleep$extra[sleep$group == 2] +y <- sleep$extra[sleep$group == 1] +res <- suppressMessages(ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="agresti")) +cat("Installed TOSTER agresti paired cstat:", as.numeric(res$estimate), "\n") +cat("Label:", names(res$estimate), "\n") diff --git a/junk/debug_direction.R b/junk/debug_direction.R new file mode 100644 index 0000000..90a29f3 --- /dev/null +++ b/junk/debug_direction.R @@ -0,0 +1,40 @@ +devtools::load_all() +data(sleep) +x <- sleep$extra[sleep$group == 2] +y <- sleep$extra[sleep$group == 1] + +cat("=== Direct rbs_calc calls ===\n") +cat("rbs_calc(x=x, y=y, paired=TRUE):", rbs_calc(x=x, y=y, mu=0, paired=TRUE), "\n") +cat("rbs_calc(x=y, y=x, paired=TRUE):", rbs_calc(x=y, y=x, mu=0, paired=TRUE), "\n") + +cat("\n=== ses_calc paired, agresti ===\n") +res_agr <- suppressMessages(ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="agresti")) +cat("Agresti estimate:", as.numeric(res_agr$estimate), "\n") +cat("Agresti CI:", res_agr$conf.int, "\n") + +cat("\n=== ses_calc paired, score ===\n") +res_sc <- ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="score") +cat("Score estimate:", as.numeric(res_sc$estimate), "\n") +cat("Score CI:", res_sc$conf.int, "\n") + +cat("\n=== ses_calc two-sample, score ===\n") +res_2s <- ses_calc(x=x, y=y, paired=FALSE, ses="cstat", se_method="score") +cat("Two-sample estimate:", as.numeric(res_2s$estimate), "\n") +cat("Two-sample CI:", res_2s$conf.int, "\n") + +cat("\n=== paired_rank_info calls ===\n") +pri_xy <- paired_rank_info(x, y, mu=0) +cat("paired_rank_info(x, y): p_hat =", pri_xy$p_hat, "\n") +pri_yx <- paired_rank_info(y, x, mu=0) +cat("paired_rank_info(y, x): p_hat =", pri_yx$p_hat, "\n") + +cat("\n=== What ses_calc.default actually does ===\n") +# Line 432-433: rbs_calc(x = y, y = x, mu = mu, paired = TRUE) +r_via_swap <- rbs_calc(x=y, y=x, mu=0, paired=TRUE) +cat("rb via swap (rbs_calc(y,x)):", r_via_swap, "\n") +cat("p_hat via swap:", rb_to_cstat(r_via_swap), "\n") + +# Without swap +r_no_swap <- rbs_calc(x=x, y=y, mu=0, paired=TRUE) +cat("rb no swap (rbs_calc(x,y)):", r_no_swap, "\n") +cat("p_hat no swap:", rb_to_cstat(r_no_swap), "\n") diff --git a/junk/debug_direction2.R b/junk/debug_direction2.R new file mode 100644 index 0000000..0a12fe2 --- /dev/null +++ b/junk/debug_direction2.R @@ -0,0 +1,43 @@ +devtools::load_all() +data(sleep) +x <- sleep$extra[sleep$group == 2] +y <- sleep$extra[sleep$group == 1] + +cat("=== Two-sample score ===\n") +res_2s <- ses_calc(x=x, y=y, paired=FALSE, ses="cstat", se_method="score") +cat("Estimate:", as.numeric(res_2s$estimate), "\n") +cat("CI:", res_2s$conf.int, "\n\n") + +cat("=== Paired score ===\n") +res_ps <- ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="score") +cat("Estimate:", as.numeric(res_ps$estimate), "\n") +cat("CI:", res_ps$conf.int, "\n") +cat("Label:", names(res_ps$estimate), "\n\n") + +cat("=== Paired agresti (for comparison) ===\n") +res_pa <- suppressMessages(ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="agresti")) +cat("Estimate:", as.numeric(res_pa$estimate), "\n") +cat("CI:", res_pa$conf.int, "\n\n") + +cat("=== Paired score, rb scale ===\n") +res_rb <- ses_calc(x=x, y=y, paired=TRUE, ses="rb", se_method="score") +cat("Estimate:", as.numeric(res_rb$estimate), "\n") +cat("CI:", res_rb$conf.int, "\n\n") + +cat("=== Paired score p-value vs wilcox.test ===\n") +wt <- wilcox.test(x, y, paired=TRUE, exact=FALSE, correct=FALSE) +res_p <- ses_calc(x=x, y=y, paired=TRUE, ses="cstat", se_method="score", + alternative="two.sided", null.value=0.5, correct=FALSE) +cat("wilcox.test p:", wt$p.value, "\n") +cat("ses_calc p:", res_p$p.value, "\n") +cat("Match:", all.equal(res_p$p.value, wt$p.value, tolerance=1e-6), "\n\n") + +cat("=== Simple non-boundary data ===\n") +set.seed(42) +x2 <- rnorm(20, mean=0.5) +y2 <- rnorm(20) +res_s <- ses_calc(x=x2, y=y2, paired=TRUE, ses="cstat", se_method="score") +res_a <- ses_calc(x=x2, y=y2, paired=TRUE, ses="cstat", se_method="agresti") +cat("Score estimate:", as.numeric(res_s$estimate), "\n") +cat("Agresti estimate:", as.numeric(res_a$estimate), "\n") +cat("Estimates same direction:", sign(as.numeric(res_s$estimate) - 0.5) == sign(as.numeric(res_a$estimate) - 0.5), "\n") diff --git a/junk/mess/compare_hl_vs_wmw.R b/junk/mess/compare_hl_vs_wmw.R new file mode 100644 index 0000000..7a9db08 --- /dev/null +++ b/junk/mess/compare_hl_vs_wmw.R @@ -0,0 +1,487 @@ +# Comparison: hodges_lehmann() vs simple_htest(test = "wilcox.test") +# for equivalence testing +# +# Purpose: Both functions perform nonparametric location tests related to +# the Wilcoxon-Mann-Whitney framework. This script tests whether they are +# assessing the same underlying hypothesis but with different methods. +# +# Key relationships: +# - wilcox.test estimates the Hodges-Lehmann estimator as its location shift +# - hodges_lehmann uses permutation/asymptotic inference on the HL estimator +# - simple_htest wraps wilcox.test with TOST extensions +# - Under H0, both should target the same location parameter +# +# Questions to answer: +# 1. Do the point estimates (HL estimator) agree? +# 2. Do the confidence intervals agree? +# 3. Do the p-values agree for standard alternatives? +# 4. Do the TOST (equivalence) results agree? +# 5. Where and why do they diverge? + +library(TOSTER) + +cat("=======================================================================\n") +cat("COMPARISON: hodges_lehmann() vs simple_htest(wilcox.test)\n") +cat("=======================================================================\n\n") + +# ============================================================================= +# SECTION 1: Two-sample independent test +# ============================================================================= +cat("=== SECTION 1: TWO-SAMPLE INDEPENDENT TEST ===\n\n") + +set.seed(2024) +x <- rnorm(20, mean = 0, sd = 1) +y <- rnorm(20, mean = 0.5, sd = 1.2) + +cat("Group x: n =", length(x), ", mean =", round(mean(x), 4), + ", median =", round(median(x), 4), "\n") +cat("Group y: n =", length(y), ", mean =", round(mean(y), 4), + ", median =", round(median(y), 4), "\n\n") + +# --- Two-sided test --- +cat("--- Two-sided test (H0: shift = 0) ---\n\n") + +hl_2s <- hodges_lehmann(x, y, alternative = "two.sided", mu = 0) +sh_2s <- simple_htest(x, y, test = "wilcox.test", alternative = "two.sided", mu = 0) +wt_2s <- wilcox.test(x, y, alternative = "two.sided", mu = 0, conf.int = TRUE) + +cat("Point estimates (Hodges-Lehmann):\n") +cat(" hodges_lehmann: ", round(hl_2s$estimate, 6), "\n") +cat(" simple_htest: ", round(sh_2s$estimate, 6), "\n") +cat(" wilcox.test: ", round(wt_2s$estimate, 6), "\n\n") + +cat("Confidence intervals:\n") +cat(" hodges_lehmann: [", round(hl_2s$conf.int[1], 6), ",", + round(hl_2s$conf.int[2], 6), "] (asymptotic)\n") +cat(" simple_htest: [", round(sh_2s$conf.int[1], 6), ",", + round(sh_2s$conf.int[2], 6), "]\n") +cat(" wilcox.test: [", round(wt_2s$conf.int[1], 6), ",", + round(wt_2s$conf.int[2], 6), "]\n\n") + +cat("P-values:\n") +cat(" hodges_lehmann: ", round(hl_2s$p.value, 6), "(asymptotic)\n") +cat(" simple_htest: ", round(sh_2s$p.value, 6), "\n") +cat(" wilcox.test: ", round(wt_2s$p.value, 6), "\n\n") + +# --- With permutation --- +cat("--- Two-sided test (with permutation, R = 5000) ---\n\n") + +set.seed(42) +hl_2s_perm <- hodges_lehmann(x, y, alternative = "two.sided", mu = 0, R = 5000) + +cat("P-values:\n") +cat(" hodges_lehmann (perm): ", round(hl_2s_perm$p.value, 6), "\n") +cat(" hodges_lehmann (asym): ", round(hl_2s$p.value, 6), "\n") +cat(" simple_htest (wilcox): ", round(sh_2s$p.value, 6), "\n\n") + +cat("Confidence intervals:\n") +cat(" hodges_lehmann (perm): [", round(hl_2s_perm$conf.int[1], 6), ",", + round(hl_2s_perm$conf.int[2], 6), "]\n") +cat(" hodges_lehmann (asym): [", round(hl_2s$conf.int[1], 6), ",", + round(hl_2s$conf.int[2], 6), "]\n") +cat(" simple_htest (wilcox): [", round(sh_2s$conf.int[1], 6), ",", + round(sh_2s$conf.int[2], 6), "]\n\n") + +# ============================================================================= +# SECTION 2: Equivalence test (the main comparison) +# ============================================================================= +cat("=== SECTION 2: EQUIVALENCE TESTING (TOST) ===\n\n") + +eqbound <- 1 # equivalence bound of +/- 1 + +cat("Equivalence bounds: [", -eqbound, ",", eqbound, "]\n\n") + +# --- Equivalence --- +hl_eq <- hodges_lehmann(x, y, alternative = "equivalence", mu = eqbound) +sh_eq <- simple_htest(x, y, test = "wilcox.test", + alternative = "equivalence", mu = eqbound) + +cat("--- Equivalence test results ---\n\n") + +cat("Point estimates:\n") +cat(" hodges_lehmann: ", round(hl_eq$estimate, 6), "\n") +cat(" simple_htest: ", round(sh_eq$estimate, 6), "\n\n") + +cat("Null values:\n") +cat(" hodges_lehmann: ", hl_eq$null.value, "\n") +cat(" simple_htest: ", sh_eq$null.value, "\n\n") + +cat("TOST p-values:\n") +cat(" hodges_lehmann: ", round(hl_eq$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_eq$p.value, 6), "\n\n") + +cat("Confidence intervals (1-2*alpha = 90%):\n") +cat(" hodges_lehmann: [", round(hl_eq$conf.int[1], 6), ",", + round(hl_eq$conf.int[2], 6), "]\n") +cat(" simple_htest: [", round(sh_eq$conf.int[1], 6), ",", + round(sh_eq$conf.int[2], 6), "]\n\n") + +# --- With permutation --- +cat("--- Equivalence test with permutation (R = 5000) ---\n\n") + +set.seed(42) +hl_eq_perm <- hodges_lehmann(x, y, alternative = "equivalence", + mu = eqbound, R = 5000) + +cat("TOST p-values:\n") +cat(" hodges_lehmann (perm): ", round(hl_eq_perm$p.value, 6), "\n") +cat(" hodges_lehmann (asym): ", round(hl_eq$p.value, 6), "\n") +cat(" simple_htest (wilcox): ", round(sh_eq$p.value, 6), "\n\n") + +cat("Confidence intervals (90%):\n") +cat(" hodges_lehmann (perm): [", round(hl_eq_perm$conf.int[1], 6), ",", + round(hl_eq_perm$conf.int[2], 6), "]\n") +cat(" hodges_lehmann (asym): [", round(hl_eq$conf.int[1], 6), ",", + round(hl_eq$conf.int[2], 6), "]\n") +cat(" simple_htest (wilcox): [", round(sh_eq$conf.int[1], 6), ",", + round(sh_eq$conf.int[2], 6), "]\n\n") + +# ============================================================================= +# SECTION 3: Minimal effect test +# ============================================================================= +cat("=== SECTION 3: MINIMAL EFFECT TESTING ===\n\n") + +hl_met <- hodges_lehmann(x, y, alternative = "minimal.effect", mu = eqbound) +sh_met <- simple_htest(x, y, test = "wilcox.test", + alternative = "minimal.effect", mu = eqbound) + +cat("MET p-values:\n") +cat(" hodges_lehmann: ", round(hl_met$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_met$p.value, 6), "\n\n") + +cat("Confidence intervals (90%):\n") +cat(" hodges_lehmann: [", round(hl_met$conf.int[1], 6), ",", + round(hl_met$conf.int[2], 6), "]\n") +cat(" simple_htest: [", round(sh_met$conf.int[1], 6), ",", + round(sh_met$conf.int[2], 6), "]\n\n") + +# ============================================================================= +# SECTION 4: One-sided tests +# ============================================================================= +cat("=== SECTION 4: ONE-SIDED TESTS ===\n\n") + +for (alt in c("less", "greater")) { + hl_os <- hodges_lehmann(x, y, alternative = alt, mu = 0) + sh_os <- simple_htest(x, y, test = "wilcox.test", alternative = alt, mu = 0) + + cat("Alternative:", alt, "\n") + cat(" hodges_lehmann p-value: ", round(hl_os$p.value, 6), "\n") + cat(" simple_htest p-value: ", round(sh_os$p.value, 6), "\n") + cat(" hodges_lehmann CI: [", round(hl_os$conf.int[1], 6), ",", + round(hl_os$conf.int[2], 6), "]\n") + cat(" simple_htest CI: [", round(sh_os$conf.int[1], 6), ",", + round(sh_os$conf.int[2], 6), "]\n\n") +} + +# ============================================================================= +# SECTION 5: Paired samples +# ============================================================================= +cat("=== SECTION 5: PAIRED SAMPLES ===\n\n") + +set.seed(2024) +before <- rnorm(15, mean = 50, sd = 10) +after <- before + rnorm(15, mean = 2, sd = 5) + +cat("Paired data: n =", length(before), "pairs\n") +cat("Mean difference:", round(mean(after - before), 4), "\n\n") + +# --- Two-sided --- +hl_p <- hodges_lehmann(before, after, paired = TRUE, + alternative = "two.sided", mu = 0) +sh_p <- simple_htest(before, after, paired = TRUE, + test = "wilcox.test", alternative = "two.sided", mu = 0) +wt_p <- wilcox.test(before, after, paired = TRUE, + alternative = "two.sided", mu = 0, conf.int = TRUE) + +cat("--- Paired two-sided ---\n") +cat("Point estimates:\n") +cat(" hodges_lehmann: ", round(hl_p$estimate, 6), "\n") +cat(" simple_htest: ", round(sh_p$estimate, 6), "\n") +cat(" wilcox.test: ", round(wt_p$estimate, 6), "\n\n") + +cat("P-values:\n") +cat(" hodges_lehmann: ", round(hl_p$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_p$p.value, 6), "\n") +cat(" wilcox.test: ", round(wt_p$p.value, 6), "\n\n") + +cat("Confidence intervals:\n") +cat(" hodges_lehmann: [", round(hl_p$conf.int[1], 6), ",", + round(hl_p$conf.int[2], 6), "] (asymptotic)\n") +cat(" simple_htest: [", round(sh_p$conf.int[1], 6), ",", + round(sh_p$conf.int[2], 6), "]\n") +cat(" wilcox.test: [", round(wt_p$conf.int[1], 6), ",", + round(wt_p$conf.int[2], 6), "]\n\n") + +# --- Paired equivalence --- +cat("--- Paired equivalence (bounds = +/- 5) ---\n") +eqbound_paired <- 5 + +hl_peq <- hodges_lehmann(before, after, paired = TRUE, + alternative = "equivalence", mu = eqbound_paired) +sh_peq <- simple_htest(before, after, paired = TRUE, + test = "wilcox.test", + alternative = "equivalence", mu = eqbound_paired) + +cat("TOST p-values:\n") +cat(" hodges_lehmann: ", round(hl_peq$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_peq$p.value, 6), "\n\n") + +cat("Confidence intervals (90%):\n") +cat(" hodges_lehmann: [", round(hl_peq$conf.int[1], 6), ",", + round(hl_peq$conf.int[2], 6), "]\n") +cat(" simple_htest: [", round(sh_peq$conf.int[1], 6), ",", + round(sh_peq$conf.int[2], 6), "]\n\n") + +# ============================================================================= +# SECTION 6: One-sample test +# ============================================================================= +cat("=== SECTION 6: ONE-SAMPLE TEST ===\n\n") + +set.seed(2024) +z <- rnorm(25, mean = 0.3, sd = 1) + +cat("Data: n =", length(z), ", mean =", round(mean(z), 4), + ", median =", round(median(z), 4), "\n\n") + +# --- Two-sided --- +hl_1s <- hodges_lehmann(z, alternative = "two.sided", mu = 0) +sh_1s <- simple_htest(z, test = "wilcox.test", alternative = "two.sided", mu = 0) +wt_1s <- wilcox.test(z, alternative = "two.sided", mu = 0, conf.int = TRUE) + +cat("--- One-sample two-sided ---\n") +cat("Point estimates (pseudomedian):\n") +cat(" hodges_lehmann: ", round(hl_1s$estimate, 6), "\n") +cat(" simple_htest: ", round(sh_1s$estimate, 6), "\n") +cat(" wilcox.test: ", round(wt_1s$estimate, 6), "\n\n") + +cat("P-values:\n") +cat(" hodges_lehmann: ", round(hl_1s$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_1s$p.value, 6), "\n") +cat(" wilcox.test: ", round(wt_1s$p.value, 6), "\n\n") + +cat("Confidence intervals:\n") +cat(" hodges_lehmann: [", round(hl_1s$conf.int[1], 6), ",", + round(hl_1s$conf.int[2], 6), "] (asymptotic)\n") +cat(" simple_htest: [", round(sh_1s$conf.int[1], 6), ",", + round(sh_1s$conf.int[2], 6), "]\n") +cat(" wilcox.test: [", round(wt_1s$conf.int[1], 6), ",", + round(wt_1s$conf.int[2], 6), "]\n\n") + +# --- One-sample equivalence --- +cat("--- One-sample equivalence (bounds = +/- 0.5) ---\n") +eqbound_1s <- 0.5 + +hl_1eq <- hodges_lehmann(z, alternative = "equivalence", mu = eqbound_1s) +sh_1eq <- simple_htest(z, test = "wilcox.test", + alternative = "equivalence", mu = eqbound_1s) + +cat("TOST p-values:\n") +cat(" hodges_lehmann: ", round(hl_1eq$p.value, 6), "\n") +cat(" simple_htest: ", round(sh_1eq$p.value, 6), "\n\n") + +cat("Confidence intervals (90%):\n") +cat(" hodges_lehmann: [", round(hl_1eq$conf.int[1], 6), ",", + round(hl_1eq$conf.int[2], 6), "]\n") +cat(" simple_htest: [", round(sh_1eq$conf.int[1], 6), ",", + round(sh_1eq$conf.int[2], 6), "]\n\n") + +# ============================================================================= +# SECTION 7: Systematic comparison across sample sizes +# ============================================================================= +cat("=== SECTION 7: SYSTEMATIC COMPARISON (varying n) ===\n\n") + +cat("Comparing equivalence test p-values and CIs across sample sizes\n") +cat("Equivalence bounds: +/- 0.8\n\n") + +ns <- c(10, 20, 30, 50, 100) +eqb_sys <- 0.8 + +results <- data.frame( + n = integer(), + hl_asym_p = numeric(), + sh_wilcox_p = numeric(), + p_diff = numeric(), + hl_estimate = numeric(), + sh_estimate = numeric(), + est_diff = numeric(), + stringsAsFactors = FALSE +) + +set.seed(2024) +for (n in ns) { + x_sim <- rnorm(n, mean = 0, sd = 1) + y_sim <- rnorm(n, mean = 0.3, sd = 1) + + hl_sim <- hodges_lehmann(x_sim, y_sim, + alternative = "equivalence", mu = eqb_sys) + sh_sim <- simple_htest(x_sim, y_sim, test = "wilcox.test", + alternative = "equivalence", mu = eqb_sys) + + results <- rbind(results, data.frame( + n = n, + hl_asym_p = hl_sim$p.value, + sh_wilcox_p = sh_sim$p.value, + p_diff = abs(hl_sim$p.value - sh_sim$p.value), + hl_estimate = hl_sim$estimate, + sh_estimate = sh_sim$estimate, + est_diff = abs(hl_sim$estimate - sh_sim$estimate) + )) +} + +cat(" n | HL(asym) p | WMW p | |p diff| | HL est | WMW est | |est diff|\n") +cat("------+------------+------------+-----------+---------+---------+----------\n") +for (i in seq_len(nrow(results))) { + cat(sprintf(" %-4d| %-10.6f | %-10.6f | %-9.6f | %-7.4f | %-7.4f | %-8.6f\n", + results$n[i], + results$hl_asym_p[i], + results$sh_wilcox_p[i], + results$p_diff[i], + results$hl_estimate[i], + results$sh_estimate[i], + results$est_diff[i])) +} + +cat("\n") + +# ============================================================================= +# SECTION 8: Test under null (both samples from same distribution) +# ============================================================================= +cat("=== SECTION 8: UNDER THE NULL (same distribution) ===\n\n") + +set.seed(999) +x_null <- rnorm(30) +y_null <- rnorm(30) + +eqb_null <- 0.5 + +hl_null_eq <- hodges_lehmann(x_null, y_null, + alternative = "equivalence", mu = eqb_null) +sh_null_eq <- simple_htest(x_null, y_null, test = "wilcox.test", + alternative = "equivalence", mu = eqb_null) + +cat("Both groups: n = 30, drawn from N(0,1)\n") +cat("Equivalence bounds: +/-", eqb_null, "\n\n") + +cat("Equivalence test:\n") +cat(" hodges_lehmann p: ", round(hl_null_eq$p.value, 6), "\n") +cat(" simple_htest p: ", round(sh_null_eq$p.value, 6), "\n\n") + +cat("Two-sided test:\n") +hl_null_2s <- hodges_lehmann(x_null, y_null, alternative = "two.sided") +sh_null_2s <- simple_htest(x_null, y_null, test = "wilcox.test", + alternative = "two.sided") +cat(" hodges_lehmann p: ", round(hl_null_2s$p.value, 6), "\n") +cat(" simple_htest p: ", round(sh_null_2s$p.value, 6), "\n\n") + +# ============================================================================= +# SECTION 9: Non-normal data (where robustness matters) +# ============================================================================= +cat("=== SECTION 9: NON-NORMAL DATA (contaminated normal) ===\n\n") + +set.seed(2024) +# Contaminated normal: 80% N(0,1) + 20% N(5,1) -- outlier group +x_contam <- c(rnorm(24, 0, 1), rnorm(6, 5, 1)) +y_contam <- rnorm(30, 0, 1) + +cat("Group x: 80% N(0,1) + 20% N(5,1) contamination\n") +cat("Group y: N(0,1)\n") +cat("x mean =", round(mean(x_contam), 4), + ", x median =", round(median(x_contam), 4), "\n") +cat("y mean =", round(mean(y_contam), 4), + ", y median =", round(median(y_contam), 4), "\n\n") + +eqb_contam <- 1.5 + +cat("Two-sided test:\n") +hl_c2s <- hodges_lehmann(x_contam, y_contam, alternative = "two.sided") +sh_c2s <- simple_htest(x_contam, y_contam, test = "wilcox.test", + alternative = "two.sided") +cat(" hodges_lehmann: p =", round(hl_c2s$p.value, 6), + ", est =", round(hl_c2s$estimate, 4), "\n") +cat(" simple_htest: p =", round(sh_c2s$p.value, 6), + ", est =", round(sh_c2s$estimate, 4), "\n\n") + +cat("Equivalence test (bounds = +/-", eqb_contam, "):\n") +hl_ceq <- hodges_lehmann(x_contam, y_contam, + alternative = "equivalence", mu = eqb_contam) +sh_ceq <- simple_htest(x_contam, y_contam, test = "wilcox.test", + alternative = "equivalence", mu = eqb_contam) +cat(" hodges_lehmann: p =", round(hl_ceq$p.value, 6), "\n") +cat(" simple_htest: p =", round(sh_ceq$p.value, 6), "\n\n") + +cat("CI comparison (90%):\n") +cat(" hodges_lehmann: [", round(hl_ceq$conf.int[1], 4), ",", + round(hl_ceq$conf.int[2], 4), "]\n") +cat(" simple_htest: [", round(sh_ceq$conf.int[1], 4), ",", + round(sh_ceq$conf.int[2], 4), "]\n\n") + +# ============================================================================= +# SECTION 10: Heavy-tailed data (Cauchy) +# ============================================================================= +cat("=== SECTION 10: HEAVY-TAILED DATA (Cauchy) ===\n\n") + +set.seed(2024) +x_cauchy <- rcauchy(30, location = 0, scale = 1) +y_cauchy <- rcauchy(30, location = 0.5, scale = 1) + +cat("Cauchy(0,1) vs Cauchy(0.5,1), n = 30 each\n\n") + +hl_cauchy <- hodges_lehmann(x_cauchy, y_cauchy, alternative = "two.sided") +sh_cauchy <- simple_htest(x_cauchy, y_cauchy, test = "wilcox.test", + alternative = "two.sided") + +cat("Two-sided test:\n") +cat(" hodges_lehmann: p =", round(hl_cauchy$p.value, 6), + ", est =", round(hl_cauchy$estimate, 4), "\n") +cat(" simple_htest: p =", round(sh_cauchy$p.value, 6), + ", est =", round(sh_cauchy$estimate, 4), "\n\n") + +eqb_cauchy <- 2 +hl_cauchy_eq <- hodges_lehmann(x_cauchy, y_cauchy, + alternative = "equivalence", mu = eqb_cauchy) +sh_cauchy_eq <- simple_htest(x_cauchy, y_cauchy, test = "wilcox.test", + alternative = "equivalence", mu = eqb_cauchy) + +cat("Equivalence test (bounds = +/-", eqb_cauchy, "):\n") +cat(" hodges_lehmann: p =", round(hl_cauchy_eq$p.value, 6), "\n") +cat(" simple_htest: p =", round(sh_cauchy_eq$p.value, 6), "\n\n") + +# ============================================================================= +# SUMMARY +# ============================================================================= +cat("=======================================================================\n") +cat("SUMMARY\n") +cat("=======================================================================\n\n") + +cat("WHAT'S THE SAME:\n") +cat(" - Both target the Hodges-Lehmann estimator (location shift)\n") +cat(" - Point estimates should be identical (both compute the HL estimator)\n") +cat(" - Both implement TOST via two one-sided tests\n") +cat(" - Both use 1-2*alpha CIs for equivalence/MET\n") +cat(" - Under the same distributional assumptions, they test the same null\n\n") + +cat("WHAT'S DIFFERENT:\n") +cat(" - Inference method:\n") +cat(" hodges_lehmann: asymptotic (kernel density) or permutation-based\n") +cat(" simple_htest: wraps wilcox.test (rank-based exact/asymptotic)\n") +cat(" - Confidence intervals:\n") +cat(" hodges_lehmann (asymptotic): based on kernel density variance est.\n") +cat(" wilcox.test: based on inverting the rank test\n") +cat(" These will generally DIFFER even though the point estimates match\n") +cat(" - P-values:\n") +cat(" hodges_lehmann: Z-test from HL estimator / permutation\n") +cat(" wilcox.test: rank-sum (exact or normal approx with continuity)\n") +cat(" These test the same hypothesis but via different statistics\n") +cat(" - Scale estimation (permutation mode):\n") +cat(" hodges_lehmann: robust scale (S1 or S2, Fried & Dehling 2011)\n") +cat(" wilcox.test: no explicit scale estimator (rank-based)\n\n") + +cat("CONCLUSION:\n") +cat(" Both functions test the SAME hypothesis about location shift using\n") +cat(" the Hodges-Lehmann estimator, but they use DIFFERENT inference\n") +cat(" procedures. This means:\n") +cat(" - Point estimates will agree\n") +cat(" - P-values and CIs may differ (sometimes substantially)\n") +cat(" - They are complementary rather than redundant\n") +cat(" - hodges_lehmann offers more flexibility (permutation, scale choice)\n") +cat(" - simple_htest(wilcox) leverages well-established rank test theory\n") diff --git a/junk/test_paired_score.R b/junk/test_paired_score.R new file mode 100644 index 0000000..5aa41fa --- /dev/null +++ b/junk/test_paired_score.R @@ -0,0 +1,245 @@ +# test_paired_score.R +# Manual verification of paired/one-sample score method against wilcox.test + +library(TOSTER) + +cat("=============================================================\n") +cat(" Paired Score Method: Manual Verification Against wilcox.test\n") +cat("=============================================================\n\n") + +# Helper to compare ses_calc score vs wilcox.test +compare_paired <- function(x, y = NULL, mu = 0, label = "") { + cat("---", label, "---\n") + + if (is.null(y)) { + cat(" Design: one-sample, mu =", mu, "\n") + cat(" x:", head(x, 10), if (length(x) > 10) "...", "\n") + cat(" n =", length(x), "\n") + } else { + cat(" Design: paired\n") + cat(" x:", head(x, 10), if (length(x) > 10) "...", "\n") + cat(" y:", head(y, 10), if (length(y) > 10) "...", "\n") + cat(" n =", length(x), "\n") + d <- x - y + cat(" # zero diffs:", sum(d == 0), "\n") + } + cat("\n") + + # --- Two-sided, no cc --- + if (is.null(y)) { + wt <- wilcox.test(x, mu = mu, exact = FALSE, correct = FALSE) + } else { + wt <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE) + } + res <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "cstat", mu = mu, + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + + cat(" Two-sided (no cc):\n") + cat(" wilcox.test V =", wt$statistic, " p =", format(wt$p.value, digits = 8), "\n") + cat(" ses_calc z =", format(res$statistic, digits = 5), + " p =", format(res$p.value, digits = 8), "\n") + cat(" p-value match:", all.equal(res$p.value, wt$p.value, tolerance = 1e-6), "\n") + + # --- Two-sided, with cc --- + if (is.null(y)) { + wt_cc <- wilcox.test(x, mu = mu, exact = FALSE, correct = TRUE) + } else { + wt_cc <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = TRUE) + } + res_cc <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "cstat", mu = mu, + se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5) + + cat(" Two-sided (with cc):\n") + cat(" wilcox.test V =", wt_cc$statistic, " p =", format(wt_cc$p.value, digits = 8), "\n") + cat(" ses_calc z =", format(res_cc$statistic, digits = 5), + " p =", format(res_cc$p.value, digits = 8), "\n") + cat(" p-value match:", all.equal(res_cc$p.value, wt_cc$p.value, tolerance = 1e-6), "\n") + + # --- CI --- + res_ci <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "cstat", mu = mu, + se_method = "score", correct = FALSE) + cat(" Score 95% CI (cstat): [", format(res_ci$conf.int[1], digits = 5), ",", + format(res_ci$conf.int[2], digits = 5), "]\n") + cat(" Estimate (cstat):", format(res_ci$estimate, digits = 5), "\n") + + # --- All scales --- + res_rb <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "rb", mu = mu, + se_method = "score", correct = FALSE) + res_odds <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "odds", mu = mu, + se_method = "score", correct = FALSE) + res_lo <- ses_calc(x = x, y = y, paired = !is.null(y), ses = "logodds", mu = mu, + se_method = "score", correct = FALSE) + + cat(" rb: est =", format(res_rb$estimate, digits = 5), + " CI = [", format(res_rb$conf.int[1], digits = 5), ",", + format(res_rb$conf.int[2], digits = 5), "]\n") + cat(" odds: est =", format(res_odds$estimate, digits = 5), + " CI = [", format(res_odds$conf.int[1], digits = 5), ",", + format(res_odds$conf.int[2], digits = 5), "]\n") + cat(" logodds: est =", format(res_lo$estimate, digits = 5), + " CI = [", format(res_lo$conf.int[1], digits = 5), ",", + format(res_lo$conf.int[2], digits = 5), "]\n") + + # --- Verify scale consistency --- + ci_c <- res_ci$conf.int + expect_rb <- 2 * ci_c - 1 + expect_odds <- ci_c / (1 - ci_c) + expect_lo <- log(ci_c / (1 - ci_c)) + cat(" Scale consistency (rb):", all.equal(as.numeric(res_rb$conf.int), as.numeric(expect_rb)), "\n") + cat(" Scale consistency (odds):", all.equal(as.numeric(res_odds$conf.int), as.numeric(expect_odds)), "\n") + cat(" Scale consistency (logodds):", all.equal(as.numeric(res_lo$conf.int), as.numeric(expect_lo)), "\n") + + # --- Compare with agresti --- + res_agr <- suppressMessages( + ses_calc(x = x, y = y, paired = !is.null(y), ses = "cstat", mu = mu, + se_method = "agresti") + ) + cat(" Agresti 95% CI (cstat): [", format(res_agr$conf.int[1], digits = 5), ",", + format(res_agr$conf.int[2], digits = 5), "]\n") + + # --- Note string --- + cat(" Note:", res_ci$note, "\n") + + cat("\n") + invisible(res_ci) +} + +# Test 1: sleep data -------- +cat("=== Test 1: Sleep data (classic paired, no ties) ===\n\n") +data(sleep) +compare_paired( + x = sleep$extra[sleep$group == 2], + y = sleep$extra[sleep$group == 1], + label = "sleep data" +) +test1 = ses_calc( x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = TRUE, ses = "c", + se_method = "score") +ses_calc( x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = F, + ses = "c", + se_method = "score") + +ses_calc( x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = T, + ses = "c", + se_method = "score") +brunner_munzel(x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = F) +brunner_munzel(x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = T) + +wilcox_TOST(x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = TRUE, eqb = 1) +t.test(x = sleep$extra[sleep$group == 2],y = sleep$extra[sleep$group == 1], paired = TRUE ) +# Test 2: Data with ties -------- +# +cat("=== Test 2: Data with ties ===\n\n") +compare_paired( + x = c(1, 2, 2, 3, 4, 5, 5, 6), + y = c(2, 2, 3, 3, 3, 4, 5, 5), + label = "tied data" +) + +# Test 3: One-sample -------- +cat("=== Test 3: One-sample ===\n\n") +compare_paired( + x = c(1.5, 2.3, 3.1, 0.8, 4.2, 2.7, 3.9, 1.1, 5.0, 2.5), + mu = 0, + label = "one-sample (all positive)" +) + +# Test 4: Heavy ties (ordinal) -------- +cat("=== Test 4: Heavy ties (ordinal-like) ===\n\n") +set.seed(123) +compare_paired( + x = sample(1:5, 20, replace = TRUE), + y = sample(1:5, 20, replace = TRUE), + label = "ordinal 1-5 (seed=123)" +) + +# Test 5: Complete separation -------- +cat("=== Test 5: Complete separation ===\n\n") +compare_paired( + x = c(10, 11, 12, 13, 14), + y = c(1, 2, 3, 4, 5), + label = "all x > y" +) + +compare_paired( + x = c(1, 2, 3, 4, 5), + y = c(10, 11, 12, 13, 14), + label = "all y > x" +) + +# Test 6: Data with zero differences -------- +cat("=== Test 6: Zero differences (should be dropped) ===\n\n") +compare_paired( + x = c(1, 2, 3, 4, 5, 6, 7), + y = c(2, 2, 4, 4, 3, 7, 5), + label = "2 zero diffs out of 7" +) + +# Test 7: CI/p-value coherence -------- +cat("=== Test 7: CI/p-value coherence for equivalence ===\n\n") +set.seed(123) +x7 <- sample(1:5, 20, replace = TRUE) +y7 <- sample(1:5, 20, replace = TRUE) + +res_equiv <- ses_calc(x = x7, y = y7, paired = TRUE, ses = "cstat", + se_method = "score", alpha = 0.05, + alternative = "equivalence", + null.value = c(0.3, 0.7)) +ci90 <- res_equiv$conf.int + +cat(" 90% CI (from equivalence, alpha=0.05):", format(ci90[1], digits = 6), ",", + format(ci90[2], digits = 6), "\n") +cat(" Equivalence p-value:", format(res_equiv$p.value, digits = 6), "\n\n") + +# Test at each CI bound +res_lo <- ses_calc(x = x7, y = y7, paired = TRUE, ses = "cstat", + se_method = "score", + alternative = "greater", null.value = ci90[1]) +res_hi <- ses_calc(x = x7, y = y7, paired = TRUE, ses = "cstat", + se_method = "score", + alternative = "less", null.value = ci90[2]) +cat(" p(cstat > lower CI bound):", format(res_lo$p.value, digits = 6), + "(expect ~0.05)\n") +cat(" p(cstat < upper CI bound):", format(res_hi$p.value, digits = 6), + "(expect ~0.05)\n") +cat(" Coherence check:", all.equal(res_lo$p.value, 0.05, tolerance = 1e-4), + "/", all.equal(res_hi$p.value, 0.05, tolerance = 1e-4), "\n\n") + +# Test 8: Equivalence on rb scale -------- +cat("=== Test 8: Equivalence test on rb scale ===\n\n") +data(sleep) +x8 <- sleep$extra[sleep$group == 2] +y8 <- sleep$extra[sleep$group == 1] + +res_eq_rb <- ses_calc(x = x8, y = y8, paired = TRUE, ses = "rb", + se_method = "score", + alternative = "equivalence", + null.value = c(-0.6, 0.6)) +cat(" rb equivalence bounds: [-0.6, 0.6]\n") +cat(" Estimate:", format(res_eq_rb$estimate, digits = 5), "\n") +cat(" 90% CI:", format(res_eq_rb$conf.int[1], digits = 5), ",", + format(res_eq_rb$conf.int[2], digits = 5), "\n") +cat(" p-value:", format(res_eq_rb$p.value, digits = 6), "\n\n") + +# Test 9: Larger sample -------- +cat("=== Test 9: Larger sample (n=50) ===\n\n") +set.seed(999) +compare_paired( + x = rnorm(50, mean = 0.3), + y = rnorm(50, mean = 0), + label = "n=50, small shift" +) + +# Summary -------- +cat("=============================================================\n") +cat(" Summary\n") +cat("=============================================================\n") +cat(" - Two-sided p-values match wilcox.test at pi0 = 0.5\n") +cat(" - Continuity correction matches wilcox.test correct = TRUE\n") +cat(" - Wilson-score CI has closed-form (no root-finding)\n") +cat(" - CI handles boundaries naturally (no Haldane correction)\n") +cat(" - CI/p-value coherence guaranteed by test inversion\n") +cat(" - Scale transformations (cstat/rb/odds/logodds) consistent\n") +cat(" - Zero differences dropped (matches wilcox.test behavior)\n") +cat("=============================================================\n") diff --git a/man/bca_ci.Rd b/man/bca_ci.Rd new file mode 100644 index 0000000..3c57a4a --- /dev/null +++ b/man/bca_ci.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/others.R +\name{bca_ci} +\alias{bca_ci} +\title{BCa bootstrap confidence interval (internal)} +\usage{ +bca_ci(boots_est, t0, jack_est, alpha) +} +\arguments{ +\item{boots_est}{Numeric vector of bootstrap estimates (on the working scale)} + +\item{t0}{Original estimate (on the same working scale as boots_est)} + +\item{jack_est}{Numeric vector of jackknife (leave-one-out) estimates (on the same working scale)} + +\item{alpha}{Significance level (e.g., 0.05 for 95\% CI)} +} +\value{ +Numeric vector of length 2: c(lower, upper) +} +\description{ +Computes a bias-corrected and accelerated (BCa) bootstrap confidence interval. +The BCa method provides second-order accuracy by correcting for both bias and +skewness in the bootstrap distribution, using jackknife estimates to compute +the acceleration factor. +} +\keyword{internal} diff --git a/man/bca_params.Rd b/man/bca_params.Rd new file mode 100644 index 0000000..250ec0f --- /dev/null +++ b/man/bca_params.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/others.R +\name{bca_params} +\alias{bca_params} +\title{Compute BCa bias-correction and acceleration parameters} +\usage{ +bca_params(boots_est, t0, jack_est) +} +\arguments{ +\item{boots_est}{Numeric vector of bootstrap estimates} + +\item{t0}{Original estimate (on the same scale as boots_est)} + +\item{jack_est}{Numeric vector of jackknife (leave-one-out) estimates} +} +\value{ +A list with components \code{z0} and \code{acc} +} +\description{ +Extracts z0 (bias correction) and acc (acceleration) from bootstrap and +jackknife estimates for use with both \code{bca_ci} and \code{boot_pvalue}. +} +\keyword{internal} diff --git a/man/boot_cor_test.Rd b/man/boot_cor_test.Rd index 0be9d30..f1c7273 100644 --- a/man/boot_cor_test.Rd +++ b/man/boot_cor_test.Rd @@ -11,7 +11,7 @@ boot_cor_test( method = c("pearson", "kendall", "spearman", "winsorized", "bendpercent"), alpha = 0.05, null = 0, - boot_ci = c("basic", "perc"), + boot_ci = c("bca", "stud", "basic", "perc"), R = 1999, ... ) @@ -54,8 +54,14 @@ or a vector of two values representing the lower and upper bounds \item{boot_ci}{type of bootstrap confidence interval: \itemize{ -\item "basic": basic/empirical bootstrap CI -\item "perc": percentile bootstrap CI (default) +\item "basic": basic/empirical bootstrap CI (default) +\item "perc": percentile bootstrap CI +\item "bca": bias-corrected and accelerated bootstrap CI. Provides second-order +accuracy by correcting for bias and skewness, but requires additional +computation via the jackknife (n extra evaluations of the statistic). +\item "stud": studentized (bootstrap-t) CI. Uses pivot statistics on the Fisher z +scale with analytical SEs. Only available for \code{method = "pearson"}, +\code{"kendall"}, or \code{"spearman"}. }} \item{R}{number of bootstrap replications (default = 1999).} @@ -72,7 +78,7 @@ A list with class "htest" containing the following components: \item \strong{p.value}: the bootstrap p-value of the test. \item \strong{parameter}: the number of observations used in the test. \item \strong{conf.int}: a bootstrap confidence interval for the correlation coefficient. -\item \strong{estimate}: the estimated correlation coefficient, with name "cor", "tau", "rho", "pb", or "wincor" +\item \strong{estimate}: the estimated correlation coefficient, with name "r", "tau", "rho", "pb", or "wincor" corresponding to the method employed. \item \strong{stderr}: the bootstrap standard error of the correlation coefficient. \item \strong{null.value}: the value(s) of the correlation under the null hypothesis. @@ -80,6 +86,7 @@ corresponding to the method employed. \item \strong{method}: a character string indicating which bootstrapped correlation was measured. \item \strong{data.name}: a character string giving the names of the data. \item \strong{boot_res}: vector of bootstrap correlation estimates. +\item \strong{boot_ci}: character string indicating which bootstrap CI method was used. \item \strong{call}: the matched call. } } @@ -92,7 +99,25 @@ This function supports standard, equivalence, and minimal effect testing with ro } \details{ This function uses bootstrap methods to calculate correlation coefficients and their -confidence intervals. P-values are calculated from a re-sampled null distribution. +confidence intervals. P-values are computed by inverting the selected CI method, +which guarantees that \code{p < alpha} if and only if the corresponding CI excludes the +null value. + +\strong{P-value computation by CI method:} +\itemize{ +\item \code{boot_ci = "perc"}: p-values are computed from the raw bootstrap distribution +(proportion of replicates beyond the null). This is the original approach from +Wilcox (2017). +\item \code{boot_ci = "basic"}: p-values use the reflected bootstrap distribution +(\code{2 * est - bvec}), which is the exact inversion of the basic CI. +\item \code{boot_ci = "bca"}: p-values are derived from the BCa probability transformation, +using the same bias correction and acceleration parameters as the BCa CI. +\item \code{boot_ci = "stud"}: p-values are derived from the bootstrap pivot distribution +on the Fisher z scale. Each replicate's pivot is \code{(z_star - z_obs) / se_star}, +where \code{se_star} is the analytical SE. This method is only available for +Pearson, Kendall, and Spearman correlations, since robust methods lack +analytical SEs on the Fisher z scale. +} The bootstrap correlation methods in this package offer two robust correlations beyond the standard methods: diff --git a/man/boot_log_TOST.Rd b/man/boot_log_TOST.Rd index 9869750..f9483a0 100644 --- a/man/boot_log_TOST.Rd +++ b/man/boot_log_TOST.Rd @@ -17,7 +17,7 @@ boot_log_TOST(x, ...) eqb = 1.25, alpha = 0.05, null = 1, - boot_ci = c("stud", "basic", "perc"), + boot_ci = c("stud", "basic", "perc", "bca"), R = 1999, ... ) @@ -45,7 +45,7 @@ or 2 specific values that represent the lower and upper equivalence bounds (e.g. \item{null}{the ratio value under the null hypothesis (default = 1).} \item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), -"basic" (basic bootstrap), or "perc" (percentile bootstrap).} +"basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap).} \item{R}{number of bootstrap replications (default = 1999).} @@ -94,16 +94,40 @@ The bootstrap procedure follows these steps: \itemize{ \item Log-transform the data \item Perform resampling with replacement to generate bootstrap samples -\item For each bootstrap sample, calculate test statistics and effect sizes -\item Use the distribution of bootstrap results to compute p-values and confidence intervals -\item Back-transform for the ratio of means +\item For each bootstrap sample, calculate test statistics and effect sizes on the log scale +\item Compute p-values and confidence intervals using the selected bootstrap method +\item Back-transform confidence intervals for the ratio of means } +\subsection{Bootstrap Confidence Interval Methods}{ + +Four types of bootstrap confidence intervals are available via the \code{boot_ci} argument: +\itemize{ +\item \strong{Studentized ("stud")}: Uses the bootstrap distribution of pivotal t-statistics +to account for variability in standard error estimates. This is the default. +\item \strong{Basic/Empirical ("basic")}: Reflects the bootstrap distribution of estimates +around the observed value. +\item \strong{Percentile ("perc")}: Uses percentiles of the bootstrap distribution directly. +\item \strong{Bias-corrected and accelerated ("bca")}: Corrects for both bias and skewness +in the bootstrap distribution using jackknife-based acceleration. +} +} + +\subsection{Bootstrap P-values}{ + +The p-value for each test (two-tailed and both one-sided) is computed using +the method that matches the selected \code{boot_ci}, ensuring that p < alpha if and +only if the corresponding confidence interval excludes the null value +(CI inversion principle). Previously, all bootstrap CI methods used the +studentized (pivot) p-value, which could produce p-values inconsistent with +non-studentized CIs. All computations are performed on the log scale, then +back-transformed. Note that all input data must be positive (ratio scale with a true zero) since log transformation is applied. The function will stop with an error if any negative values are detected. For details on the calculations in this function see \code{vignette("robustTOST")}. } +} \section{Purpose}{ Use this function when: @@ -152,6 +176,7 @@ https://www.fda.gov/regulatory-information/search-fda-guidance-documents/bioavai } \seealso{ Other Robust tests: +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, diff --git a/man/boot_pvalue.Rd b/man/boot_pvalue.Rd new file mode 100644 index 0000000..e7de342 --- /dev/null +++ b/man/boot_pvalue.Rd @@ -0,0 +1,55 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/corr_calcs.R +\name{boot_pvalue} +\alias{boot_pvalue} +\title{Compute a bootstrap p-value consistent with the selected CI method} +\usage{ +boot_pvalue( + bvec, + est, + null, + alternative, + boot_ci, + tvec = NULL, + se_obs = NULL, + z0 = NULL, + acc = NULL, + nboot, + z_transform = FALSE +) +} +\arguments{ +\item{bvec}{Numeric vector of bootstrap estimates (on the working scale)} + +\item{est}{Observed estimate (on the same scale as bvec)} + +\item{null}{Null hypothesis value (single numeric, on the same scale as bvec)} + +\item{alternative}{One of "two.sided", "greater", "less"} + +\item{boot_ci}{One of "perc", "basic", "bca", "stud"} + +\item{tvec}{Bootstrap pivots (required for "stud"): +typically \code{(bvec - est) / bootstrap_se}} + +\item{se_obs}{Observed standard error on the working scale (required for "stud")} + +\item{z0}{BCa bias correction from \code{bca_params()} (required for "bca")} + +\item{acc}{BCa acceleration from \code{bca_params()} (required for "bca")} + +\item{nboot}{Number of bootstrap replicates} + +\item{z_transform}{Logical indicating whether to apply Fisher z transformation +(used for correlation estimates; default FALSE)} +} +\value{ +A single p-value +} +\description{ +Dispatches to the appropriate p-value calculation based on the CI method, +ensuring that p < alpha if and only if the corresponding CI excludes the null. +Used by all bootstrap functions in the package (correlations, t-tests, SMD, +SES, TOST, and log-TOST). +} +\keyword{internal} diff --git a/man/boot_ses_calc.Rd b/man/boot_ses_calc.Rd index 25cbd5a..0507411 100644 --- a/man/boot_ses_calc.Rd +++ b/man/boot_ses_calc.Rd @@ -13,11 +13,12 @@ boot_ses_calc( ses = "rb", alpha = 0.05, mu = 0, - boot_ci = c("basic", "stud", "perc"), + boot_ci = c("bca", "stud", "basic", "perc"), R = 1999, se_method = c("agresti", "fisher"), output = c("htest", "data.frame"), - alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), null.value = NULL ) @@ -28,11 +29,12 @@ boot_ses_calc( ses = c("rb", "odds", "logodds", "cstat"), alpha = 0.05, mu = 0, - boot_ci = c("basic", "stud", "perc"), + boot_ci = c("basic", "stud", "perc", "bca"), R = 1999, se_method = c("agresti", "fisher"), output = c("htest", "data.frame"), - alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), null.value = NULL, ... ) @@ -57,14 +59,15 @@ boot_ses_calc( \item{mu}{number indicating the value around which asymmetry (for one-sample or paired samples) or shift (for independent samples) is to be estimated (default = 0).} -\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), or "perc" (percentile bootstrap).} +\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap).} \item{R}{number of bootstrap replications (default = 1999).} \item{se_method}{a character string specifying the method for computing standard errors within each bootstrap sample: -- "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation. -This method has better asymptotic properties. +- "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation +with the log-odds working scale, which has better asymptotic properties +(faster convergence to normality per Agresti, 1980). - "fisher": Uses the legacy Fisher z-transformation method. Retained for backward compatibility.} @@ -72,12 +75,14 @@ compatibility.} - "htest": (default) Returns an object of class "htest" compatible with standard R output. - "data.frame": Returns a data frame with effect size estimates and confidence intervals.} -\item{alternative}{a character string specifying the alternative hypothesis: -- "two.sided": effect differs from null.value (default) -- "less": effect is less than null.value -- "greater": effect is greater than null.value -- "equivalence": effect is between specified bounds -- "minimal.effect": effect is outside specified bounds} +\item{alternative}{a character string specifying the alternative hypothesis for optional +hypothesis testing: +- "none": (default) No hypothesis test is performed; only effect size and CI are returned. +- "two.sided": Test whether effect differs from null.value +- "less": Test whether effect is less than null.value +- "greater": Test whether effect is greater than null.value +- "equivalence": Test whether effect is between specified bounds +- "minimal.effect": Test whether effect is outside specified bounds} \item{null.value}{a number or vector specifying the null hypothesis value(s): - For standard alternatives: a single value (default = 0 for rb/logodds, 0.5 for cstat, 1 for odds) @@ -99,14 +104,14 @@ If \code{output = "htest"} (default), returns a list with class \code{"htest"} c \item estimate: The effect size estimate calculated from the original data \item stderr: Standard error estimated from the bootstrap distribution \item conf.int: Bootstrap confidence interval with conf.level attribute -\item statistic: The observed z-statistic (for hypothesis testing) -\item p.value: The bootstrapped p-value for the test -\item null.value: The specified hypothesized value(s) \item alternative: A character string describing the alternative hypothesis \item method: A character string indicating what type of test was performed \item boot: The bootstrap samples of the effect size (on the requested scale) \item data.name: A character string giving the name(s) of the data \item call: The matched call +\item statistic: Test statistic (only if alternative != "none") +\item p.value: The bootstrapped p-value for the test (only if alternative != "none") +\item null.value: The specified hypothesized value(s) (only if alternative != "none") } If \code{output = "data.frame"}, returns a data frame containing: @@ -136,7 +141,9 @@ The function implements the following bootstrap approach: \item Calculate the raw effect size using the original data \item Create R bootstrap samples by resampling with replacement from the original data \item Calculate the effect size for each bootstrap sample -\item Apply the Fisher z-transformation to stabilize variance for rank-biserial correlation values +\item Transform bootstrap estimates to the working scale for CI construction: +the log-odds scale when \code{se_method = "agresti"} (default), or Fisher z +when \code{se_method = "fisher"} \item Calculate confidence intervals using the specified method \item Back-transform the confidence intervals to the original scale \item Convert to the requested effect size measure (if not rank-biserial) @@ -155,25 +162,44 @@ Wilcoxon statistic variance. This is retained for backward compatibility. \subsection{Bootstrap Confidence Interval Methods}{ -Three bootstrap confidence interval methods are available: +Four bootstrap confidence interval methods are available via the \code{boot_ci} argument: \itemize{ -\item \strong{Basic bootstrap ("basic")}: Uses the empirical distribution of bootstrap estimates -\item \strong{Studentized bootstrap ("stud")}: Accounts for the variability in standard error estimates +\item \strong{Basic bootstrap ("basic")}: Reflects the bootstrap distribution of estimates +around the observed value +\item \strong{Studentized bootstrap ("stud")}: Uses the bootstrap distribution of pivotal +t-statistics to account for variability in standard error estimates. This is the +default and usually provides the most accurate coverage. \item \strong{Percentile bootstrap ("perc")}: Uses percentiles of the bootstrap distribution directly +\item \strong{Bias-corrected and accelerated ("bca")}: Corrects for both bias and skewness in the +bootstrap distribution using jackknife-based acceleration } + +All CI methods operate on a working scale that is better suited +to symmetric bootstrap distributions: the log-odds scale when +\code{se_method = "agresti"} (default), or the Fisher z scale when +\code{se_method = "fisher"}. Confidence limits are then back-transformed to the +requested effect size scale. } \subsection{Hypothesis Testing}{ -When an alternative other than "two.sided" is specified, or when null.value is not the +When an alternative other than "none" is specified, or when null.value is not the default, the function performs bootstrap hypothesis testing. For equivalence and minimal effect testing, specify null.value as a vector of two values (lower and upper bounds). +The p-value is computed using the method that matches the selected \code{boot_ci}, +ensuring that p < alpha if and only if the corresponding confidence interval +excludes the null value (CI inversion principle). Previously, all bootstrap +CI methods used the studentized (pivot) p-value, which could produce p-values +inconsistent with non-studentized CIs. The null value is converted to the +working scale (log-odds or Fisher z) before computing the p-value, maintaining +consistency with the CI construction. + For different alternatives, the p-values are calculated as follows: \itemize{ -\item "two.sided": Proportion of bootstrap statistics at least as extreme as the observed statistic -\item "less": Proportion of bootstrap statistics less than or equal to the observed statistic -\item "greater": Proportion of bootstrap statistics greater than or equal to the observed statistic +\item "two.sided": Two-tailed p-value from the bootstrap distribution +\item "less": One-sided p-value for the hypothesis that the true value is less than the null +\item "greater": One-sided p-value for the hypothesis that the true value is greater than the null \item "equivalence": Maximum of two one-sided p-values (for lower and upper bounds) \item "minimal.effect": Minimum of two one-sided p-values (for lower and upper bounds) } @@ -190,6 +216,32 @@ the bootstrapping process. The function will issue a warning if this occurs. For detailed information on calculation methods, see \code{vignette("robustTOST")}. } + +\subsection{Edge Cases}{ +\itemize{ +\item \strong{Complete separation}: When one group entirely dominates the other +(concordance probability = 0 or 1), the bootstrap distribution collapses +and CIs become degenerate. The function stops with an informative error +directing users to \code{\link[=ses_calc]{ses_calc()}} with \code{se_method = "agresti"} for +asymptotic inference. This condition is detected before resampling begins. +\item \strong{Near-complete separation}: When the observed rb is close to +/-1 but +not exactly at the boundary, the working-scale transformation (log-odds +or Fisher z) helps stabilize the bootstrap but coverage may still +degrade. The function issues a message when bootstrap replicates contain +infinite values after transformation, which is a symptom of this problem. +\item \strong{Why the bootstrap fails at boundaries}: The rank-biserial is bounded +on [-1, 1]. When the observed value is near a boundary, resampled +values pile up at the boundary, producing a distribution that is not +well-approximated by the symmetric bootstrap CI methods (basic, +percentile, studentized). The log-odds and Fisher z working scales +mitigate this by mapping [-1, 1] to the real line, but the mapping +itself becomes unstable as rb approaches +/-1. +\item \strong{Recommendation}: For data with complete or near-complete separation, +prefer the asymptotic Agresti/Lehmann interval from \code{\link[=ses_calc]{ses_calc()}}, which +handles boundary behavior more gracefully through the placement-based +variance estimator. +} +} } \section{Purpose}{ @@ -229,13 +281,14 @@ result <- boot_ses_calc(x = group1, y = group2, R = 99) # Example 4: Paired samples -data(sleep) -with(sleep, boot_ses_calc(x = extra[group == 1], - y = extra[group == 2], - paired = TRUE, - ses = "rb", - alternative = "greater", - R = 99)) +set.seed(42) +pre <- c(4.5, 5.2, 3.8, 6.1, 4.9, 5.7, 3.6, 5.0, 4.3, 6.5) +post <- c(5.1, 4.9, 4.5, 5.8, 5.5, 5.2, 4.3, 5.4, 4.0, 6.2) +boot_ses_calc(x = pre, y = post, + paired = TRUE, + ses = "rb", + alternative = "greater", + R = 99) # Example 5: Using formula notation data(mtcars) @@ -259,7 +312,9 @@ Lehmann, E.L. (1975). \emph{Nonparametrics: Statistical Methods Based on Ranks}. \seealso{ Other effect sizes: \code{\link{boot_smd_calc}()}, +\code{\link{rank_diff}()}, \code{\link{ses_calc}()}, -\code{\link{smd_calc}()} +\code{\link{smd_calc}()}, +\code{\link{trans_rank_prob}()} } \concept{effect sizes} diff --git a/man/boot_ses_test.Rd b/man/boot_ses_test.Rd new file mode 100644 index 0000000..36a6be7 --- /dev/null +++ b/man/boot_ses_test.Rd @@ -0,0 +1,252 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/boot_ses_test.R +\name{boot_ses_test} +\alias{boot_ses_test} +\alias{boot_ses_test.default} +\alias{boot_ses_test.formula} +\title{Parametric Bootstrap Test for Rank-Based Effect Sizes} +\usage{ +boot_ses_test( + x, + ..., + paired = FALSE, + ses = c("rb", "cstat", "odds", "logodds"), + alpha = 0.05, + mu = NULL, + alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), + B = 2000L, + keep_boot = TRUE +) + +\method{boot_ses_test}{default}( + x, + y = NULL, + paired = FALSE, + ses = c("rb", "cstat", "odds", "logodds"), + alpha = 0.05, + mu = NULL, + alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), + B = 2000L, + keep_boot = TRUE, + ... +) + +\method{boot_ses_test}{formula}(formula, data, subset, na.action, ...) +} +\arguments{ +\item{x}{numeric vector of data values (first group or pre-treatment).} + +\item{...}{further arguments to be passed to or from methods.} + +\item{paired}{a logical indicating whether you want a paired t-test. Cannot be used with the formula method; use x and y vectors instead for paired tests.} + +\item{ses}{a character string specifying the effect size measure: +- "rb": rank-biserial correlation (default) +- "cstat": concordance statistic (C-statistic/AUC) +- "odds": Wilcoxon-Mann-Whitney odds +- "logodds": Wilcoxon-Mann-Whitney log-odds} + +\item{alpha}{significance level (default = 0.05).} + +\item{mu}{the null hypothesis value(s) on the scale of the chosen effect size. +- For standard alternatives: a single value (default = 0 for rb/logodds, +0.5 for cstat, 1 for odds) +- For equivalence/minimal.effect: two values representing the lower and +upper bounds, or a single value for symmetric bounds} + +\item{alternative}{a character string specifying the alternative hypothesis: +- "two.sided": Test whether effect differs from mu +- "less": Test whether effect is less than mu +- "greater": Test whether effect is greater than mu +- "equivalence": TOST equivalence test (effect inside bounds) +- "minimal.effect": Minimal effect test (effect outside bounds)} + +\item{B}{integer; the number of bootstrap replicates (default = 2000). +Increase to 5000+ for publication-quality results.} + +\item{keep_boot}{logical; if \code{TRUE} (default), return the bootstrap +distributions in the output.} + +\item{y}{numeric vector of data values (second group or post-treatment).} + +\item{formula}{a formula of the form lhs ~ rhs where lhs is a numeric variable giving the data values and rhs either 1 for a one-sample test or a factor with two levels giving the corresponding groups. For paired tests, use the default method with x and y vectors instead of the formula method.} + +\item{data}{an optional matrix or data frame (or similar: see model.frame) containing the variables in the formula formula. By default the variables are taken from environment(formula).} + +\item{subset}{an optional vector specifying a subset of observations to be used.} + +\item{na.action}{a function which indicates what should happen when the data contain NAs. Defaults to getOption("na.action").} +} +\value{ +A list with class \code{"htest"} containing: +\item{estimate}{Observed effect size on the requested scale.} +\item{p.value}{Bootstrap p-value.} +\item{alternative}{Character string describing the alternative hypothesis.} +\item{method}{Description of the test performed.} +\item{null.value}{Null hypothesis value(s) on the requested scale.} +\item{data.name}{Character string giving the name(s) of the data.} +\item{call}{The matched call.} +\item{model.param}{The model parameter(s) used for null generation +(for diagnostics). For two-sample: the Lehmann gamma parameter(s). +For paired: the sign probability parameter(s).} +\item{boot.dist}{Bootstrap null distribution (if \code{keep_boot = TRUE} and +standard alternative).} +\item{boot.dist.low}{Bootstrap distribution under lower bound (if +\code{keep_boot = TRUE} and TOST).} +\item{boot.dist.high}{Bootstrap distribution under upper bound (if +\code{keep_boot = TRUE} and TOST).} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Performs hypothesis testing for rank-based effect sizes using a parametric +bootstrap. This function is designed primarily for equivalence testing (TOST) +and minimal effect testing with non-zero null hypotheses, where +permutation-based approaches are not valid for rank-based effect sizes. +} +\details{ +This function calculates p-values for rank-based effect sizes using a +parametric bootstrap. It generates data under the null hypothesis and +compares the observed effect size to the resulting null reference +distribution. +\subsection{Why Not Permutation?}{ + +Permutation tests are exact and assumption-free when testing the null +\eqn{\rho = 0}. However, for non-zero nulls — as required by equivalence +(TOST) and minimal effect testing — the permutation distribution cannot be +shifted to the correct null by arithmetic operations. The rank-biserial +correlation is a nonlinear, bounded function of the data, so there is no +data transformation that shifts rb by a fixed \eqn{\Delta}. Studentization +(as used in \code{\link[=perm_t_test]{perm_t_test()}} and \code{\link[=brunner_munzel]{brunner_munzel()}}) cannot rescue this +because rb is not a studentized statistic. + +This function uses parametric models to generate data under the non-zero +null. The tradeoff is that validity now depends on how well the model +approximates the true data-generating process. + +Users who need TOST for means should use \code{\link[=boot_t_TOST]{boot_t_TOST()}}, which handles +non-zero nulls correctly via studentization without any parametric +assumption. +} + +\subsection{Why No Confidence Intervals?}{ + +This function intentionally omits confidence intervals. The parametric +bootstrap here generates data under a specific null to produce a reference +distribution for p-value computation. This is fundamentally different from +the nonparametric bootstrap in \code{\link[=boot_ses_calc]{boot_ses_calc()}}, which resamples from the +observed data to characterize the sampling distribution of the estimator. +Users who need confidence intervals should use \code{\link[=boot_ses_calc]{boot_ses_calc()}} or the +asymptotic intervals from \code{\link[=ses_calc]{ses_calc()}}. +} + +\subsection{Algorithm}{ + +\strong{Two-sample (independent)}: Uses the Lehmann alternative (proportional +hazards) model. Data are pooled and treated as a common empirical CDF +\eqn{F}. Under the null \eqn{P(X > Y) = \text{target}}, group Y is +resampled from \eqn{F} and group X is resampled from a transformed CDF +\eqn{G(t) = 1 - (1 - F(t))^{1/\gamma}} where +\eqn{\gamma = \text{target\_cstat} / (1 - \text{target\_cstat})}. This +produces data with the correct population rank-biserial under the +proportional hazards assumption. + +\strong{Paired samples}: Uses a sign-randomization model. The absolute +differences \eqn{|d_i| = |x_i - y_i|} are resampled with replacement, and +signs are assigned independently with probability +\eqn{P(\text{sign} = +) = (1 + \Delta) / 2}. This produces a bootstrap +distribution with the correct expected signed-rank rb under the assumption +of rank-independent sign probabilities. + +For equivalence testing, two null distributions are generated (one per bound) +and the TOST p-value is the maximum of the two one-sided p-values. +} +} +\section{Warning}{ + +This function is experimental. Important caveats: +\itemize{ +\item Validity depends on parametric assumptions (Lehmann alternative for +two-sample, sign-randomization for paired). Unlike permutation tests, +this is not assumption-free. +\item The procedure is most reliable for continuous data, moderate n (>= 20), +and equivalence bounds not too close to +/-1. +\item Results should be interpreted with caution and ideally cross-checked +against asymptotic methods from \code{\link[=ses_calc]{ses_calc()}}. +\item This function exists because no assumption-free alternative for non-zero +null TOST is available for rank-based effect sizes. The choice is between +this and no test at all, not between this and a better test. +} +} + +\section{Future Work}{ + +\itemize{ +\item \strong{Confidence intervals}: Not currently provided. Adding CIs would +require test inversion across a grid of null values (Berger & Boos, 1994), +which is computationally expensive. Use \code{\link[=boot_ses_calc]{boot_ses_calc()}} or \code{\link[=ses_calc]{ses_calc()}} +for interval estimation. +\item \strong{Rank-dependent sign model}: The current paired bootstrap assigns +signs independently of rank. A rank-weighted sign model could improve +accuracy by allowing the sign probability to depend on the magnitude of +the difference. +\item \strong{Copula-based generation}: A normal copula model could provide an +alternative data generation mechanism, especially for paired data where +the joint distribution matters beyond marginals. This would require +numerical calibration of the copula parameter to the target rb. +} +} + +\examples{ +\donttest{ +# Example 1: Two-sided test +set.seed(42) +x <- rnorm(30, mean = 0) +y <- rnorm(30, mean = 0.5) +boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 599) + +# Example 2: Equivalence test with rank-biserial +boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.4, 0.4), alternative = "equivalence", B = 599) + +# Example 3: Paired samples +pre <- c(4.5, 5.2, 3.8, 6.1, 4.9, 5.7, 3.6, 5.0, 4.3, 6.5, + 4.1, 5.5, 3.9, 6.0, 4.7, 5.3, 3.7, 5.1, 4.4, 6.3) +post <- c(5.1, 4.9, 4.5, 5.8, 5.5, 5.2, 4.3, 5.4, 4.0, 6.2, + 4.8, 5.3, 4.2, 5.7, 5.1, 5.0, 4.1, 5.3, 4.2, 6.1) +boot_ses_test(x = pre, y = post, paired = TRUE, + ses = "rb", mu = 0, alternative = "two.sided", B = 599) + +# Example 4: Using formula interface +data(mtcars) +boot_ses_test(formula = mpg ~ am, data = mtcars, + ses = "rb", mu = 0, + alternative = "two.sided", B = 599) +} + +} +\references{ +Berger, R.L. and Boos, D.D. (1994). P values maximized over a confidence set +for the nuisance parameter. \emph{Journal of the American Statistical Association}, +89, 1012-1016. + +Lehmann, E.L. (1975). \emph{Nonparametrics: Statistical Methods Based on Ranks}. +Holden-Day. +} +\seealso{ +\code{\link[=ses_calc]{ses_calc()}} for asymptotic inference, \code{\link[=boot_ses_calc]{boot_ses_calc()}} for +bootstrap confidence intervals, \code{\link[=brunner_munzel]{brunner_munzel()}} with +\code{test_method = "perm"} for robust TOST on the probability scale. + +Other Robust tests: +\code{\link{boot_log_TOST}()}, +\code{\link{boot_t_TOST}()}, +\code{\link{boot_t_test}()}, +\code{\link{brunner_munzel}()}, +\code{\link{hodges_lehmann}()}, +\code{\link{log_TOST}()}, +\code{\link{perm_t_test}()}, +\code{\link{wilcox_TOST}()} +} +\concept{Robust tests} diff --git a/man/boot_smd_calc.Rd b/man/boot_smd_calc.Rd index 2289c1a..5ceb6bc 100644 --- a/man/boot_smd_calc.Rd +++ b/man/boot_smd_calc.Rd @@ -15,8 +15,14 @@ boot_smd_calc( bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - boot_ci = c("stud", "basic", "perc"), - R = 1999 + denom = c("auto", "z", "rm", "pooled", "avg", "glass1", "glass2"), + boot_ci = c("stud", "basic", "perc", "bca"), + R = 1999, + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), + tr = 0 ) \method{boot_smd_calc}{default}( @@ -29,8 +35,14 @@ boot_smd_calc( bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - boot_ci = c("stud", "basic", "perc"), + denom = c("auto", "z", "rm", "pooled", "avg", "glass1", "glass2"), + boot_ci = c("stud", "basic", "perc", "bca"), R = 1999, + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), + tr = 0, ... ) @@ -53,10 +65,49 @@ boot_smd_calc( \item{glass}{Option to calculate Glass's delta instead of Cohen's d style SMD ('glass1' uses first group's SD, 'glass2' uses second group's SD).} -\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), or "perc" (percentile bootstrap).} +\item{denom}{a character string specifying the denominator for standardization: +- "auto": (default) Uses the standard denominator based on design and other arguments +(glass, rm_correction, var.equal). +- "z": SD of differences (Cohen's d_z). Valid for paired and one-sample designs. +- "rm": Repeated-measures corrected (Cohen's d_rm). Valid for paired designs only. +- "pooled": Pooled SD (Cohen's d_s). Valid for independent samples only. +- "avg": Root-mean-square SD (Cohen's d_av). Valid for independent samples only. +- "glass1": First group's (x) SD (Glass's delta). Valid for paired and independent designs. +- "glass2": Second group's (y) SD (Glass's delta). Valid for paired and independent designs. + +\if{html}{\out{
}}\preformatted{When set to any value other than "auto", this overrides the glass, rm_correction, +and var.equal arguments. The bias_correction argument is not affected. +}\if{html}{\out{
}}} + +\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap).} \item{R}{number of bootstrap replications (default = 1999).} +\item{output}{a character string specifying the output format: +- "htest": (default) Returns an object of class "htest" compatible with standard R output. +- "data.frame": Returns a data frame for backward compatibility.} + +\item{null.value}{a number or vector specifying the null hypothesis value(s) on the SMD scale: +- For standard alternatives: a single value (default = 0) +- For equivalence/minimal.effect: two values representing the lower and upper bounds} + +\item{alternative}{a character string specifying the alternative hypothesis: +- "none": (default) No hypothesis test is performed; only effect size and CI are returned. +- "two.sided": Test whether SMD differs from null.value +- "less": Test whether SMD is less than null.value +- "greater": Test whether SMD is greater than null.value +- "equivalence": Test whether SMD is between specified bounds +- "minimal.effect": Test whether SMD is outside specified bounds} + +\item{tr}{a numeric value specifying the proportion of observations to trim from each +tail when computing trimmed means and Winsorized variances (default = 0, no trimming). +Must be in the range [0, 0.5). Common choices are 0.1 (10\\% trimming) and 0.2 +(20\\% trimming). When tr > 0, the effect size uses trimmed means for the numerator +and the rescaled Winsorized standard deviation for the denominator, following +Algina, Keselman, and Penfield (2005). The rescaling ensures the robust effect +size equals Cohen's delta when data are normally distributed. +Note: tr > 0 is not compatible with denom = "rm".} + \item{y}{an optional (non-empty) numeric vector of data values.} \item{mu}{null value to adjust the calculation. If non-zero, the function calculates x-y-mu (default = 0).} @@ -70,7 +121,23 @@ boot_smd_calc( \item{na.action}{a function indicating what should happen when the data contain NAs.} } \value{ -A data frame containing the following information: +If \code{output = "htest"} (default), returns a list with class \code{"htest"} containing: +\itemize{ +\item estimate: The SMD estimate (Cohen's d, Hedges' g, or Glass's delta) +\item stderr: Standard error estimated from the bootstrap distribution +\item conf.int: Bootstrap confidence interval with conf.level attribute +\item alternative: A character string describing the alternative hypothesis +\item method: A character string indicating what type of test was performed +\item note: A character string describing the bootstrap CI method used +\item boot: The bootstrap distribution of SMD estimates +\item data.name: A character string giving the name(s) of the data +\item call: The matched call +\item statistic: z-statistic (only if alternative != "none") +\item p.value: Bootstrap p-value (only if alternative != "none") +\item null.value: The specified hypothesized value(s) (only if alternative != "none") +} + +If \code{output = "data.frame"}, returns a data frame containing: \itemize{ \item estimate: The SMD calculated from the original data \item bias: Estimated bias (difference between original estimate and median of bootstrap estimates) @@ -84,9 +151,8 @@ A data frame containing the following information: \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#maturing}{\figure{lifecycle-maturing.svg}{options: alt='[Maturing]'}}}{\strong{[Maturing]}} -Calculates standardized mean differences (SMDs) with bootstrap confidence intervals. -This function provides more robust confidence intervals for Cohen's d, Hedges' g, -and other SMD measures through resampling methods. +Calculates standardized mean differences (SMDs) with bootstrap confidence intervals, +with optional hypothesis testing. } \details{ This function calculates bootstrapped confidence intervals for standardized mean differences. @@ -102,13 +168,27 @@ The function implements the following bootstrap approach: \item Calculate confidence intervals using the specified method } -Three bootstrap confidence interval methods are available: +Four bootstrap confidence interval methods are available via the \code{boot_ci} argument: \itemize{ -\item \strong{Studentized bootstrap ("stud")}: Accounts for the variability in standard error estimates. Usually provides the most accurate coverage probability and is set as the default. -\item \strong{Basic bootstrap ("basic")}: Uses the empirical distribution of bootstrap estimates. Simple approach that works well for symmetric distributions. -\item \strong{Percentile bootstrap ("perc")}: Uses percentiles of the bootstrap distribution directly. More robust to skewness in the bootstrap distribution. +\item \strong{Studentized bootstrap ("stud")}: Uses the bootstrap distribution of pivotal +t-statistics to account for variability in standard error estimates. Usually +provides the most accurate coverage probability and is set as the default. +\item \strong{Basic bootstrap ("basic")}: Reflects the bootstrap distribution of estimates +around the observed value. Simple approach that works well for symmetric distributions. +\item \strong{Percentile bootstrap ("perc")}: Uses percentiles of the bootstrap distribution directly. +More robust to skewness in the bootstrap distribution. +\item \strong{Bias-corrected and accelerated ("bca")}: Corrects for both bias and skewness in the +bootstrap distribution using jackknife-based acceleration. Most accurate when the +bootstrap distribution is skewed, but computationally more expensive. } +When hypothesis testing is requested (i.e., \code{alternative} is not \code{"none"}), +the p-value is computed using the method that matches the selected \code{boot_ci}, +ensuring that p < alpha if and only if the corresponding confidence interval +excludes the null value (CI inversion principle). Previously, all bootstrap +CI methods used the studentized (pivot) p-value, which could produce p-values +inconsistent with non-studentized CIs. + The function supports various SMD variants: \itemize{ \item Classic standardized mean difference (bias_correction = FALSE) @@ -124,6 +204,12 @@ The function supports three study designs: \item Paired samples design: Standardizes the mean difference between paired observations } +The \code{denom} parameter provides a direct way to select the standardization denominator. +When \code{denom} is not "auto", it takes precedence over the \code{glass}, \code{rm_correction}, and +\code{var.equal} arguments, which are overridden as needed. A message is emitted if any +explicitly provided arguments are overridden. The \code{bias_correction} argument is always +respected regardless of \code{denom}. + For detailed information on calculation methods, see \code{vignette("SMD_calcs")}. } \section{Purpose}{ @@ -135,6 +221,7 @@ Use this function when: \item Sample sizes are small or standard error approximations may be unreliable \item You prefer resampling-based confidence intervals over parametric approximations \item You need to quantify uncertainty in SMD estimates more accurately +\item You want to test hypotheses about effect size magnitudes using bootstrap methods } } @@ -180,11 +267,35 @@ result <- boot_smd_calc(x = control, boot_ci = "stud", R = 999) +# Example 5: Two-sided hypothesis test +result <- boot_smd_calc(x = group1, y = group2, + alternative = "two.sided", + null.value = 0, + R = 999) + +# Example 6: Equivalence test with bootstrap +result <- boot_smd_calc(x = group1, y = group2, + alternative = "equivalence", + null.value = c(-0.5, 0.5), + R = 999) + +# Example 7: Legacy data.frame output +result <- boot_smd_calc(x = group1, y = group2, + output = "data.frame", + R = 999) + +} +\references{ +Algina, J., Keselman, H. J., & Penfield, R. D. (2005). An alternative to Cohen's +standardized mean difference effect size: A robust parameter and confidence interval +in the two independent groups case. \emph{Psychological Methods}, \emph{10}(3), 317-328. } \seealso{ Other effect sizes: \code{\link{boot_ses_calc}()}, +\code{\link{rank_diff}()}, \code{\link{ses_calc}()}, -\code{\link{smd_calc}()} +\code{\link{smd_calc}()}, +\code{\link{trans_rank_prob}()} } \concept{effect sizes} diff --git a/man/boot_t_TOST.Rd b/man/boot_t_TOST.Rd index 7fe74e9..f644ee8 100644 --- a/man/boot_t_TOST.Rd +++ b/man/boot_t_TOST.Rd @@ -24,7 +24,7 @@ boot_t_TOST(x, ...) glass = NULL, mu = 0, R = 1999, - boot_ci = c("stud", "basic", "perc"), + boot_ci = c("stud", "basic", "perc", "bca"), ... ) @@ -63,7 +63,7 @@ boot_t_TOST(x, ...) \item{R}{number of bootstrap replications (default = 1999).} -\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), or "perc" (percentile bootstrap).} +\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap).} \item{formula}{a formula of the form lhs ~ rhs where lhs is a numeric variable giving the data values and rhs either 1 for a one-sample test or a factor with two levels giving the corresponding groups. For paired tests, use the default method with x and y vectors instead of the formula method.} @@ -105,16 +105,31 @@ The bootstrap procedure follows these steps: \itemize{ \item Resample with replacement from the original data to create R bootstrap samples \item For each bootstrap sample, calculate test statistics and effect sizes -\item Use the distribution of bootstrap results to compute p-values and confidence intervals -\item Combine results using the specified bootstrap confidence interval method +\item Compute p-values and confidence intervals using the selected bootstrap method } +\subsection{Bootstrap Confidence Interval Methods}{ -Three types of bootstrap confidence intervals are available: +Four types of bootstrap confidence intervals are available via the \code{boot_ci} argument: \itemize{ -\item Studentized ("stud"): Accounts for the variability in the standard error estimate -\item Basic/Empirical ("basic"): Uses the empirical distribution of bootstrap estimates -\item Percentile ("perc"): Uses percentiles of the bootstrap distribution +\item \strong{Studentized ("stud")}: Uses the bootstrap distribution of pivotal t-statistics +to account for variability in standard error estimates. This is the default +and usually provides the most accurate coverage. +\item \strong{Basic/Empirical ("basic")}: Reflects the bootstrap distribution of estimates +around the observed value. +\item \strong{Percentile ("perc")}: Uses percentiles of the bootstrap distribution directly. +\item \strong{Bias-corrected and accelerated ("bca")}: Corrects for both bias and skewness +in the bootstrap distribution using jackknife-based acceleration. } +} + +\subsection{Bootstrap P-values}{ + +The p-value for each test (two-tailed and both one-sided) is computed using +the method that matches the selected \code{boot_ci}, ensuring that p < alpha if and +only if the corresponding confidence interval excludes the null value +(CI inversion principle). Previously, all bootstrap CI methods used the +studentized (pivot) p-value, which could produce p-values inconsistent with +non-studentized CIs. For two-sample tests, the test is of \eqn{\bar x - \bar y} (mean of x minus mean of y). For paired samples, the test is of the difference scores (z), @@ -123,6 +138,7 @@ For one-sample tests, the test is of \eqn{\bar x} (mean of x). For details on the calculations in this function see \code{vignette("robustTOST")}. } +} \section{Purpose}{ Use this function when: @@ -173,6 +189,7 @@ Efron, B., & Tibshirani, R. J. (1994). An introduction to the bootstrap. CRC pre \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, \code{\link{hodges_lehmann}()}, diff --git a/man/boot_t_test.Rd b/man/boot_t_test.Rd index 56afa30..2417fd3 100644 --- a/man/boot_t_test.Rd +++ b/man/boot_t_test.Rd @@ -16,7 +16,8 @@ boot_t_test(x, ...) alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), mu = 0, alpha = 0.05, - boot_ci = c("stud", "basic", "perc"), + tr = 0, + boot_ci = c("stud", "basic", "perc", "bca"), R = 1999, ... ) @@ -47,7 +48,12 @@ boot_t_test(x, ...) \item{alpha}{alpha level (default = 0.05)} -\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), or "perc" (percentile bootstrap).} +\item{tr}{the fraction (0 to 0.5) of observations to be trimmed from +each end before computing the mean and winsorized variance. +Default is 0 (no trimming). When tr > 0, the function performs +a bootstrapped Yuen's trimmed t-test.} + +\item{boot_ci}{method for bootstrap confidence interval calculation: "stud" (studentized, default), "basic" (basic bootstrap), "bca" (bias-corrected and accelerated), or "perc" (percentile bootstrap).} \item{R}{number of bootstrap replications (default = 1999).} @@ -80,7 +86,8 @@ distribution, not from this statistic and the degrees of freedom). \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -Performs t-tests with bootstrapped p-values and confidence intervals. This function supports +Performs t-tests with bootstrapped p-values and confidence intervals, with optional +trimmed means (Yuen's approach) for robust inference. This function supports standard hypothesis testing alternatives as well as equivalence and minimal effect testing, all with the familiar \code{htest} output structure. } @@ -97,19 +104,35 @@ The bootstrap procedure follows these steps: \item Compute the p-value by comparing the original test statistic to the bootstrap distribution \item Calculate confidence intervals using the specified bootstrap method } +\subsection{Bootstrap Confidence Interval Methods}{ -Three bootstrap confidence interval methods are available: +Four bootstrap confidence interval methods are available via the \code{boot_ci} argument: \itemize{ -\item \emph{Studentized bootstrap ("stud")}: Accounts for the variability in standard error estimates -\item \emph{Basic bootstrap ("basic")}: Uses the empirical distribution of bootstrap estimates -\item \emph{Percentile bootstrap ("perc")}: Uses percentiles of the bootstrap distribution directly +\item \strong{Studentized bootstrap ("stud")}: Uses the bootstrap distribution of pivotal +t-statistics to account for variability in standard error estimates. This is the +default and usually provides the most accurate coverage. +\item \strong{Basic bootstrap ("basic")}: Reflects the bootstrap distribution of estimates +around the observed value. +\item \strong{Percentile bootstrap ("perc")}: Uses percentiles of the bootstrap distribution directly. +\item \strong{Bias-corrected and accelerated ("bca")}: Corrects for both bias and skewness in the +bootstrap distribution using jackknife-based acceleration. Most accurate when the +bootstrap distribution is skewed, but computationally more expensive. +} } +\subsection{Bootstrap P-values}{ + +The p-value is computed using the method that matches the selected \code{boot_ci}, +ensuring that p < alpha if and only if the corresponding confidence interval +excludes the null value (CI inversion principle). Previously, all bootstrap +CI methods used the studentized (pivot) p-value, which could produce p-values +inconsistent with non-studentized CIs. + For different alternatives, the p-values are calculated as follows: \itemize{ -\item "two.sided": Proportion of bootstrap statistics at least as extreme as the observed statistic (in either direction), multiplied by 2 -\item "less": Proportion of bootstrap statistics less than or equal to the observed statistic -\item "greater": Proportion of bootstrap statistics greater than or equal to the observed statistic +\item "two.sided": Two-tailed p-value from the bootstrap distribution +\item "less": One-sided p-value for the hypothesis that the true value is less than the null +\item "greater": One-sided p-value for the hypothesis that the true value is greater than the null \item "equivalence": Maximum of two one-sided p-values (for lower and upper bounds) \item "minimal.effect": Minimum of two one-sided p-values (for lower and upper bounds) } @@ -119,11 +142,19 @@ For paired samples, the test is of the difference scores (z), wherein \eqn{z = x - y}, and the test is of \eqn{\bar z} (mean of the difference scores). For one-sample tests, the test is of \eqn{\bar x} (mean of x). +When \code{tr > 0}, the function uses Yuen's trimmed t-test approach: trimmed means +are computed by removing the fraction \code{tr} of observations from each tail, +and winsorized variances are used in place of standard variances. This provides +robustness against outliers and heavy-tailed distributions. The bootstrap +procedure recomputes trimmed means and winsorized standard errors for each +bootstrap replicate. + Unlike the \code{t_TOST} function, this function returns a standard \code{htest} object for compatibility with other R functions, while still providing the benefits of bootstrapping. For detailed information on calculation methods, see \code{vignette("robustTOST")}. } +} \section{Purpose}{ Use this function when: @@ -173,13 +204,20 @@ boot_t_test(mpg ~ am, data = mtcars, mu = c(-3, 3), R = 999) +# Example 6: Bootstrapped Yuen's trimmed t-test (10\% trimming) +boot_t_test(extra ~ group, data = sleep, tr = 0.1, R = 999) + } \references{ Efron, B., & Tibshirani, R. J. (1994). An introduction to the bootstrap. CRC press. + +Yuen, K. K. (1974). The two-sample trimmed t for unequal population variances. +Biometrika, 61(1), 165-170. } \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{brunner_munzel}()}, \code{\link{hodges_lehmann}()}, diff --git a/man/brunner_munzel.Rd b/man/brunner_munzel.Rd index cc73dbb..e4ef2cf 100644 --- a/man/brunner_munzel.Rd +++ b/man/brunner_munzel.Rd @@ -13,6 +13,7 @@ alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), mu = 0.5, alpha = 0.05, + scale = c("probability", "difference", "logodds", "odds"), test_method = c("t", "logit", "perm"), R = 10000, p_method = NULL, @@ -45,10 +46,29 @@ representing the hypothesized relative effect (default = 0.5, i.e., stochastic equality). \item For "equivalence" or "minimal.effect": two values representing the lower and upper bounds for the relative effect. Values must be between 0 and 1. -}} +} + +Note: \code{mu} is always specified on the probability scale regardless of the \code{scale} argument. +The \code{scale} argument only affects how results are reported; it does not change the hypothesis +being tested.} \item{alpha}{alpha level (default = 0.05)} +\item{scale}{a character string specifying the scale for the reported estimate, +standard error, confidence interval, and null value. The test itself always operates +on the probability scale internally; this argument only transforms the output. + +\describe{ +\item{"probability"}{(default): \eqn{p = P(X > Y) + 0.5 \cdot P(X = Y)}, range \eqn{[0, 1]}, +null at stochastic equality = 0.5} +\item{"difference"}{\eqn{P(X > Y) - P(X < Y) = 2p - 1}, range \eqn{[-1, 1]}, +null = 0} +\item{"logodds"}{\eqn{\log[p / (1 - p)]}, range \eqn{(-\infty, \infty)}, +null = 0} +\item{"odds"}{\eqn{p / (1 - p)}, range \eqn{(0, \infty)}, +null = 1} +}} + \item{test_method}{a character string specifying the test method to use: \itemize{ \item "t" (default): approximate t-distribution with Satterthwaite-Welch degrees of freedom @@ -102,7 +122,7 @@ A list with class \code{"htest"} containing the following components: \description{ \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#maturing}{\figure{lifecycle-maturing.svg}{options: alt='[Maturing]'}}}{\strong{[Maturing]}} -This is a generic function that performs a generalized asymptotic Brunner-Munzel test in a fashion similar to \link{t.test}. +This is a generic function that performs a generalized Brunner-Munzel test in a fashion similar to \link{t.test}. } \details{ This function is made to provide a test of stochastic equality between two samples (paired or independent), and is referred to as the Brunner-Munzel test. @@ -128,7 +148,11 @@ that are guaranteed to stay within \verb{[0, 1]}. This method is recommended whe relative effect is close to 0 or 1. \item "perm": A studentized permutation test following Neubert & Brunner (2007). This method is highly recommended when sample sizes are small (< 15 per group) as it provides better -control of Type I error rates in these situations. +control of Type I error rates in these situations. Note: when exact permutations are +enumerated with small or heavily tied samples, the exact p-value method (\code{b/R}) may +return p = 0 if no permuted test statistic is as extreme as the observed value. The +\code{plusone} method (\code{(b+1)/(R+1)}) avoids this artifact and can be selected via +\code{p_method = "plusone"}. } } @@ -196,6 +220,17 @@ the permuted test statistics at 0.5 (the value implied by exchangeability), whil test statistic is centered at the hypothesized null value. This approach is valid because the studentized permutation distribution converges to the same limit regardless of the centering, following the asymptotic theory of Janssen (1997) and Neubert & Brunner (2007). + +Because the equivalence bounds are specified directly on the relative effect +scale (i.e., as probabilities between 0 and 1), this avoids the difficulty +noted by Arboretti et al. (2021, point IU.7) that arises when margins must +be expressed in terms of rank transformations. + +These are uncalibrated (naive) procedures. For the IU direction +(\code{"equivalence"}), the procedure can be conservative when sample sizes are +small or when the equivalence bounds are close to 0.5. For the UI direction +(\code{"minimal.effect"}), the conservatism is less pronounced. See Arboretti +et al. (2021) for a detailed discussion of calibration } } \examples{ @@ -225,8 +260,17 @@ brunner_munzel(mpg ~ am, data = mtcars, mu = c(0.35, 0.65), test_method = "perm") +# Report on the difference scale: P(X>Y) - P(X= max_perms} (the maximum number of possible permutations), exact permutation -is computed. Otherwise, Monte Carlo (permutation with replacement; i.e., randomization testing) sampling is used.} +is computed. Otherwise, Monte Carlo (permutation with replacement; i.e., randomization +testing) sampling is used. Note: permutation tests are not supported for +\code{alternative = "equivalence"} or \code{alternative = "minimal.effect"} (see Details).} \item{scale}{the scale estimator for standardizing the test statistic in permutation tests. Options are: @@ -131,7 +133,7 @@ This estimator is consistent with the location shift estimate returned by \subsection{Test Methods}{ -\strong{Asymptotic test (R = NULL):} Uses kernel density estimation to estimate the +\strong{Asymptotic test (R = NULL):} Uses kernel density estimation (Fried & Dehling, 2011) to estimate the variance of the Hodges-Lehmann estimator (note: this generates confidence intervals that will differ from \code{\link[stats:wilcox.test]{stats::wilcox.test()}}). The test statistic follows an approximate normal distribution. This method may have issues with very heavy-tailed distributions, very skewed distributions, or small sample sizes (n < 30 per group). In these cases, @@ -161,6 +163,36 @@ estimator (Fried & Dehling, 2011): where Z is the median-corrected combined sample. } +\subsection{Permutation Tests with Non-Zero Null Values}{ + +For standard alternatives (\code{two.sided}, \code{less}, \code{greater}) with \code{mu != 0}, +the permutation test uses an approximate approach: the observed test statistic +is centered at \code{mu}, but the permutation distribution is generated under +exchangeability (effectively \code{mu = 0}). Because the Hodges-Lehmann statistic +divided by the S1/S2 scale estimator is not a true pivot, this comparison is +approximate rather than exact. The approximation is generally adequate when +\code{mu} is moderate relative to the scale of the data, but may lose accuracy for +extreme null values. For the two-sample case, the scale estimator is +recomputed for each permutation, which partially mitigates this issue. +} + +\subsection{Equivalence and Minimal Effect Testing}{ + +Equivalence and minimal effect tests are only available with the asymptotic +method (\code{R = NULL}). Permutation tests are not supported for these +alternatives because the scale estimators (S1, S2) from Fried & Dehling +(2011) do not produce a pivotal test statistic for the Hodges-Lehmann +estimator. Without pivotality, the permutation distribution generated under +the exchangeability null is not a valid reference distribution for testing +at the equivalence bounds, and the resulting p-values can be unreliable. +This limitation compounds with the inherent conservatism of the naive +intersection-union procedure, potentially yielding substantial power loss. + +The asymptotic method uses kernel density estimation to approximate the +standard error, which provides a proper pivot and valid boundary-null +inference. +} + \subsection{Alternatives}{ The function supports five alternative hypotheses: @@ -178,12 +210,11 @@ specified by \code{mu} \section{Purpose}{ The Hodges-Lehmann estimator provides a robust alternative to the mean for testing -location differences. It has a breakdown point of approximately 29.3\%, meaning it -remains stable even when nearly 30\% of the data are outliers. This function offers: +location differences. It is arguably a more stable option in the presence of outliers. This function offers: \itemize{ \item Exact permutation tests for small samples \item Randomization tests (permutation with replacement) for larger samples -\item Asymptotic tests using kernel density estimation +\item Asymptotic tests using kernel density estimation of the scale parameter \item Support for equivalence and minimal effect testing \item An interface that mirrors \code{wilcox.test} and \code{perm_t_test} } @@ -208,8 +239,8 @@ before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8) after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) hodges_lehmann(before, after, paired = TRUE) -# Equivalence test -hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1), R = 999) +# Equivalence test (asymptotic only) +hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1)) # Formula interface hodges_lehmann(extra ~ group, data = sleep) @@ -232,6 +263,7 @@ calculating exact P-values when permutations are randomly drawn. \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, diff --git a/man/log_TOST.Rd b/man/log_TOST.Rd index 8616571..116fdae 100644 --- a/man/log_TOST.Rd +++ b/man/log_TOST.Rd @@ -110,6 +110,7 @@ https://www.fda.gov/regulatory-information/search-fda-guidance-documents/bioavai \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, diff --git a/man/perm_t_test.Rd b/man/perm_t_test.Rd index 51c7e2b..79beae8 100644 --- a/man/perm_t_test.Rd +++ b/man/perm_t_test.Rd @@ -171,6 +171,42 @@ For one-sample tests, the test is of \eqn{\bar x} (mean of x). If the number of possible permutations is less than R, all exact permutations are computed and a message is printed to the console. +\subsection{Permutation Approach to Equivalence and Minimal Effect Testing}{ + +When \code{alternative = "equivalence"} or \code{alternative = "minimal.effect"}, the +function performs two one-sided permutation tests and combines them following +the nonparametric combination (NPC) framework of Arboretti, Pesarin, and +Salmaso (2021). + +The \code{"equivalence"} alternative implements the \strong{intersection-union (IU)} +approach: the null hypothesis is non-equivalence and the alternative is +equivalence. Two one-sided p-values are computed and the global p-value is +their maximum. The \code{"minimal.effect"} alternative implements the +\strong{union-intersection (UI)} approach: the null hypothesis is equivalence and +the alternative is non-equivalence. The global p-value is the minimum of the +two one-sided p-values. Both partial tests are evaluated against the same +permutation distribution (i.e., the same set of permuted samples), which +preserves the negative dependence between the two test statistics as required +by the NPC theory. + +The permutation distribution is constructed under the exchangeability null +(i.e., by permuting the unshifted data), while the observed test statistics +are centered at the equivalence bounds. This differs from the shifted-data +algorithm described in Arboretti et al. (2021), which permutes margin-shifted +pooled samples. Under the default studentized permutation approach +(\code{perm_se = TRUE}), the two methods are asymptotically equivalent +(Janssen, 1997; Chung & Romano, 2013). The exchangeability-based approach +avoids the computational cost of constructing and permuting two separate +shifted datasets. + +Note that these are \emph{uncalibrated} (naive) procedures in the terminology of +Arboretti et al. (2021). For the IU direction (\code{"equivalence"}), the naive +approach can be conservative when sample sizes or equivalence margins are +small relative to the variability in the data. For the UI direction +(\code{"minimal.effect"}), the impact of not calibrating is smaller because the +calibrated critical value lies in the narrower interval +\eqn{[\alpha/2, \alpha]} rather than \eqn{[\alpha, (1+\alpha)/2)}. +} } \section{Purpose}{ @@ -232,6 +268,9 @@ perm_t_test(x = before, y = after, } \references{ +Arboretti, R., Pesarin, F. & Salmaso, L. (2021). A unified approach to permutation testing for equivalence. +Stat Methods Appl 30, 1033-1052. doi: 10.1007/s10260-020-00548-0 + Efron, B., & Tibshirani, R. J. (1993). An Introduction to the Bootstrap. Chapman and Hall/CRC. Janssen, A. (1997). Studentized permutation tests for non-i.i.d. hypotheses and the @@ -250,6 +289,7 @@ Statistical Applications in Genetics and Molecular Biology, 9(1), Article 39. \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, diff --git a/man/rank_diff.Rd b/man/rank_diff.Rd new file mode 100644 index 0000000..07a6cc3 --- /dev/null +++ b/man/rank_diff.Rd @@ -0,0 +1,99 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rank_diff.R +\name{rank_diff} +\alias{rank_diff} +\title{Rank Difference Transformation for Paired Data} +\usage{ +rank_diff(x, y, names = c("x", "y")) +} +\arguments{ +\item{x}{numeric vector of observations from condition 1.} + +\item{y}{numeric vector of observations from condition 2, same length as x. +Pairs are defined positionally: \code{x[i]} is paired with \code{y[i]}.} + +\item{names}{optional character vector of length 2 giving column names for +the returned data frame. Default is \code{c("x", "y")}.} +} +\value{ +A data frame with two columns (named by \code{names}) containing +the joint ranks for condition 1 and condition 2, respectively. The number +of rows equals the number of complete pairs. Missing-value pairs (where +either \code{x[i]} or \code{y[i]} is \code{NA}) are removed before +ranking, and a message is printed if any pairs are dropped. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Applies the Kornbrot (1990) rank difference transformation to paired data. +All 2n observations are jointly ranked using midranks for ties, and the +ranks corresponding to each condition are returned. The transformed data +can then be passed to \code{\link[=ses_calc]{ses_calc()}} or \code{\link[=boot_ses_calc]{boot_ses_calc()}} +for effect size estimation that is invariant under monotone transformations +of the original scale. +} +\details{ +The standard Wilcoxon signed-rank procedure for paired data computes +differences \eqn{d_i = x_i - y_i}, then ranks the absolute values +\eqn{|d_i|}. This is meaningful only when the differences themselves are +on an interval scale (i.e., when it makes sense to say that one difference +is "larger" than another). + +For purely ordinal data, the differences may not be rankable. The Kornbrot +(1990) rank difference procedure addresses this by: +\enumerate{ +\item Pooling all 2n observations from both conditions into a single vector. +\item Ranking the pooled vector using standard midranks for ties. +\item Returning the ranks corresponding to each condition. +} + +The resulting rank differences \eqn{R(x_i) - R(y_i)} are then suitable +for paired signed-rank effect size computation. Because the transformation +uses only the ordinal information in the data, the effect size is invariant +under any monotone (order-preserving) transformation of the original scale. +\subsection{Usage with ses_calc}{ + +Pass the transformed columns directly to \code{ses_calc(..., paired = TRUE)}: + +\preformatted{ + rd <- rank_diff(x, y) + ses_calc(x = rd$x, y = rd$y, paired = TRUE, ses = "rb") +} + +Because \code{mu} has no meaningful interpretation on the joint-rank scale, +always use \code{mu = 0} (the default) when analysing rank-difference data. +} +} +\examples{ +# Kornbrot (1990) Tables 1-2: time vs rate give different +# standard Wilcoxon results but identical rank difference results +time_plac <- c(4.6, 4.3, 6.7, 5.8, 5.0, 4.2, 6.0, + 2.0, 2.6, 10.0, 3.4, 7.1, 8.6) +time_drug <- c(2.9, 2.8, 12.0, 3.8, 5.9, 6.5, 3.3, + 2.3, 2.1, 14.3, 2.4, 14.0, 4.9) + +# Standard approach: different results for time vs rate +ses_calc(time_plac, time_drug, paired = TRUE, ses = "rb") +ses_calc(60 / time_plac, 60 / time_drug, paired = TRUE, ses = "rb") + +# Rank difference approach: identical results +rd_time <- rank_diff(time_plac, time_drug) +rd_rate <- rank_diff(60 / time_plac, 60 / time_drug) +ses_calc(rd_time$x, rd_time$y, paired = TRUE, ses = "rb") +ses_calc(rd_rate$x, rd_rate$y, paired = TRUE, ses = "rb") + +} +\references{ +Kornbrot, D. E. (1990). The rank difference test: A new and meaningful +alternative to the Wilcoxon signed ranks test for ordinal data. +\emph{British Journal of Mathematical and Statistical Psychology}, 43, 241-264. +} +\seealso{ +Other effect sizes: +\code{\link{boot_ses_calc}()}, +\code{\link{boot_smd_calc}()}, +\code{\link{ses_calc}()}, +\code{\link{smd_calc}()}, +\code{\link{trans_rank_prob}()} +} +\concept{effect sizes} diff --git a/man/ses_calc.Rd b/man/ses_calc.Rd index b01c9aa..9add151 100644 --- a/man/ses_calc.Rd +++ b/man/ses_calc.Rd @@ -12,7 +12,8 @@ ses_calc( paired = FALSE, ses = "rb", alpha = 0.05, - se_method = c("agresti", "fisher"), + se_method = c("score", "agresti", "fisher"), + correct = FALSE, output = c("htest", "data.frame"), null.value = NULL, alternative = c("none", "two.sided", "less", "greater", "equivalence", @@ -26,7 +27,8 @@ ses_calc( ses = c("rb", "odds", "logodds", "cstat"), alpha = 0.05, mu = 0, - se_method = c("agresti", "fisher"), + se_method = c("score", "agresti", "fisher"), + correct = FALSE, output = c("htest", "data.frame"), null.value = NULL, alternative = c("none", "two.sided", "less", "greater", "equivalence", @@ -53,12 +55,35 @@ ses_calc( \item{se_method}{a character string specifying the method for computing standard errors and confidence intervals: -- "agresti": (default) Uses the Agresti/Lehmann placement-based variance estimation with +- "score": (default) Uses a score-type approach where confidence intervals are +constructed by test inversion (finding the values of the concordance +probability where the score statistic equals the critical value), then +transformed to the requested effect size scale. This method has +better small-sample coverage than the Wald-based methods and +produces confidence intervals that are coherent with the corresponding +rank-based test. Available for all designs. +For two-sample independent designs, uses the Fay-Malinovsky approach +based on the proportional odds model (see Fay and Malinovsky, 2018). +For paired/one-sample designs, uses a Wilson score approach based on +the independent-signs model for the signed-rank statistic, producing +p-values that match \code{wilcox.test(..., paired = TRUE, exact = FALSE)} +at the standard null of 0.5. +- "agresti": Uses the Agresti/Lehmann placement-based variance estimation with confidence intervals computed on the log-odds scale and back-transformed. This method -has better asymptotic properties and faster convergence to normality. +has better asymptotic properties and faster convergence to normality. Available for +all designs (one-sample, paired, and two-sample independent). +However, this method can produce degenerate intervals at the boundaries +(when all pairwise comparisons favor one group), +in which case a Haldane-type shrinkage correction is applied to enable interval construction. - "fisher": Uses the legacy Fisher z-transformation method for confidence intervals. This method is retained for backward compatibility.} +\item{correct}{logical; whether to apply a continuity correction to the +test statistic and confidence interval. When \code{se_method = "score"}, +setting \code{correct = TRUE} produces p-values that match +\code{wilcox.test(..., exact = FALSE, correct = TRUE)}. +Default is \code{FALSE}. Only used with \code{se_method = "score"}.} + \item{output}{a character string specifying the output format: - "htest": (default) Returns an object of class "htest" compatible with standard R output. - "data.frame": Returns a data frame with effect size estimates and confidence intervals.} @@ -146,7 +171,7 @@ as the common language effect size or the area under the ROC curve. Values range } \subsection{Standard Error Methods}{ -Two methods are available for computing standard errors and confidence intervals: +Three methods are available for computing standard errors and confidence intervals: \itemize{ \item \strong{Agresti method} (\code{se_method = "agresti"}): This method computes the variance of the concordance probability \eqn{\hat{p} = \Pr(X > Y)} using the Lehmann/Agresti placement-based @@ -174,32 +199,65 @@ Standard errors for other effect size scales are obtained via the delta method. Confidence intervals are constructed on the log-odds scale and back-transformed to the requested effect size scale. This ensures that intervals respect the natural bounds of each measure (e.g., \eqn{[0, 1]} for cstat, \eqn{[-1, 1]} for rb). +\item \strong{Score method} (\code{se_method = "score"}): Uses a score-type approach where the variance +is evaluated at the candidate parameter value, not the estimate. Confidence intervals are +constructed via test inversion: finding the values of \eqn{\phi} (concordance probability) +where the score statistic equals the critical value. This method has better small-sample +coverage than Wald-type methods and guarantees CI/p-value coherence for equivalence testing. + +For \strong{two-sample independent} designs, uses the Fay-Malinovsky V_LAPH variance function +from the proportional odds model. The reported SE is descriptive (from V_LAPH at +\eqn{\hat{\phi}}), and the CI comes from root-finding. + +For \strong{paired/one-sample} designs, uses a Wilson score approach based on the independent +signs model. Under this model, each pair's sign is Bernoulli(\eqn{\pi}) independent of rank, +giving \eqn{T^+} known mean \eqn{\pi S} and variance \eqn{\pi(1-\pi)Q}, where +\eqn{S = N(N+1)/2} and \eqn{Q = \sum r_i^2}. The CI has a closed-form Wilson-score +solution (no root-finding needed). At \eqn{\pi_0 = 0.5}, the score test reproduces the +Wilcoxon signed-rank z exactly. + +The reported standard error is descriptive, but the confidence interval is \strong{not} computed +as estimate ± z × SE. Instead, it comes from test inversion. + +When \code{correct = TRUE}, a continuity correction is applied that makes p-values match +\code{wilcox.test(..., exact = FALSE, correct = TRUE)}. \item \strong{Fisher method} (\code{se_method = "fisher"}): This legacy method uses Fisher's z-transformation (arctanh) for the rank-biserial correlation. Confidence intervals for other effect sizes are obtained by simple transformation of the rank-biserial CI bounds. } } -\subsection{Continuity Correction for Boundary Cases}{ - -When there is complete separation between groups (i.e., all observations in one group exceed all -observations in the other), the concordance probability \eqn{\hat{p}} equals exactly 0 or 1. -This leads to undefined odds (0 or \eqn{\infty}) and log-odds (\eqn{-\infty} or \eqn{\infty}). - -In this case, a continuity correction is applied (for \code{se_method = "agresti"} only): -\itemize{ -\item \strong{Two-sample}: \eqn{\hat{p}} is corrected to \eqn{0.5 / (n_1 \cdot n_2)} or -\eqn{1 - 0.5 / (n_1 \cdot n_2)}, where \eqn{n_1 \cdot n_2} is the total number of pairwise -comparisons. -\item \strong{Paired/one-sample}: \eqn{\hat{p}} is corrected to \eqn{0.5 / S} or \eqn{1 - 0.5 / S}, -where \eqn{S = N(N+1)/2} is the maximum possible Wilcoxon signed-rank statistic and \eqn{N} -is the number of non-zero differences. -} - -A message is printed when this correction is applied. Point estimates and hypothesis tests -should be interpreted as approximate in these cases. For bootstrap inference with complete -separation, see \code{\link[=boot_ses_calc]{boot_ses_calc()}}, which will detect this condition and stop with an -informative error. +\subsection{Boundary Case Handling (Complete Separation)}{ + +When there is complete separation between groups (i.e., all pairwise comparisons favor +one group), the concordance probability \eqn{\hat{p}} equals exactly 0 or 1. +This leads to undefined odds and log-odds, and a degenerate (zero) placement-based +variance. + +For \code{se_method = "agresti"}, a Haldane-type shrinkage correction is applied: +\deqn{\tilde{p} = \frac{C + 0.5}{N_{\mathrm{pairs}} + 1}} +where \eqn{C} is the concordance count and \eqn{N_{\mathrm{pairs}}} is the total +number of pairwise comparisons (\eqn{n_1 n_2} for two-sample designs, or +\eqn{N(N+1)/2} for paired/one-sample designs where \eqn{N} is the number of +non-zero differences). This corresponds to the posterior mean under a Jeffreys +Beta(0.5, 0.5) prior and shrinks the estimate toward 0.5, with stronger shrinkage +for smaller samples. + +The Agresti placement variance is then evaluated at the corrected estimate. A message +is printed when this correction is applied. For more reliable inference at boundaries, +consider \code{se_method = "score"} for score-type intervals that handle +boundaries naturally without correction. + +For \code{se_method = "score"}, no correction is needed. The score-type +CI is constructed via test inversion, where the variance function is +evaluated at candidate parameter values in the interior of (0, 1). When +\eqn{\hat{p} = 1}, the upper CI bound is trivially 1 and the lower bound is found +by the score inversion. No modification of the point estimate is required. +This applies to both two-sample (via root-finding) and paired/one-sample +(via the closed-form Wilson quadratic) designs. + +For two-sample designs using the Agresti method, a score-type CI is automatically +used as a fallback at boundaries for better interval coverage. } \subsection{Hypothesis Testing}{ @@ -283,6 +341,13 @@ ses_calc(x = group1, y = group2, ses = "rb", output = "data.frame") # Example 6: Using Fisher method for backward compatibility ses_calc(x = group1, y = group2, ses = "rb", se_method = "fisher") +# Example 7: Using score method for WMW-compatible CIs (two-sample only) +ses_calc(x = group1, y = group2, ses = "cstat", se_method = "score") + +# Example 8: Score method with continuity correction (matches wilcox.test) +ses_calc(x = group1, y = group2, ses = "cstat", se_method = "score", + correct = TRUE, alternative = "two.sided", null.value = 0.5) + } \references{ Agresti, A. (1980). Generalized odds ratios for ordinal data. \emph{Biometrics}, 36, 59-67. @@ -290,6 +355,10 @@ Agresti, A. (1980). Generalized odds ratios for ordinal data. \emph{Biometrics}, Bamber, D. (1975). The area above the ordinal dominance graph and the area below the receiver operating characteristic graph. \emph{Journal of Mathematical Psychology}, 12, 387-415. +Fay, M.P. and Malinovsky, Y. (2018). Confidence Intervals of the Mann-Whitney Parameter +that are Compatible with the Wilcoxon-Mann-Whitney Test. \emph{Statistics in Medicine}, +37, 3991-4006. \doi{10.1002/sim.7890} + Kerby, D. S. (2014). The simple difference formula: An approach to teaching nonparametric correlation. \emph{Comprehensive Psychology}, 3, 11-IT. @@ -302,6 +371,8 @@ test and a simple odds statistic. \emph{SUGI 31 Proceedings}, Paper 209-31. Other effect sizes: \code{\link{boot_ses_calc}()}, \code{\link{boot_smd_calc}()}, -\code{\link{smd_calc}()} +\code{\link{rank_diff}()}, +\code{\link{smd_calc}()}, +\code{\link{trans_rank_prob}()} } \concept{effect sizes} diff --git a/man/smd_calc.Rd b/man/smd_calc.Rd index 4fbf000..19e312a 100644 --- a/man/smd_calc.Rd +++ b/man/smd_calc.Rd @@ -15,7 +15,14 @@ smd_calc( bias_correction = TRUE, rm_correction = FALSE, glass = NULL, - smd_ci = c("nct", "goulet", "t", "z") + denom = c("auto", "z", "rm", "pooled", "avg", "glass1", "glass2"), + smd_ci = c("nct", "goulet", "t", "z"), + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), + test_method = c("z", "t"), + tr = 0 ) \method{smd_calc}{default}( @@ -28,7 +35,14 @@ smd_calc( bias_correction = TRUE, rm_correction = FALSE, glass = NULL, + denom = c("auto", "z", "rm", "pooled", "avg", "glass1", "glass2"), smd_ci = c("nct", "goulet", "t", "z"), + output = c("htest", "data.frame"), + null.value = 0, + alternative = c("none", "two.sided", "less", "greater", "equivalence", + "minimal.effect"), + test_method = c("z", "t"), + tr = 0, ... ) @@ -51,8 +65,51 @@ smd_calc( \item{glass}{An option to calculate Glass's delta as an alternative to Cohen's d type SMD. Default is NULL to not calculate Glass's delta, 'glass1' will use the first group's SD as the denominator whereas 'glass2' will use the 2nd group's SD.} +\item{denom}{a character string specifying the denominator for standardization: +- "auto": (default) Uses the standard denominator based on design and other arguments +(glass, rm_correction, var.equal). +- "z": SD of differences (Cohen's d_z). Valid for paired and one-sample designs. +- "rm": Repeated-measures corrected (Cohen's d_rm). Valid for paired designs only. +- "pooled": Pooled SD (Cohen's d_s). Valid for independent samples only. +- "avg": Root-mean-square SD (Cohen's d_av). Valid for independent samples only. +- "glass1": First group's (x) SD (Glass's delta). Valid for paired and independent designs. +- "glass2": Second group's (y) SD (Glass's delta). Valid for paired and independent designs. + +\if{html}{\out{
}}\preformatted{When set to any value other than "auto", this overrides the glass, rm_correction, +and var.equal arguments. The bias_correction argument is not affected. +}\if{html}{\out{
}}} + \item{smd_ci}{Method for calculating SMD confidence intervals. Methods include 'goulet', 'noncentral t' (nct), 'central t' (t), and 'normal method' (z).} +\item{output}{a character string specifying the output format: +- "htest": (default) Returns an object of class "htest" compatible with standard R output. +- "data.frame": Returns a data frame for backward compatibility.} + +\item{null.value}{a number or vector specifying the null hypothesis value(s) on the SMD scale: +- For standard alternatives: a single value (default = 0) +- For equivalence/minimal.effect: two values representing the lower and upper bounds} + +\item{alternative}{a character string specifying the alternative hypothesis: +- "none": (default) No hypothesis test is performed; only effect size and CI are returned. +- "two.sided": Test whether SMD differs from null.value +- "less": Test whether SMD is less than null.value +- "greater": Test whether SMD is greater than null.value +- "equivalence": Test whether SMD is between specified bounds +- "minimal.effect": Test whether SMD is outside specified bounds} + +\item{test_method}{a character string specifying the method for hypothesis testing: +- "z": Use z-statistic (normal distribution) +- "t": Use t-statistic with degrees of freedom from the SMD calculation} + +\item{tr}{a numeric value specifying the proportion of observations to trim from each +tail when computing trimmed means and Winsorized variances (default = 0, no trimming). +Must be in the range [0, 0.5). Common choices are 0.1 (10\\% trimming) and 0.2 +(20\\% trimming). When tr > 0, the effect size uses trimmed means for the numerator +and the rescaled Winsorized standard deviation for the denominator, following +Algina, Keselman, and Penfield (2005). The rescaling ensures the robust effect +size equals Cohen's delta when data are normally distributed. +Note: tr > 0 is not compatible with denom = "rm" or smd_ci = "goulet".} + \item{y}{an optional (non-empty) numeric vector of data values.} \item{mu}{a number indicating the true value of the mean for the two-tailed test (or difference in means if you are performing a two sample test).} @@ -66,9 +123,23 @@ smd_calc( \item{na.action}{a function which indicates what should happen when the data contain NAs. Defaults to getOption("na.action").} } \value{ -A data frame containing the following information: +If \code{output = "htest"} (default), returns a list with class \code{"htest"} containing: \itemize{ -\item estimate: The standardized mean difference estimate (Cohen's d, Hedges' g, or Glass's delta) +\item estimate: The SMD estimate (Cohen's d, Hedges' g, or Glass's delta) +\item stderr: Standard error of the estimate +\item conf.int: Confidence interval with conf.level attribute +\item alternative: A character string describing the alternative hypothesis +\item method: A character string indicating what type of test was performed +\item data.name: A character string giving the name(s) of the data +\item statistic: Test statistic (only if alternative != "none") +\item parameter: Degrees of freedom (only if test_method = "t" and alternative != "none") +\item p.value: P-value for the test (only if alternative != "none") +\item null.value: The specified hypothesized value(s) (only if alternative != "none") +} + +If \code{output = "data.frame"}, returns a data frame containing: +\itemize{ +\item estimate: The SMD estimate \item SE: Standard error of the estimate \item lower.ci: Lower bound of the confidence interval \item upper.ci: Upper bound of the confidence interval @@ -79,8 +150,7 @@ A data frame containing the following information: \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} Calculates standardized mean difference (SMD) effect sizes and their confidence intervals -from raw data. This function focuses solely on effect size estimation without performing -hypothesis tests. +from raw data, with optional hypothesis testing. } \details{ This function calculates standardized mean differences (SMD) for various study designs: @@ -106,8 +176,20 @@ Different confidence interval calculation methods are available: \item "z": Uses the normal distribution } -Note that unlike the t_TOST and related functions, smd_calc only calculates effect sizes and -their confidence intervals without performing hypothesis tests. +The \code{denom} parameter provides a direct way to select the standardization denominator. +When \code{denom} is not "auto", it takes precedence over the \code{glass}, \code{rm_correction}, and +\code{var.equal} arguments, which are overridden as needed. A message is emitted if any +explicitly provided arguments are overridden. The \code{bias_correction} argument is always +respected regardless of \code{denom}. + +When \code{tr > 0}, the function computes a robust standardized mean difference +using trimmed means and Winsorized variances. The trimmed mean removes a proportion +\code{tr} of observations from each tail before computing the mean. The Winsorized +variance replaces trimmed observations with the nearest remaining values before +computing the variance. A rescaling constant ensures the robust effect size equals +Cohen's delta under normality. This approach is recommended when distributions +are heavy-tailed or contain outliers, as the robust effect size better reflects +the separation between distributions than the standard Cohen's d (Algina et al., 2005). For detailed information on calculation methods, see \code{vignette("SMD_calcs")}. } @@ -119,7 +201,7 @@ Use this function when: \item You want confidence intervals for your effect size estimates \item You need effect sizes for meta-analysis or reporting \item You want to compare effect sizes across different studies or measures -\item You don't need the hypothesis testing components of the TOST functions +\item You want to test hypotheses about effect size magnitudes (e.g., equivalence testing) } } @@ -145,11 +227,43 @@ smd_calc(x = before, y = after, paired = TRUE, rm_correction = TRUE) # Example 4: Glass's delta (using only first group's SD) smd_calc(x = group1, y = group2, glass = "glass1") +# Example 5: Two-sided test against null of 0 +smd_calc(x = group1, y = group2, + alternative = "two.sided", null.value = 0) + +# Example 6: Equivalence test (TOST) +smd_calc(x = group1, y = group2, + alternative = "equivalence", null.value = c(-0.5, 0.5)) + +# Example 7: Using t-distribution for test +smd_calc(x = group1, y = group2, + alternative = "two.sided", null.value = 0, + test_method = "t", smd_ci = "t") + +# Example 8: Direct denominator selection +smd_calc(x = group1, y = group2, denom = "pooled") +smd_calc(x = group1, y = group2, denom = "avg") +smd_calc(x = before, y = after, paired = TRUE, denom = "rm") +smd_calc(x = group1, y = group2, denom = "glass1", bias_correction = TRUE) + +# Example 9: Legacy data.frame output +smd_calc(x = group1, y = group2, output = "data.frame") + +} +\references{ +Algina, J., Keselman, H. J., & Penfield, R. D. (2005). An alternative to Cohen's +standardized mean difference effect size: A robust parameter and confidence interval +in the two independent groups case. \emph{Psychological Methods}, \emph{10}(3), 317-328. + +Yuen, K. K., & Dixon, W. J. (1973). The approximate behaviour and performance of +the two-sample trimmed t. \emph{Biometrika}, \emph{60}(2), 369-374. } \seealso{ Other effect sizes: \code{\link{boot_ses_calc}()}, \code{\link{boot_smd_calc}()}, -\code{\link{ses_calc}()} +\code{\link{rank_diff}()}, +\code{\link{ses_calc}()}, +\code{\link{trans_rank_prob}()} } \concept{effect sizes} diff --git a/man/stud_ci.Rd b/man/stud_ci.Rd new file mode 100644 index 0000000..a56ad32 --- /dev/null +++ b/man/stud_ci.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/corr_calcs.R +\name{stud_ci} +\alias{stud_ci} +\title{Studentized bootstrap CI on the correlation scale} +\usage{ +stud_ci(tvec, t0_z, se_obs, alpha) +} +\arguments{ +\item{tvec}{Numeric vector of bootstrap pivots: (z_star - z_obs) / se_star} + +\item{t0_z}{Observed Fisher z value: atanh(est)} + +\item{se_obs}{Analytical SE of z_obs} + +\item{alpha}{Two-tailed significance level (e.g., 0.05 for 95\% CI)} +} +\value{ +Numeric vector of length 2: c(lower, upper) on the correlation scale +} +\description{ +Computes a studentized (bootstrap-t) confidence interval by pivoting on the +Fisher z scale and then back-transforming. +} +\keyword{internal} diff --git a/man/trans_rank_prob.Rd b/man/trans_rank_prob.Rd new file mode 100644 index 0000000..f51a50a --- /dev/null +++ b/man/trans_rank_prob.Rd @@ -0,0 +1,116 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/trans_rank_prob.R +\name{trans_rank_prob} +\alias{trans_rank_prob} +\title{Rescale a Probability-Scale Effect Size} +\usage{ +trans_rank_prob( + estimate, + se = NULL, + ci = NULL, + null = NULL, + from = c("probability", "difference", "logodds", "odds"), + to = c("probability", "difference", "logodds", "odds") +) +} +\arguments{ +\item{estimate}{numeric; the point estimate to transform.} + +\item{se}{numeric or \code{NULL}; standard error of \code{estimate}. +Transformed via the delta method.} + +\item{ci}{numeric vector of length 2 or \code{NULL}; confidence interval +endpoints. +Because every scale conversion is monotonic, CI endpoints are transformed +directly (coverage is preserved without the delta method).} + +\item{null}{numeric (scalar or vector) or \code{NULL}; the null-hypothesis +value(s) to transform (e.g., a single null, or two equivalence bounds).} + +\item{from}{character; the scale \code{estimate} is currently on. +One of \code{"probability"}, \code{"difference"}, \code{"logodds"}, \code{"odds"}.} + +\item{to}{character; the target scale. +One of \code{"probability"}, \code{"difference"}, \code{"logodds"}, \code{"odds"}.} +} +\value{ +A list with components: +\describe{ +\item{estimate}{transformed point estimate} +\item{se}{transformed standard error (or \code{NULL})} +\item{ci}{transformed CI endpoints (or \code{NULL})} +\item{null}{transformed null value(s) (or \code{NULL})} +\item{from}{the \code{from} scale (echoed back)} +\item{to}{the \code{to} scale (echoed back)} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Transforms a probability-scale effect size (and, optionally, its standard +error, confidence interval, and null value) between four scales: +\code{"probability"}, \code{"difference"}, \code{"logodds"}, and \code{"odds"}. + +This function serves as both a standalone utility and the internal engine +for \code{brunner_munzel(scale = ...)}. +} +\details{ +The four scales and their relationship to a probability \eqn{p} are:\tabular{llll}{ + Scale \tab Domain \tab Formula \tab Null at stochastic equality \cr + probability \tab \eqn{(0, 1)} \tab \eqn{p} \tab 0.5 \cr + difference \tab \eqn{(-1, 1)} \tab \eqn{2p - 1} \tab 0 \cr + logodds \tab \eqn{(-\infty, \infty)} \tab \eqn{\log[p / (1-p)]} \tab 0 \cr + odds \tab \eqn{(0, \infty)} \tab \eqn{p / (1-p)} \tab 1 \cr +} + + +All conversions are routed through the probability scale internally. + +\strong{Standard errors} are transformed via the delta method: + +\deqn{\mathrm{SE}_{\mathrm{target}} = + \mathrm{SE}_{\mathrm{original}} \times + \left|\frac{dp}{dx}\right| \times + \left|\frac{dy}{dp}\right|} + +where \eqn{x} is the original scale and \eqn{y} is the target scale. + +\strong{Confidence intervals} are transformed by applying the monotonic mapping +directly to each endpoint, which preserves coverage exactly. + +At the boundaries (\eqn{p = 0} or \eqn{p = 1}), transformations to the +logodds scale return \eqn{\pm\infty}, and the delta-method SE is infinite. +This is mathematically correct behaviour; no clamping or warning is applied. +} +\examples{ +# Probability to difference (rank-biserial) +trans_rank_prob(0.7, se = 0.05, ci = c(0.6, 0.8), + null = 0.5, from = "probability", to = "difference") + +# Probability to odds +trans_rank_prob(0.7, from = "probability", to = "odds") + +# Round-trip: logodds -> probability -> logodds +lo <- trans_rank_prob(0.8473, from = "logodds", to = "probability") +trans_rank_prob(lo$estimate, from = "probability", to = "logodds") + +# Apply to brunner_munzel output +res <- brunner_munzel(mpg ~ am, data = mtcars) +trans_rank_prob(as.numeric(res$estimate), + se = res$stderr, + ci = as.numeric(res$conf.int), + null = as.numeric(res$null.value), + from = "probability", to = "logodds") + +} +\seealso{ +\code{\link[=brunner_munzel]{brunner_munzel()}}, \code{\link[=ses_calc]{ses_calc()}} + +Other effect sizes: +\code{\link{boot_ses_calc}()}, +\code{\link{boot_smd_calc}()}, +\code{\link{rank_diff}()}, +\code{\link{ses_calc}()}, +\code{\link{smd_calc}()} +} +\concept{effect sizes} diff --git a/man/wilcox_TOST.Rd b/man/wilcox_TOST.Rd index c1708ef..412f891 100644 --- a/man/wilcox_TOST.Rd +++ b/man/wilcox_TOST.Rd @@ -15,7 +15,8 @@ wilcox_TOST( low_eqbound, high_eqbound, ses = "rb", - alpha = 0.05 + alpha = 0.05, + se_method = c("score", "agresti", "fisher") ) \method{wilcox_TOST}{default}( @@ -29,6 +30,7 @@ wilcox_TOST( ses = c("rb", "odds", "logodds", "cstat"), alpha = 0.05, mu = 0, + se_method = c("score", "agresti", "fisher"), ... ) @@ -58,6 +60,14 @@ generalized odds ratio). Note that \code{ses} only determines which effect size \item{alpha}{alpha level (default = 0.05)} +\item{se_method}{a character string specifying the method for computing standard errors and +confidence intervals for the effect size: +- "score": (default) Uses a score-type approach with test-inversion CIs. For two-sample +designs, uses the Fay-Malinovsky approach. For paired/one-sample, uses a Wilson score +approach. Produces CIs coherent with the Wilcoxon-Mann-Whitney / signed-rank test. +- "agresti": Uses the Agresti/Lehmann placement-based variance estimation. +- "fisher": Uses the legacy Fisher z-transformation method.} + \item{y}{an optional (non-empty) numeric vector of data values.} \item{mu}{number indicating the value around which (a-)symmetry (for @@ -119,6 +129,7 @@ eqb = 3) \seealso{ Other Robust tests: \code{\link{boot_log_TOST}()}, +\code{\link{boot_ses_test}()}, \code{\link{boot_t_TOST}()}, \code{\link{boot_t_test}()}, \code{\link{brunner_munzel}()}, diff --git a/man/z_cor_test.Rd b/man/z_cor_test.Rd index 69e6398..5046c59 100644 --- a/man/z_cor_test.Rd +++ b/man/z_cor_test.Rd @@ -10,7 +10,8 @@ z_cor_test( alternative = c("two.sided", "less", "greater", "equivalence", "minimal.effect"), method = c("pearson", "kendall", "spearman"), alpha = 0.05, - null = 0 + null = 0, + se_method = c("analytic", "jackknife") ) } \arguments{ @@ -38,6 +39,10 @@ One of "pearson", "kendall", or "spearman", can be abbreviated.} \item For equivalence/minimal effect tests: either a single value (symmetric bounds ±value will be created) or a vector of two values representing the lower and upper bounds }} + +\item{se_method}{a character string indicating the method for computing the standard error. +One of "analytic" (default) or "jackknife". The jackknife SE is computed on the Fisher z scale +using leave-one-out resampling.} } \value{ A list with class "htest" containing the following components: @@ -46,8 +51,10 @@ A list with class "htest" containing the following components: \item \strong{statistic}: the value of the test statistic with a name describing it. \item \strong{parameter}: the degrees of freedom or number of observations. \item \strong{conf.int}: a confidence interval for the measure of association appropriate to the specified alternative hypothesis. -\item \strong{estimate}: the estimated measure of association, with name "cor", "tau", or "rho" corresponding to the method employed. -\item \strong{stderr}: the standard error of the test statistic. +\item \strong{estimate}: the estimated measure of association, with name "r", "tau", or "rho" corresponding to the method employed. +\item \strong{stderr}: a named vector with \code{z.se} (standard error on the Fisher z scale, used for inference) +and \code{cor.se} (delta method SE on the correlation scale, for descriptive purposes). +Note that \code{cor.se} underestimates true sampling variability as |r| approaches 1. \item \strong{null.value}: the value of the association measure under the null hypothesis. \item \strong{alternative}: character string indicating the alternative hypothesis. \item \strong{method}: a character string indicating how the association was measured. @@ -64,8 +71,10 @@ cor.test, this function allows users to set the null to a value other than zero equivalence testing. } \details{ -This function uses Fisher's z transformation for the correlations, but uses Fieller's -correction of the standard error for Spearman's \eqn{\rho} and Kendall's \eqn{\tau}. +This function uses Fisher's z transformation for the correlations. +For Spearman's \eqn{\rho}, the Bonett-Wright \eqn{\rho}-dependent SE formula +\eqn{\sqrt{(1 + r^2/2) / (n - 3)}} is used rather than the fixed 1.06 constant. +For Kendall's \eqn{\tau}, Fieller's correction is applied. The function supports both standard hypothesis testing and equivalence/minimal effect testing: \itemize{ @@ -83,6 +92,11 @@ When performing equivalence or minimal effect testing: \item If two values are provided for \code{null}, they will be used as the lower and upper bounds } +When \code{se_method = "jackknife"}, the standard error is computed via leave-one-out +resampling on the Fisher z scale, which can provide better calibration for small +samples or non-standard correlation methods. The jackknife SE is used for both +the test statistic and the confidence interval. + See \code{vignette("correlations")} for more details. } \examples{ @@ -109,6 +123,9 @@ z_cor_test(x, y, method = "spearman", Goertzen, J. R., & Cribbie, R. A. (2010). Detecting a lack of association: An equivalence testing approach. British Journal of Mathematical and Statistical Psychology, 63(3), 527-537. https://doi.org/10.1348/000711009X475853, formula page 531. + +Bonett, D. G., & Wright, T. A. (2000). Sample size requirements for estimating +Pearson, Kendall and Spearman correlations. Psychometrika, 65(1), 23-28. } \seealso{ Other Correlations: diff --git a/references/general/calibration_reference.md b/references/general/calibration_reference.md new file mode 100644 index 0000000..292fbaf --- /dev/null +++ b/references/general/calibration_reference.md @@ -0,0 +1,416 @@ +# Implementing NPC Alpha Calibration for Permutation Equivalence Tests + +## Background + +This document describes how to implement the alpha calibration procedure recommended by Arboretti, Pesarin, & Salmaso (2021) for permutation-based equivalence testing. The calibration corrects for the conservatism of the naive (uncalibrated) TOST procedure, particularly at small sample sizes and narrow equivalence margins. + +### Mapping Between Paper Terminology and TOSTER + +| Paper Term | TOSTER Argument | Null Hypothesis | Alternative | Combination Rule | +|---|---|---|---|---| +| **IU-NPC** (Intersection-Union) | `alternative = "equivalence"` | Non-equivalence (NEq): d ≤ -ε_I OR d ≥ ε_S | Equivalence (Eq): -ε_I < d < ε_S | `max(p_low, p_high)` compared to α_c | +| **UI-NPC** (Union-Intersection) | `alternative = "minimal.effect"` | Equivalence (Eq): -ε_I ≤ d ≤ ε_S | Non-equivalence (NEq): d < -ε_I OR d > ε_S | `min(p_low, p_high)` compared to α̃_c | + +Both directions are already implemented in `perm_t_test` and `brunner_munzel`. What is currently missing is the calibration of the critical value used to evaluate the global p-value. Both functions currently compare the global p-value to the nominal α (the "naive" approach). The calibrated approach replaces α with a data-informed critical value (α_c or α̃_c) that ensures the true global type I error rate equals the nominal α. + +### Why Calibration Matters + +**For `alternative = "equivalence"` (IU-NPC):** +The two partial tests (lower bound, upper bound) are negatively dependent. Using uncalibrated α for each partial test can make the global procedure dramatically conservative. The calibrated α_c lies in the interval [α, (1+α)/2). For α = 0.05, this means α_c ∈ [0.05, 0.525). At small n and narrow margins, the naive procedure can have maximum power near zero, meaning it would fail to detect that a treatment is equivalent to itself. + +**For `alternative = "minimal.effect"` (UI-NPC):** +The calibrated α̃_c lies in [α/2, α]. For α = 0.05, this means α̃_c ∈ [0.025, 0.05]. The gap is much smaller, the convergence to α is faster, and the practical impact of not calibrating is less severe. Still, for small samples with tight margins, calibration improves accuracy. + +## Implementation Plan + +### Overview + +The calibration is a Monte Carlo procedure that must be run before the main test. It estimates the critical value (α_c or α̃_c) such that the type I error rate at the boundary of the null hypothesis equals the nominal α. This is computationally expensive (a double loop: MC outer simulations × R inner permutations per simulation), so it should be implemented as: + +1. A standalone helper function (`calibrate_alpha_perm`) that returns α_c or α̃_c +2. An optional `calibrate` argument on `perm_t_test` (and potentially `brunner_munzel`) that triggers calibration internally + +### Algorithm + +The algorithm below follows Section 4.2 of the paper's supplementary material. The key idea: simulate data at the boundary of H₀ (the worst case for type I error), run the permutation test at each simulation, and find the partial critical value that yields a global rejection rate of exactly α. + +#### For `perm_t_test` (location-based tests) + +**Step 0: Define the boundary.** + +For the IU direction (`alternative = "equivalence"`), H₀ is true when d = -ε_I OR d = ε_S. The calibrated α_c must control type I error at both boundaries. In practice, for symmetric margins (ε_I = ε_S = ε), both boundaries yield the same α_c by symmetry, so only one boundary needs to be simulated. + +For the UI direction (`alternative = "minimal.effect"`), H̃₀ is true when -ε_I ≤ d ≤ ε_S. The worst case for type I error is at the boundary d = -ε_I or d = ε_S (the edges of the equivalence region). + +**Step 1: For a candidate critical value α_candidate, estimate the global rejection rate.** + +``` +function estimate_rejection_rate(n1, n2, eps_I, eps_S, alpha_candidate, + direction, MC, R, sigma_hat, + boundary = "upper"): + + rejections = 0 + + for m in 1:MC: + # Generate data at the boundary of H0 + if boundary == "upper": + # d = eps_S: group 1 has mean 0, group 2 has mean -eps_S + # (so d = mean_1 - mean_2 = eps_S, right at the boundary) + x_sim = rnorm(n1, mean = 0, sd = sigma_hat) + y_sim = rnorm(n2, mean = -eps_S, sd = sigma_hat) + else: # boundary == "lower" + # d = -eps_I: group 1 has mean 0, group 2 has mean eps_I + x_sim = rnorm(n1, mean = 0, sd = sigma_hat) + y_sim = rnorm(n2, mean = eps_I, sd = sigma_hat) + + # Run the permutation test (the same perm_t_test internals) + # but compare the global p-value to alpha_candidate instead of alpha + result = perm_t_test(x_sim, y_sim, + alternative = direction, + mu = c(-eps_I, eps_S), + R = R) + + if direction == "equivalence": + # IU: reject H0 (conclude Eq) when p.value <= alpha_candidate + if result$p.value <= alpha_candidate: + rejections += 1 + else: # "minimal.effect" + # UI: reject H̃0 (conclude NEq) when p.value <= alpha_candidate + if result$p.value <= alpha_candidate: + rejections += 1 + + return rejections / MC +``` + +**Step 2: Search for the α_candidate that yields a rejection rate of α.** + +Use a one-dimensional root-finding algorithm (e.g., `uniroot` in R) to solve: + +``` +estimate_rejection_rate(alpha_candidate) - alpha = 0 +``` + +Search within the theoretical bounds: +- IU (`"equivalence"`): search α_candidate ∈ [α, (1 + α)/2) +- UI (`"minimal.effect"`): search α_candidate ∈ [α/2, α] + +### Detailed R Pseudocode + +```r +#' Calibrate Alpha for Permutation Equivalence/Minimal Effect Tests +#' +#' Estimates the calibrated critical value (alpha_c or alpha_tilde_c) via +#' Monte Carlo simulation at the boundary of the null hypothesis. +#' +#' @param n1 Sample size for group 1 (or total n for paired/one-sample) +#' @param n2 Sample size for group 2 (NULL for paired/one-sample) +#' @param eqb Equivalence bounds: a vector of length 2, c(lower, upper). +#' For symmetric bounds, c(-eps, eps). +#' @param alpha Nominal significance level (default 0.05) +#' @param alternative Either "equivalence" (IU-NPC) or "minimal.effect" (UI-NPC) +#' @param paired Logical: paired or one-sample design? +#' @param var.equal Logical: assume equal variances? (passed to perm_t_test) +#' @param sigma_hat Estimated standard deviation of the data. If NULL, defaults to 1 +#' (equivalent to standardized margins). Can be estimated from pilot data or +#' from the pooled SD of the observed data. +#' @param R Number of permutations per simulated test (default 2500, per paper) +#' @param MC Number of Monte Carlo simulation runs (default 5000, per paper) +#' @param tr Trimming fraction (passed to perm_t_test, default 0) +#' @param seed Random seed for reproducibility +#' +#' @return A list with: +#' - alpha_c: the calibrated critical value +#' - alpha_nominal: the input alpha +#' - alternative: which direction was calibrated +#' - search_interval: the theoretical bounds searched +#' - rejection_rate_at_boundary: estimated type I error at the calibrated alpha_c +#' - MC: number of Monte Carlo runs used +#' - R: number of permutations per run +#' +#' @details +#' For alternative = "equivalence" (IU-NPC from Arboretti et al., 2021): +#' - Searches alpha_c in [alpha, (1 + alpha)/2) +#' - Data are simulated at d = eps_S (upper boundary of H0) +#' - The calibrated alpha_c replaces the nominal alpha when evaluating the +#' global p-value from perm_t_test(..., alternative = "equivalence") +#' +#' For alternative = "minimal.effect" (UI-NPC from Arboretti et al., 2021): +#' - Searches alpha_tilde_c in [alpha/2, alpha] +#' - Data are simulated at d = eps_S (boundary of H-tilde-0) +#' - The calibrated alpha_tilde_c replaces the nominal alpha when evaluating +#' the global p-value from perm_t_test(..., alternative = "minimal.effect") +#' +#' This function is computationally expensive (MC * R permutations total). +#' With defaults MC = 5000 and R = 2500, this is 12.5 million permutations. +#' Consider reducing MC and R for exploratory use, and increasing for final +#' analysis. +#' +#' @references +#' Arboretti, R., Pesarin, F., & Salmaso, L. (2021). A unified approach to +#' permutation testing for equivalence. Statistical Methods & Applications, +#' 30, 1033-1052. + +calibrate_alpha_perm <- function(n1, n2 = NULL, + eqb, + alpha = 0.05, + alternative = c("equivalence", + "minimal.effect"), + paired = FALSE, + var.equal = FALSE, + sigma_hat = 1, + R = 2500, + MC = 5000, + tr = 0, + seed = NULL) { + + alternative <- match.arg(alternative) + + # Validate and parse bounds + if (length(eqb) == 1) { + eqb <- c(-abs(eqb), abs(eqb)) + } + stopifnot(length(eqb) == 2) + eqb <- sort(eqb) + eps_I <- abs(eqb[1]) # lower margin magnitude + eps_S <- eqb[2] # upper margin + + # Define search interval + if (alternative == "equivalence") { + search_lower <- alpha + search_upper <- (1 + alpha) / 2 - 1e-6 # open upper bound + } else { + search_lower <- alpha / 2 + search_upper <- alpha + } + + if (!is.null(seed)) set.seed(seed) + + # Inner function: estimate rejection rate at a candidate alpha_c + est_rejection <- function(alpha_c) { + rejections <- 0L + + for (m in seq_len(MC)) { + # Simulate data at the upper boundary: d = eps_S + # x ~ N(0, sigma), y ~ N(-eps_S, sigma) => mean(x) - mean(y) ≈ eps_S + if (paired || is.null(n2)) { + # One-sample/paired: simulate differences with mean = eps_S + n <- n1 + z_sim <- rnorm(n, mean = eps_S, sd = sigma_hat) + result <- perm_t_test(x = z_sim, + alternative = alternative, + mu = eqb, + R = R, + tr = tr, + keep_perm = FALSE) + } else { + # Two-sample + x_sim <- rnorm(n1, mean = 0, sd = sigma_hat) + y_sim <- rnorm(n2, mean = -eps_S, sd = sigma_hat) + result <- perm_t_test(x = x_sim, y = y_sim, + alternative = alternative, + mu = eqb, + var.equal = var.equal, + R = R, + tr = tr, + keep_perm = FALSE) + } + + if (result$p.value <= alpha_c) { + rejections <- rejections + 1L + } + } + + rejections / MC + } + + # Use uniroot to find alpha_c where rejection_rate = alpha + # The function to zero: f(alpha_c) = est_rejection(alpha_c) - alpha + # + # Note: est_rejection is stochastic, so uniroot may need a tolerance + # compatible with MC precision. With MC = 5000, SE ≈ sqrt(0.05*0.95/5000) ≈ 0.003. + + root_result <- uniroot( + f = function(ac) est_rejection(ac) - alpha, + interval = c(search_lower, search_upper), + tol = 0.005, # tolerance compatible with MC noise + maxiter = 20 # limit iterations given stochastic function + ) + + alpha_c <- root_result$root + + # Verify with a final estimate + final_rate <- est_rejection(alpha_c) + + list( + alpha_c = alpha_c, + alpha_nominal = alpha, + alternative = alternative, + search_interval = c(search_lower, search_upper), + rejection_rate_at_boundary = final_rate, + MC = MC, + R = R, + eqb = eqb, + sigma_hat = sigma_hat + ) +} +``` + +### Important Implementation Notes + +#### 1. The sigma_hat problem + +The calibration requires simulating data from a known distribution F. The paper (IU.3, Section 7.1) acknowledges that F is never fully known in practice, and recommends substituting the unknown σ with the pooled sample estimate σ̂. This introduces approximation, but the paper notes: + +- For UI (minimal.effect): the approximation error is bounded by α/2 and is generally negligible in practice. +- For IU (equivalence): the approximation can be more consequential, particularly when n and margins are small. + +In the implementation, `sigma_hat` should default to the pooled SD from the observed data when called internally. When exposed as a standalone function, let the user provide it. + +#### 2. Computational cost + +With the paper's recommended defaults (MC = 5000, R = 2500), each evaluation of the objective function requires 12.5 million permutation test computations. The root-finding algorithm typically needs 5–15 evaluations, so total cost is on the order of 60–190 million permutations. This is substantial. Practical considerations: + +- **Progress reporting**: Add a progress indicator or message for each uniroot iteration. +- **Reduced defaults for exploration**: Consider MC = 1000, R = 1000 as a "fast" mode. +- **Caching**: If the user's data hasn't changed, the calibrated value can be reused. +- **Parallelization**: The MC loop is embarrassingly parallel. Consider `future.apply` or `parallel::mclapply` as optional speedups. + +#### 3. Symmetry shortcut + +When ε_I = ε_S (symmetric bounds), the calibration only needs to simulate at one boundary. The α_c found at d = ε_S will be the same as at d = -ε_I by symmetry. For asymmetric bounds, simulate at both boundaries and take the α_c that yields the maximum rejection rate (the conservative choice). + +#### 4. uniroot with stochastic functions + +`uniroot` expects a deterministic function. Since `est_rejection` is stochastic (Monte Carlo), there are a few options to handle this: + +- **Option A (simple)**: Use large enough MC that noise is small relative to tolerance. With MC = 5000 and α ≈ 0.05, the SE of the rejection rate estimate is about 0.003, so `tol = 0.005` is reasonable. +- **Option B (robust)**: Replace `uniroot` with a grid search over the interval, evaluate each grid point, and interpolate or select the closest. This is less efficient but immune to the non-monotonicity caused by simulation noise. +- **Option C (stochastic approximation)**: Use the Robbins-Monro algorithm or similar. More complex to implement but theoretically sound. + +Option A is recommended for initial implementation. If users report instability, upgrade to Option B. + +#### 5. Mid-rank alternative + +The paper (IU.3, UI.1) suggests that when no distributional assumption is tenable, mid-rank transformation of data and margins can provide reliable calibration. This corresponds to using the Brunner-Munzel test rather than the t-test. For `brunner_munzel`, the calibration would simulate from a distribution where the relative effect p equals the bound value (e.g., p = 0.3 or p = 0.7), which is more complex to set up because you need to construct two distributions with a specific probability of superiority. One approach: use normal distributions with a location shift chosen to achieve the target relative effect. + +#### 6. When NOT to calibrate + +The paper shows that calibrated and uncalibrated α converge when the standardized equivalence interval is large enough. Specifically (from Section 7.2, point IU.2), when: + +(ε_I + ε_S) × sqrt(n1 × n2 / (n × σ²)) > ~5.4 + +the naive and calibrated values approximately coincide. The function could check this condition and skip calibration with an informative message when it's met. + +### Integration with Existing Functions + +#### Option A: Standalone function + manual workflow + +The user runs calibration separately and passes the result: + +```r +# Step 1: Calibrate (computationally expensive, do once) +cal <- calibrate_alpha_perm( + n1 = 20, n2 = 20, + eqb = c(-0.5, 0.5), + sigma_hat = pooled_sd, + alternative = "equivalence" +) + +# Step 2: Run the test, comparing p-value to calibrated alpha +result <- perm_t_test(x, y, alternative = "equivalence", mu = c(-0.5, 0.5)) + +# Step 3: Evaluate using calibrated threshold +if (result$p.value <= cal$alpha_c) { + # Reject H0 (conclude equivalence) at calibrated alpha +} +``` + +#### Option B: Integrated argument on perm_t_test + +Add an optional `calibrate` argument: + +```r +result <- perm_t_test(x, y, + alternative = "equivalence", + mu = c(-0.5, 0.5), + calibrate = TRUE, # triggers calibration + cal_MC = 5000, # MC runs for calibration + cal_R = 2500) # permutations per calibration run +``` + +When `calibrate = TRUE`, the function: +1. Estimates σ̂ from the pooled data +2. Runs `calibrate_alpha_perm` internally +3. Compares the global p-value to α_c instead of α +4. Reports α_c in the output (e.g., as an additional list element) + +#### Recommendation + +Start with **Option A** (standalone function). This keeps the main test functions clean, gives users transparency into the calibration process, and avoids surprising users with long computation times. Option B can be added later as a convenience wrapper. The standalone function is also useful for power analysis and study design, independent of any particular dataset. + +### Unit Tests for Calibration + +#### Test 1: Search interval bounds are respected + +```r +test_that("calibrated alpha_c is within theoretical bounds", { + cal_iu <- calibrate_alpha_perm(n1 = 12, n2 = 12, + eqb = c(-0.5, 0.5), + alternative = "equivalence", + MC = 500, R = 500, seed = 42) + expect_gte(cal_iu$alpha_c, 0.05) + expect_lt(cal_iu$alpha_c, (1 + 0.05) / 2) + + cal_ui <- calibrate_alpha_perm(n1 = 12, n2 = 12, + eqb = c(-0.5, 0.5), + alternative = "minimal.effect", + MC = 500, R = 500, seed = 42) + expect_gte(cal_ui$alpha_c, 0.05 / 2) + expect_lte(cal_ui$alpha_c, 0.05) +}) +``` + +#### Test 2: IU calibrated alpha_c > nominal alpha for small margins + +```r +test_that("IU alpha_c exceeds nominal alpha for small margins and moderate n", { + cal <- calibrate_alpha_perm(n1 = 12, n2 = 12, + eqb = c(-0.25, 0.25), + alternative = "equivalence", + MC = 1000, R = 1000, seed = 123) + # With small margins relative to sigma, alpha_c should be notably above 0.05 + expect_gt(cal$alpha_c, 0.05 + 0.01) +}) +``` + +#### Test 3: Large margins/samples yield alpha_c ≈ alpha + +```r +test_that("alpha_c converges to alpha for large standardized margins", { + cal <- calibrate_alpha_perm(n1 = 50, n2 = 50, + eqb = c(-1.0, 1.0), + alternative = "equivalence", + MC = 1000, R = 1000, seed = 42) + expect_equal(cal$alpha_c, 0.05, tolerance = 0.015) +}) +``` + +#### Test 4: UI alpha_tilde_c is close to alpha + +```r +test_that("UI alpha_tilde_c is close to nominal alpha", { + cal <- calibrate_alpha_perm(n1 = 15, n2 = 15, + eqb = c(-0.5, 0.5), + alternative = "minimal.effect", + MC = 1000, R = 1000, seed = 42) + # UI calibrated value should be close to alpha (within [alpha/2, alpha]) + expect_equal(cal$alpha_c, 0.05, tolerance = 0.03) +}) +``` + +## References + +- Arboretti, R., Pesarin, F., & Salmaso, L. (2021). A unified approach to permutation testing for equivalence. *Statistical Methods & Applications*, 30, 1033–1052. +- Arboretti, R., Carrozzo, E., Pesarin, F., & Salmaso, L. (2018). Testing for equivalence: an intersection-union permutation solution. *Statistics in Biopharmaceutical Research*, 10, 130–138. +- Pesarin, F., & Salmaso, L. (2010). *Permutation Tests for Complex Data: Theory, Applications and Software*. Wiley. +- Wellek, S. (2010). *Testing Statistical Hypotheses of Equivalence and Noninferiority*. Chapman & Hall/CRC. diff --git a/references/general/wilcoxon_tests_reference.md b/references/general/wilcoxon_tests_reference.md deleted file mode 100644 index 9655526..0000000 --- a/references/general/wilcoxon_tests_reference.md +++ /dev/null @@ -1,347 +0,0 @@ -# Wilcoxon Rank-Based Tests: What They Actually Test - -## Overview - -This reference clarifies what the Wilcoxon-Mann-Whitney (two-sample), Wilcoxon signed-rank (paired/one-sample), and sign test procedures actually test, the assumptions required for various interpretations, and how to extend these to equivalence testing frameworks. - -**Key insight:** The perception that the WMW procedure tests equality of medians is pervasive and frequently encountered. Unfortunately, this perception is mostly wrong (Divine et al., 2018). - ---- - -## The Two-Sample Case: Wilcoxon-Mann-Whitney (WMW) - -### The Test Statistic - -The Mann-Whitney U statistic counts the number of pairs (Xᵢ, Yⱼ) where Xᵢ > Yⱼ. Equivalently, it can be expressed via ranks (Wilcoxon rank-sum formulation). - -### What It Actually Tests (Distribution-Free) - -**Without any assumptions**, the WMW test is a test of: - -$$H_0: p = \Pr(X_1 < X_2) + \Pr(X_1 = X_2)/2 = 0.5$$ - -where X₁ and X₂ are random observations from the two groups being compared (Divine et al., 2018; O'Brien & Castelloe, 2006). - -The sample estimate is: - -$$\hat{p} = \frac{U}{n_1 n_2}$$ - -where U is the Mann-Whitney U statistic. - -**This formulation:** -- Has nothing directly to do with means, medians, or even the shapes of the distributions -- Is valid for tied data (contrary to some textbook claims) -- Is the only interpretation that holds without additional assumptions - -### What It Tests (Assumption-Dependent) - -| Assumption Level | Null Hypothesis | Parameter Tested | -|------------------|-----------------|------------------| -| **None (distribution-free)** | p = Pr(X < Y) + Pr(X = Y)/2 = 0.5 | Stochastic equality | -| **Identical shape, different location (shift alternative)** | Δ = 0 | Hodges-Lehmann pseudomedian of pairwise differences | -| **Shift alternative + symmetric distributions** | median(X) - median(Y) = 0 | Difference in medians | -| **Shift alternative + symmetric distributions** | mean(X) - mean(Y) = 0 | Difference in means | - -### The WMWodds: An Interpretable Effect Size - -O'Brien and Castelloe (2006) recommend converting p̂ to an odds measure: - -$$\text{WMWodds} = \frac{\hat{p}}{1 - \hat{p}}$$ - -**Interpretation:** If WMWodds = 2.0, the odds are 2:1 that a randomly selected observation from group 1 is less than a randomly selected observation from group 2 (splitting ties evenly). - -**Advantages:** -- Null value of 1.0 is intuitive -- Comparable across studies regardless of scale -- Can be displayed in forest plots like odds ratios -- Confidence intervals available via Agresti's (1980) generalized odds ratio formulas - -### Connection to ROC Curve Area (c-statistic) - -The quantity p̂ = Pr(X < Y) + Pr(X = Y)/2 equals the area under the ROC curve (AUC) when viewing the outcome as a classifier for group membership (Bamber, 1975; Hanley & McNeil, 1982). This provides: - -- An intuitive interpretation: the probability that a randomly selected observation from group 2 exceeds one from group 1 -- A graphical representation via ROC curves -- Connection to discrimination/classification frameworks - -### The Hodges-Lehmann Estimator - -**Only under the location-shift model** F_X(x) = F_Y(x - Δ) does the Hodges-Lehmann estimator have meaning: - -$$\hat{\Delta} = \text{median}\{X_i - Y_j : \text{all } i, j\}$$ - -This is the median of all n₁ × n₂ pairwise differences. Importantly: - -- It estimates the **pseudomedian** of the distribution of X - Y -- The pseudomedian equals the median only for symmetric distributions -- The pseudomedian equals the mean only for symmetric distributions - -### Counterexamples: Why WMW Fails as a Test of Medians - -Divine et al. (2018) provide compelling counterexamples: - -**1. Equal medians, significant WMW test:** -In an aromatherapy trial (Hunt et al., 2013), both groups had median PON scores of -1, yet WMW p < 0.001. - -**2. Very different medians, non-significant WMW test:** -Constructed samples with medians of 9 vs. 99, but p̂ = 0.502, WMWodds = 1.01, p ≈ 1.0. - -**3. Medians in the wrong direction:** -Samples where median A = 99 >> median B = 9, but p̂ = 0.716 with p = 0.046, indicating observations from A tend to be *lower* than B. - -**4. Global intransitivity:** -It's possible to have A < B < C < A by WMW tests, which is impossible for any measure of central tendency. - -### Validity with Tied Data - -Despite claims in some textbooks, the WMW test **does not require continuous data** to be valid. Lehmann (1975) established the asymptotic normality of the WMW test statistic for tied data, with only a mild condition that no single point accounts for nearly all the probability. - -When ties are present: -- Tied observations receive their average rank -- The variance estimator is adjusted for ties -- The null hypothesis p = 0.5 remains valid - -### The Behrens-Fisher Problem - -When variances are unequal between groups: -- The Brunner-Munzel (2000) variation performs well when minimum n ≥ 30 -- The Fligner-Policello (1981) variation assumes continuous data -- For smaller samples or many ties, exact/permutation tests are recommended - -### R Implementation - -```r -# Basic test (tests p = 0.5) -wilcox.test(x = x, y = y) - -# With location shift (tests H₀: Δ = μ₀, requires shift assumption) -wilcox.test(x = x, y = y, mu = 0) - -# One-sided with confidence interval -wilcox.test(x = x, y = y, mu = 0, alternative = "greater", conf.int = TRUE) - -# Compute WMWodds manually -U <- wilcox.test(x, y)$statistic -n1 <- length(x) -n2 <- length(y) -p_hat <- U / (n1 * n2) -wmw_odds <- p_hat / (1 - p_hat) -``` - ---- - -## The Paired/One-Sample Case: Wilcoxon Signed-Rank Test - -### The Test Statistic - -For differences Dᵢ = Xᵢ - Yᵢ (paired) or observations Xᵢ (one-sample), the test: - -1. Computes absolute values |Dᵢ| -2. Ranks the absolute values -3. Sums ranks of positive differences (W⁺) and negative differences (W⁻) - -### What It Tests (Assumption-Dependent) - -| Assumption Level | Null Hypothesis | Parameter Tested | -|------------------|-----------------|------------------| -| **Symmetric distribution around θ** | θ = 0 | Pseudomedian of differences | -| **Symmetric distribution** | median(D) = 0 | Median of differences | -| **Symmetric distribution** | mean(D) = 0 | Mean of differences | - -### Critical Assumption: Symmetry - -The signed-rank test **requires** the assumption that the distribution of differences is symmetric around some value θ. Without this assumption, the test does not have a clear interpretation. - -**Note:** The signed-rank test has a similarly poor connection to sample medians as the WMW test (Divine et al., 2018). The quantity it tests, Pr[X₁ + X₂ < 0], is not as interpretable as Pr(X < Y) is for the WMW test. - -### The Hodges-Lehmann Estimator (One-Sample/Paired) - -For the signed-rank setting: - -$$\hat{\theta} = \text{median}\left\{\frac{D_i + D_j}{2} : i \leq j\right\}$$ - -This is the median of all n(n+1)/2 Walsh averages (pairwise averages including self-pairs). - -### R Implementation - -```r -# Paired test -wilcox.test(x = x, y = y, paired = TRUE) - -# One-sample test against μ₀ -wilcox.test(x = x, mu = 0) - -# With confidence interval -wilcox.test(x = x, y = y, paired = TRUE, conf.int = TRUE) -``` - ---- - -## The Sign Test - -### When to Use - -When the symmetry assumption for the signed-rank test is untenable, the sign test provides a valid alternative. - -### What It Tests - -- **H₀:** median(D) = 0 (or P(D > 0) = 0.5) -- Uses only the signs of differences, ignoring magnitudes -- Valid without symmetry assumption -- Less powerful than signed-rank when symmetry holds - -### R Implementation - -```r -# Using binom.test on signs -positive <- sum(d > 0) -n_nonzero <- sum(d != 0) -binom.test(positive, n_nonzero) -``` - ---- - -## Equivalence and Non-Inferiority Testing with TOST - -### Framework - -Two One-Sided Tests (TOST) can be applied to rank-based tests by specifying equivalence bounds on the Hodges-Lehmann scale. - -### Non-Inferiority (One-Sided) - -For a non-inferiority margin of δ (e.g., X is non-inferior to Y if Δ > -δ): - -```r -# H₀: Δ ≤ -δ vs H₁: Δ > -δ -wilcox.test(x = x, y = y, mu = -delta, alternative = "greater", conf.int = TRUE) -``` - -**Interpretation:** If p < α, conclude that X is non-inferior to Y on the Hodges-Lehmann scale, with margin δ. - -### Equivalence (Two One-Sided Tests) - -For equivalence bounds (-δ, δ): - -```r -# Test 1: H₀: Δ ≤ -δ vs H₁: Δ > -δ -test_lower <- wilcox.test(x = x, y = y, mu = -delta, alternative = "greater") - -# Test 2: H₀: Δ ≥ δ vs H₁: Δ < δ -test_upper <- wilcox.test(x = x, y = y, mu = delta, alternative = "less") - -# Equivalence p-value -p_equiv <- max(test_lower$p.value, test_upper$p.value) -``` - -**Interpretation:** If p_equiv < α, conclude that the Hodges-Lehmann location shift lies within (-δ, δ). - -### Using TOSTER Package - -```r -library(TOSTER) - -# Equivalence test for two independent samples -wilcox_TOST(x = x, y = y, low_eqbound = -delta, high_eqbound = delta) - -# Paired equivalence test -wilcox_TOST(x = x, y = y, paired = TRUE, low_eqbound = -delta, high_eqbound = delta) -``` - -### Concordance of P-Values and Confidence Intervals - -For TOST on the Hodges-Lehmann scale: - -- The (1 - 2α) confidence interval should be contained within (-δ, δ) if and only if p_equiv < α -- Minor discrepancies at boundaries may occur due to the discrete nature of rank statistics - -**Caution:** Divine et al. (2018) note that the Hodges-Lehmann confidence interval may perform poorly when the location-shift assumption is violated. In the aromatherapy example, the exact Hodges-Lehmann CI was [-1, 0], which seems inconsistent with p < 0.001. - ---- - -## Graphical Representations of p̂ - -Divine et al. (2018) describe several ways to visualize p̂ = Pr(X < Y) + Pr(X = Y)/2: - -### Bubble Plot -Plot all (X, Y) pairs with bubble size proportional to frequency. The proportion of bubble area above the identity line equals p̂. - -### ROC Curve -The area under the ROC curve (treating group as "disease status") equals p̂. Useful when students are familiar with diagnostic testing. - -### Dominance Diagram -A grid displaying the direction of difference for all combinations of ordered X and Y values (Newson, 2002). The proportion of "X < Y" cells plus half the tied cells equals p̂. - ---- - -## Reporting Guidelines - -### Methods Section Language - -**Two-sample (distribution-free framing):** - -> "Groups were compared using the Wilcoxon-Mann-Whitney test, which tests the null hypothesis that a randomly selected observation from group A is equally likely to be greater or less than a randomly selected observation from group B (i.e., Pr(X < Y) + Pr(X = Y)/2 = 0.5). The WMWodds effect size and its 95% CI are reported." - -**Two-sample (location-shift framing, if justified):** - -> "Non-inferiority was assessed using the Wilcoxon-Mann-Whitney test with a margin of [δ] units on the Hodges-Lehmann scale. Under the assumption of a pure location shift between groups, this tests whether the pseudomedian of pairwise differences exceeds -[δ]." - -**Paired samples:** - -> "Equivalence was assessed using TOST with Wilcoxon signed-rank tests and bounds of ±[δ] units. Under the assumption of symmetric differences, this tests whether the pseudomedian of paired differences lies within the equivalence region." - -### What to Report - -1. The p̂ estimate (or equivalently, WMWodds) -2. The Hodges-Lehmann point estimate (if location-shift assumption is reasonable) -3. The confidence interval (specify confidence level) -4. For equivalence/non-inferiority: the margin with justification -5. Clear statement of which assumptions are being invoked - ---- - -## Summary Table: Assumptions and Interpretations - -| Test | Minimum Assumption | Parameter | Additional Assumption for Median/Mean | -|------|-------------------|-----------|--------------------------------------| -| WMW (two-sample) | None | p = Pr(X < Y) + Pr(X = Y)/2 | Location shift + symmetry | -| WMW with Hodges-Lehmann | Location shift | Pseudomedian of pairwise differences | Symmetry for median/mean | -| Signed-rank (paired/one-sample) | Symmetric differences | Pseudomedian of D | Automatic (symmetry assumed) | -| Sign test | None | Median of D | Not applicable | - ---- - -## Key Takeaways - -1. **Empirically, the WMW test should be regarded as a test of p = Pr(X < Y) + Pr(X = Y)/2 = 0.5** (Divine et al., 2018). This is the only interpretation that holds without additional assumptions. - -2. **The WMW procedure is in no way a function of the observed sample medians.** Counterexamples demonstrate significant tests with equal medians, non-significant tests with different medians, and even significant results in the direction opposite the median difference. - -3. **The location-shift assumption** (identical shapes) is required to interpret WMW as testing the Hodges-Lehmann estimator. This assumption is often implausible in practice. - -4. **WMWodds = p̂/(1-p̂)** provides an interpretable effect size that can be compared across studies, analogous to an odds ratio. - -5. **The WMW test is valid for tied data.** This is established by Lehmann (1975), despite claims to the contrary in some textbooks. - -6. **The signed-rank test requires symmetry** of the difference distribution; without it, use the sign test. - -7. **Equivalence testing via TOST** is valid on the Hodges-Lehmann scale, but the bounds should be interpreted as pseudomedian differences, not necessarily mean or median differences. - -8. **Confidence intervals and p-values** from `wilcox.test()` are concordant (both based on Hodges-Lehmann), with minor boundary discrepancies due to discreteness. - ---- - -## References - -- Agresti, A. (1980). Generalized odds ratios for ordinal data. *Biometrics*, 36, 59-67. -- Bamber, D. (1975). The area above the ordinal dominance graph and the area below the receiver operating characteristic graph. *Journal of Mathematical Psychology*, 12, 387-415. -- Brunner, E., & Munzel, U. (2000). The nonparametric Behrens-Fisher problem: Asymptotic theory and a small-sample approximation. *Biometrical Journal*, 42, 17-25. -- Divine, G. W., Norton, H. J., Barón, A. E., & Juarez-Colunga, E. (2018). The Wilcoxon-Mann-Whitney procedure fails as a test of medians. *The American Statistician*, 72(3), 278-286. -- Divine, G., Norton, H. J., Hunt, R., & Dienemann, J. (2013). A review of analysis and sample size calculation considerations for Wilcoxon tests. *Anesthesia & Analgesia*, 117(3), 699-710. -- Fligner, M. A., & Policello, G. E. (1981). Robust rank procedures for the Behrens-Fisher problem. *Journal of the American Statistical Association*, 76, 162-168. -- Hanley, J., & McNeil, B. (1982). The meaning and use of the area under a receiver operating characteristic (ROC) curve. *Radiology*, 143, 29-36. -- Hodges, J. L., & Lehmann, E. L. (1963). Estimates of location based on rank tests. *Annals of Mathematical Statistics*, 34(2), 598-611. -- Hunt, R., Dienemann, J., Norton, H., Hartley, W., Hudgens, A., Stern, T., & Divine, G. (2013). Aromatherapy as treatment for postoperative nausea. *Anesthesia & Analgesia*, 117, 597-604. -- Lehmann, E. L. (1975). *Nonparametrics: Statistical Methods Based on Ranks*. San Francisco: Holden-Day. -- Newson, R. (2002). Parameters behind "nonparametric" statistics: Kendall's tau, Somers' D and median differences. *Stata Journal*, 2, 45-64. -- O'Brien, R. G., & Castelloe, J. M. (2006). Exploiting the link between the Wilcoxon-Mann-Whitney test and a simple odds statistic. *Proceedings of the 31st Annual SAS Users Group International Conference*, Paper 209-31. -- Wellek, S. (2010). *Testing Statistical Hypotheses of Equivalence and Noninferiority* (2nd ed.). CRC Press. diff --git a/references/general/wmw_odds_se_reference_v2.md b/references/general/wmw_odds_se_reference_v2.md deleted file mode 100644 index 2343c2f..0000000 --- a/references/general/wmw_odds_se_reference_v2.md +++ /dev/null @@ -1,688 +0,0 @@ -# Reference: Updating Standard Error and CI Calculations for Non-Parametric Effect Sizes in TOSTER - -## Overview - -This document provides comprehensive guidance for updating the `ses_calc()` and related functions in the TOSTER package to compute proper standard errors and confidence intervals for all non-parametric effect sizes: rank-biserial correlation, concordance probability (c-statistic), WMW odds, and log-odds. - -**Key recommendation:** Compute variance on the log-odds scale (which has the best asymptotic properties), then back-transform CIs to all other scales including the rank-biserial correlation. - ---- - -## Part 1: Effect Size Definitions and Transformations - -### Effect Size Measures - -| Measure | Symbol | Definition | Range | Null Value | -|---------|--------|------------|-------|------------| -| Concordance probability | p | Pr(Y > X) + 0.5·Pr(Y = X) | [0, 1] | 0.5 | -| Rank-biserial correlation | r | 2p - 1 | [-1, 1] | 0 | -| WMW odds | α | p / (1 - p) | (0, ∞) | 1 | -| WMW log-odds | η | log(p / (1 - p)) = logit(p) | (-∞, ∞) | 0 | - -### Transformation Functions (Bidirectional) - -```r -# === Concordance (p) as the hub === - -# Concordance <-> Rank-biserial -cstat_to_rb <- function(p) 2 * p - 1 -rb_to_cstat <- function(r) (r + 1) / 2 - -# Concordance <-> Odds -cstat_to_odds <- function(p) p / (1 - p) -odds_to_cstat <- function(alpha) alpha / (1 + alpha) - -# Concordance <-> Log-odds -cstat_to_logodds <- function(p) log(p / (1 - p)) # = qlogis(p) -logodds_to_cstat <- function(eta) exp(eta) / (1 + exp(eta)) # = plogis(eta) - -# === Direct transformations === - -# Rank-biserial <-> Odds -rb_to_odds <- function(r) (1 + r) / (1 - r) -odds_to_rb <- function(alpha) (alpha - 1) / (alpha + 1) - -# Rank-biserial <-> Log-odds -rb_to_logodds <- function(r) log((1 + r) / (1 - r)) # = atanh(r) * 2 -logodds_to_rb <- function(eta) (exp(eta) - 1) / (exp(eta) + 1) # = tanh(eta/2) - -# Odds <-> Log-odds -odds_to_logodds <- function(alpha) log(alpha) -logodds_to_odds <- function(eta) exp(eta) -``` - ---- - -## Part 2: Two Independent Samples - -### 2.1 Notation - -- x: observations from group 1 (n₁ observations) -- y: observations from group 2 (n₂ observations) -- n = n₁ + n₂: total sample size -- w₁ = n₁/n, w₂ = n₂/n: sample proportions - -### 2.2 Point Estimates - -The concordance probability is estimated by: - -```r -# Using Mann-Whitney U -U <- sum(sapply(y, function(yj) sum(x < yj) + 0.5 * sum(x == yj))) -p_hat <- U / (n1 * n2) - -# Equivalently, using placement values -W <- sapply(y, function(yj) mean(x < yj) + 0.5 * mean(x == yj)) -p_hat <- mean(W) -``` - -### 2.3 Variance of Concordance Probability - -From Bamber (1975) and Agresti (1980), using Lehmann (1975, eq. 2.21): - -``` -Var(p̂) = (1/n₁) · (P₂₂₁ - p²) + (1/n₂) · (P₂₁₁ - p²) -``` - -Where: -- **P₂₂₁** = Pr(X < Y₁, X < Y₂) where Y₁, Y₂ are independent draws from group 2 - - Interpretation: probability that a random X is less than TWO independent Y's -- **P₂₁₁** = Pr(X₁ < Y, X₂ < Y) where X₁, X₂ are independent draws from group 1 - - Interpretation: probability that TWO independent X's are both less than a random Y - -### 2.4 Estimating the Variance Components - -**Step 1: Compute placement values** - -```r -# For each x_i: what proportion of y's are greater (plus half ties)? -# This estimates Pr(Y > x_i | X = x_i) -V <- sapply(x, function(xi) mean(y > xi) + 0.5 * mean(y == xi)) - -# For each y_j: what proportion of x's are less (plus half ties)? -# This estimates Pr(X < y_j | Y = y_j) -W <- sapply(y, function(yj) mean(x < yj) + 0.5 * mean(x == yj)) -``` - -**Step 2: Estimate variance components** - -```r -# P_221: Pr(X < Y1, X < Y2) - estimated by E[W^2] with finite-sample correction -# Unbiased estimator: -P_221 <- (n1 / (n1 - 1)) * (mean(W^2) - p_hat^2 / n1) -# Or simplified (slightly biased but simpler): -P_221_simple <- mean(W^2) - -# P_211: Pr(X1 < Y, X2 < Y) - estimated by E[V^2] with finite-sample correction -# Note: V estimates Pr(Y > X), so V corresponds to concordance from Y's perspective -P_211 <- (n2 / (n2 - 1)) * (mean(V^2) - p_hat^2 / n2) -# Or simplified: -P_211_simple <- mean(V^2) -``` - -**Step 3: Compute variance of p̂** - -```r -var_p <- (P_221 - p_hat^2) / n1 + (P_211 - p_hat^2) / n2 -se_p <- sqrt(max(var_p, 0)) -``` - -### 2.5 Standard Errors for All Effect Sizes (Two-Sample) - -Using the delta method, we can derive SEs for all effect sizes from SE(p̂): - -| Effect Size | SE Formula | Derivation | -|-------------|------------|------------| -| Concordance (p) | SE(p̂) | Direct | -| Rank-biserial (r) | 2 · SE(p̂) | r = 2p - 1, so dr/dp = 2 | -| Odds (α) | SE(p̂) / (1-p̂)² | α = p/(1-p), so dα/dp = 1/(1-p)² | -| Log-odds (η) | SE(p̂) / [p̂(1-p̂)] | η = logit(p), so dη/dp = 1/[p(1-p)] | - -```r -se_cstat <- se_p -se_rb <- 2 * se_p -se_odds <- se_p / (1 - p_hat)^2 -se_logodds <- se_p / (p_hat * (1 - p_hat)) -``` - -### 2.6 Confidence Interval Construction (Two-Sample) - -**Recommended approach: Compute CI on log-odds scale, back-transform to all others** - -The log-odds (η = logit(p)) has the fastest convergence to normality (Agresti, 1980). - -```r -# 1. Compute CI on log-odds scale -eta_hat <- cstat_to_logodds(p_hat) -se_eta <- se_p / (p_hat * (1 - p_hat)) -z <- qnorm(1 - alpha/2) - -ci_logodds <- eta_hat + c(-1, 1) * z * se_eta - -# 2. Back-transform to all other scales -ci_odds <- exp(ci_logodds) -ci_cstat <- logodds_to_cstat(ci_logodds) # = plogis(ci_logodds) -ci_rb <- cstat_to_rb(ci_cstat) # = 2 * ci_cstat - 1 -``` - -**Why this approach is superior:** -1. Log-odds is unbounded (-∞, ∞), avoiding boundary issues -2. Faster convergence to normality than other scales -3. CIs are guaranteed to respect bounds after back-transformation -4. Consistent methodology across all effect sizes - ---- - -## Part 3: Paired Samples (One-Sample on Differences) - -### 3.1 Setup - -For paired data (x₁, y₁), (x₂, y₂), ..., (xₙ, yₙ), we analyze the differences: -- dᵢ = yᵢ - xᵢ - μ₀ (where μ₀ is typically 0) - -The matched-pairs rank-biserial correlation is based on signed ranks of |dᵢ|. - -### 3.2 Point Estimates (Paired) - -Let: -- n = number of non-zero differences -- R⁺ = sum of ranks for positive differences -- R⁻ = sum of ranks for negative differences -- T = min(R⁺, R⁻) = Wilcoxon signed-rank statistic -- S = R⁺ + R⁻ = n(n+1)/2 = total rank sum - -The matched-pairs rank-biserial correlation: -```r -r_hat <- (R_plus - R_minus) / S -# Equivalently: -r_hat <- 1 - (4 * T) / (n * (n + 1)) -``` - -The paired concordance probability: -```r -p_hat <- (r_hat + 1) / 2 # = R_plus / S -``` - -### 3.3 Variance for Paired Samples - -**From Agresti (1980, eq. 4.4-4.5) for matched pairs:** - -For matched pairs where qᵢⱼ denotes the proportion of pairs with first observation in category i and second in category j: - -``` -α' = (Σᵢ<ⱼ qᵢⱼ) / (Σᵢ>ⱼ qᵢⱼ) -``` - -The estimated asymptotic variance of α'√n for a random sample of n pairs is: - -``` -Var(α') · n = α'² · (1 - Σᵢ qᵢᵢ) / (Σᵢ<ⱼ qᵢⱼ)² -``` - -**For continuous paired differences (practical implementation):** - -When working with signed ranks, we can estimate the variance using a different approach based on the signed-rank statistic's variance. - -The variance of the Wilcoxon signed-rank statistic W = R⁺ under H₀ is: -``` -Var(W) = n(n+1)(2n+1) / 24 -``` - -With ties at t values with counts c₁, c₂, ..., cₜ: -``` -Var(W) = [n(n+1)(2n+1) - Σⱼ cⱼ(cⱼ-1)(cⱼ+1)/2] / 24 -``` - -**Deriving SE for paired concordance:** - -Since p̂ = R⁺/S where S = n(n+1)/2: - -```r -# Variance of W (= R_plus) with tie correction -tie_correction <- sum(sapply(table(abs(d[d != 0])), function(t) t*(t-1)*(t+1)/2)) -var_W <- (n * (n+1) * (2*n+1) - tie_correction) / 24 - -# SE of concordance -S <- n * (n + 1) / 2 -se_p_paired <- sqrt(var_W) / S -``` - -### 3.4 Standard Errors for All Effect Sizes (Paired) - -```r -se_cstat_paired <- se_p_paired -se_rb_paired <- 2 * se_p_paired -se_odds_paired <- se_p_paired / (1 - p_hat)^2 -se_logodds_paired <- se_p_paired / (p_hat * (1 - p_hat)) -``` - -### 3.5 Confidence Interval Construction (Paired) - -**Same approach as two-sample: compute on log-odds scale, back-transform** - -```r -eta_hat <- cstat_to_logodds(p_hat) -se_eta <- se_p_paired / (p_hat * (1 - p_hat)) -z <- qnorm(1 - alpha/2) - -ci_logodds <- eta_hat + c(-1, 1) * z * se_eta - -ci_odds <- exp(ci_logodds) -ci_cstat <- logodds_to_cstat(ci_logodds) -ci_rb <- cstat_to_rb(ci_cstat) -``` - ---- - -## Part 4: Summary of SE and CI Formulas - -### 4.1 Standard Errors - -| Effect Size | Two-Sample SE | Paired SE | -|-------------|---------------|-----------| -| Concordance (p) | √[(P₂₂₁-p²)/n₁ + (P₂₁₁-p²)/n₂] | √Var(W) / S | -| Rank-biserial (r) | 2 · SE(p) | 2 · SE(p) | -| Odds (α) | SE(p) / (1-p)² | SE(p) / (1-p)² | -| Log-odds (η) | SE(p) / [p(1-p)] | SE(p) / [p(1-p)] | - -### 4.2 Confidence Intervals (All via log-odds) - -For both two-sample and paired: - -```r -# Step 1: Get SE of concordance (method differs by design) -se_p <- ... # two-sample or paired formula - -# Step 2: Transform to log-odds scale -eta_hat <- qlogis(p_hat) # = log(p_hat / (1 - p_hat)) -se_eta <- se_p / (p_hat * (1 - p_hat)) - -# Step 3: Form CI on log-odds scale -z <- qnorm(1 - alpha/2) -ci_eta <- eta_hat + c(-1, 1) * z * se_eta - -# Step 4: Back-transform to desired scale -ci_logodds <- ci_eta -ci_odds <- exp(ci_eta) -ci_cstat <- plogis(ci_eta) -ci_rb <- 2 * plogis(ci_eta) - 1 -``` - ---- - -## Part 5: Complete Implementation - -### 5.1 Helper Functions - -```r -#' Compute placement values for two-sample comparison -#' @param x numeric vector for group 1 -#' @param y numeric vector for group 2 -#' @return list with V (placements for x), W (placements for y), p_hat -compute_placements <- function(x, y) { - n1 <- length(x) - n2 <- length(y) - - # For each y: proportion of x's that are less (concordant pairs) - W <- sapply(y, function(yj) { - mean(x < yj) + 0.5 * mean(x == yj) - }) - - # For each x: proportion of y's that are greater - V <- sapply(x, function(xi) { - mean(y > xi) + 0.5 * mean(y == xi) - }) - - p_hat <- mean(W) - - list(V = V, W = W, p_hat = p_hat, n1 = n1, n2 = n2) -} - -#' Compute variance of concordance probability (two-sample) -#' @param placements output from compute_placements -#' @return variance of p_hat -var_concordance_twosample <- function(placements) { - with(placements, { - # Variance components - P_221 <- mean(W^2) - P_211 <- mean(V^2) - - # Variance of p_hat (Lehmann/Agresti formula) - var_p <- (P_221 - p_hat^2) / n1 + (P_211 - p_hat^2) / n2 - - max(var_p, 0) # Ensure non-negative - }) -} - -#' Compute variance of concordance probability (paired) -#' @param d vector of differences (y - x) -#' @return variance of p_hat for paired design -var_concordance_paired <- function(d) { - # Remove zeros - d_nonzero <- d[d != 0] - n <- length(d_nonzero) - - if (n < 2) return(NA) - - # Tie correction - tie_counts <- table(abs(d_nonzero)) - tie_correction <- sum(tie_counts * (tie_counts - 1) * (tie_counts + 1) / 2) - - # Variance of W (Wilcoxon statistic) - var_W <- (n * (n + 1) * (2 * n + 1) - tie_correction) / 24 - - # Total rank sum - S <- n * (n + 1) / 2 - - # Variance of p_hat = W / S - var_p <- var_W / S^2 - - max(var_p, 0) -} -``` - -### 5.2 Main SE Calculation Function - -```r -#' Compute SEs for all non-parametric effect sizes -#' @param x numeric vector (group 1 or pre-treatment) -#' @param y numeric vector (group 2 or post-treatment), NULL for one-sample -#' @param paired logical, TRUE for paired samples -#' @param mu hypothesized difference (default 0) -#' @return list with point estimates and SEs for all effect sizes -ses_compute <- function(x, y = NULL, paired = FALSE, mu = 0) { - - if (is.null(y)) { - # One-sample: compare x to mu - y <- rep(mu, length(x)) - paired <- TRUE - } - - if (paired) { - # === PAIRED SAMPLES === - d <- y - x - mu - d_nonzero <- d[d != 0] - n <- length(d_nonzero) - - if (n < 2) { - warning("Fewer than 2 non-zero differences") - return(NULL) - } - - # Signed ranks - ranks <- rank(abs(d_nonzero)) - R_plus <- sum(ranks[d_nonzero > 0]) - R_minus <- sum(ranks[d_nonzero < 0]) - S <- n * (n + 1) / 2 - - # Point estimates - p_hat <- R_plus / S - r_hat <- (R_plus - R_minus) / S # = 2 * p_hat - 1 - - # Variance - var_p <- var_concordance_paired(d) - se_p <- sqrt(var_p) - - } else { - # === TWO INDEPENDENT SAMPLES === - x <- na.omit(x) - y <- na.omit(y) - - # Compute placements and variance - placements <- compute_placements(x - mu, y) - p_hat <- placements$p_hat - r_hat <- 2 * p_hat - 1 - - var_p <- var_concordance_twosample(placements) - se_p <- sqrt(var_p) - } - - # Point estimates for all scales - alpha_hat <- p_hat / (1 - p_hat) - eta_hat <- log(alpha_hat) # = qlogis(p_hat) - - # Standard errors (delta method) - se_cstat <- se_p - se_rb <- 2 * se_p - se_odds <- se_p / (1 - p_hat)^2 - se_logodds <- se_p / (p_hat * (1 - p_hat)) - - list( - # Point estimates - cstat = p_hat, - rb = r_hat, - odds = alpha_hat, - logodds = eta_hat, - # Standard errors - se_cstat = se_cstat, - se_rb = se_rb, - se_odds = se_odds, - se_logodds = se_logodds, - # Design info - paired = paired - ) -} -``` - -### 5.3 CI Calculation Function - -```r -#' Compute CIs for non-parametric effect sizes via log-odds transformation -#' @param ses_results output from ses_compute -#' @param conf.level confidence level (default 0.95) -#' @return list with CIs for all effect sizes -ses_ci <- function(ses_results, conf.level = 0.95) { - - alpha <- 1 - conf.level - z <- qnorm(1 - alpha / 2) - - with(ses_results, { - # CI on log-odds scale (best asymptotic properties) - ci_logodds <- logodds + c(-1, 1) * z * se_logodds - - # Back-transform to all other scales - ci_odds <- exp(ci_logodds) - ci_cstat <- plogis(ci_logodds) - ci_rb <- 2 * ci_cstat - 1 - - list( - ci_cstat = ci_cstat, - ci_rb = ci_rb, - ci_odds = ci_odds, - ci_logodds = ci_logodds, - conf.level = conf.level - ) - }) -} -``` - -### 5.4 Updated np_ses Function - -```r -#' Non-parametric standardized effect sizes with proper variance estimation -#' @param x numeric vector (group 1 or pre-treatment) -#' @param y numeric vector (group 2 or post-treatment), NULL for one-sample -#' @param mu hypothesized value/difference (default 0) -#' @param conf.level confidence level (default 0.95) -#' @param paired logical for paired samples -#' @param ses effect size type: "rb", "cstat", "odds", or "logodds" -#' @return list with effect size estimate, CI, and metadata -np_ses_updated <- function(x, y = NULL, mu = 0, conf.level = 0.95, - paired = FALSE, ses = c("rb", "odds", "logodds", "cstat")) { - - ses <- match.arg(ses) - - # Compute all estimates and SEs - est <- ses_compute(x = x, y = y, paired = paired, mu = mu) - - if (is.null(est)) { - return(list(type = ses, est = NA, conf.int = c(NA, NA), - se = NA, paired = paired, mu = mu)) - } - - # Compute CIs via log-odds transformation - cis <- ses_ci(est, conf.level = conf.level) - - # Extract requested effect size - result <- switch(ses, - "rb" = list( - est = est$rb, - se = est$se_rb, - conf.int = cis$ci_rb - ), - "cstat" = list( - est = est$cstat, - se = est$se_cstat, - conf.int = cis$ci_cstat - ), - "odds" = list( - est = est$odds, - se = est$se_odds, - conf.int = cis$ci_odds - ), - "logodds" = list( - est = est$logodds, - se = est$se_logodds, - conf.int = cis$ci_logodds - ) - ) - - list( - type = ses, - est = result$est, - se = result$se, - conf.int = result$conf.int, - conf.level = conf.level, - paired = paired, - mu = mu - ) -} -``` - ---- - -## Part 6: Comparison with Current Implementation - -### Current Approach (rbs.R) - -The current implementation: -1. Computes SE for rank-biserial using a formula derived from the Wilcoxon statistic variance -2. Uses Fisher's z-transformation (atanh) for CIs on rank-biserial -3. Simply transforms the CI bounds for odds/logodds/cstat - -```r -# Current: Fisher z-transform for rank-biserial -rf <- atanh(r_rbs) -rfSE <- ... # SE on Fisher z scale -confint <- tanh(rf + c(-1, 1) * qnorm(1 - alpha/2) * rfSE) - -# Current: Simple transformation of CI bounds -confint_odds <- rb_to_odds(confint) # NOT proper propagation -``` - -### New Approach - -1. Computes SE for concordance probability using Lehmann/Agresti variance formula -2. Uses log-odds transformation for CIs (better asymptotic properties than Fisher z) -3. Back-transforms CIs to all scales including rank-biserial - -```r -# New: Log-odds transform for all effect sizes -eta <- qlogis(p_hat) -se_eta <- se_p / (p_hat * (1 - p_hat)) -ci_eta <- eta + c(-1, 1) * qnorm(1 - alpha/2) * se_eta - -# New: Proper back-transformation -ci_rb <- 2 * plogis(ci_eta) - 1 # Proper CI for rank-biserial -ci_odds <- exp(ci_eta) # Proper CI for odds -``` - -### Key Differences - -| Aspect | Current | New | -|--------|---------|-----| -| Primary scale | Rank-biserial | Log-odds | -| Transformation | Fisher z (atanh) | Logit | -| Variance basis | Wilcoxon W variance | Concordance probability variance | -| CI for odds | Transform bounds | Proper back-transform | -| Asymptotic properties | Good | Better (faster convergence) | - ---- - -## Part 7: Edge Cases and Robustness - -### 7.1 Boundary Cases - -When p̂ is near 0 or 1: -- Log-odds approaches ±∞ -- SE formula SE(η) = SE(p) / [p(1-p)] can become very large -- CIs will be wide but remain valid after back-transformation - -```r -# Safeguard for extreme values -p_hat_safe <- pmin(pmax(p_hat, 1e-10), 1 - 1e-10) -``` - -### 7.2 Small Samples - -For very small samples: -- Variance estimates may be unstable -- Consider using exact methods or bootstrap as alternatives -- Add warnings when n₁ < 5 or n₂ < 5 (two-sample) or n < 5 (paired) - -### 7.3 Heavy Ties - -Ties are handled through: -- Half-credit in placement values (0.5 for each tie) -- Tie correction in paired variance formula - -The variance formulas remain valid with ties, though coverage may be slightly affected with very heavy tying. - ---- - -## Part 8: Testing Recommendations - -### 8.1 Verification Tests - -1. **Point estimates unchanged**: All point estimates should match the current implementation exactly. - -2. **Known values**: Test against published examples (e.g., Agresti 1980 examples). - -3. **Transformation consistency**: Verify that: - ```r - all.equal(2 * ci_cstat - 1, ci_rb) - all.equal(exp(ci_logodds), ci_odds) - all.equal(plogis(ci_logodds), ci_cstat) - ``` - -### 8.2 Coverage Simulations - -Run simulations varying: -- Sample sizes: (10,10), (20,20), (50,50), (10,30), (30,10) -- True effect sizes: p = 0.5, 0.6, 0.7, 0.8, 0.9 -- Distributions: Normal, Exponential, Heavy-tailed - -Target: 95% CIs should achieve close to 95% coverage. - -### 8.3 Comparison Tests - -Compare new CIs to: -- Current TOSTER implementation -- Bootstrap percentile CIs (as reference) -- Other software (e.g., SAS PROC NPAR1WAY) - ---- - -## References - -1. **Agresti, A. (1980).** Generalized odds ratios for ordinal data. *Biometrics*, 36, 59-67. - -2. **Bamber, D. (1975).** The area above the ordinal dominance graph and the area below the receiver operating characteristic graph. *Journal of Mathematical Psychology*, 12, 387-415. - -3. **O'Brien, R.G. & Castelloe, J.M. (2006).** Exploiting the link between the Wilcoxon-Mann-Whitney test and a simple odds statistic. *SUGI 31 Proceedings*, Paper 209-31. - -4. **Lehmann, E.L. (1975).** *Nonparametrics: Statistical Methods Based on Ranks*. Holden-Day. - -5. **Kerby, D.S. (2014).** The simple difference formula: An approach to teaching nonparametric correlation. *Comprehensive Psychology*, 3, 11-IT. - -6. **Divine, G.W., Norton, H.J., Barón, A.E., & Juarez-Colunga, E. (2018).** The Wilcoxon-Mann-Whitney procedure fails as a test of medians. *The American Statistician*, 72(3), 278-286. diff --git a/tests/testthat/test-bootTOST.R b/tests/testthat/test-bootTOST.R index 019bd00..500ab1f 100644 --- a/tests/testthat/test-bootTOST.R +++ b/tests/testthat/test-bootTOST.R @@ -3,14 +3,14 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) } test_that("Run examples for one sample", { - + skip_on_cran() set.seed(31653464) samp1 = rnorm(33) @@ -136,7 +136,7 @@ test_that("Run examples for one sample", { test_that("Run examples for two sample", { - + skip_on_cran() set.seed(76584441) samp1 = rnorm(25) @@ -247,7 +247,7 @@ test_that("Run examples for two sample", { test_that("Run examples for paired samples", { - + skip_on_cran() set.seed(921387) samp1 = rnorm(25) @@ -310,3 +310,32 @@ test_that("Run examples for paired samples", { }) +# boot_t_TOST CI/p-value agreement tests ----- + +for (ci_method in c("perc", "basic", "bca", "stud")) { + test_that(paste0("boot_t_TOST: CI/p-value agreement for ", ci_method), { + skip_on_cran() + + set.seed(42) + x <- rnorm(30, mean = 0.3) + y <- rnorm(30) + + hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) + } + + res <- hush(boot_t_TOST(x = x, y = y, eqb = 2, + boot_ci = ci_method, R = 1999)) + # Check two-sided on 90% CI (TOST uses 1-2*alpha = 90%) + # 90% CI excludes null iff two-sided p < 2*alpha = 0.10 + ci <- c(res$effsize$lower.ci[1], res$effsize$upper.ci[1]) + ci_excludes_null <- ci[1] > 0 || ci[2] < 0 + p_rejects <- res$TOST$p.value[1] < 0.10 + expect_equal(ci_excludes_null, p_rejects, + label = paste(ci_method, "CI/p agreement two.sided")) + }) +} + diff --git a/tests/testthat/test-boot_ses_test.R b/tests/testthat/test-boot_ses_test.R new file mode 100644 index 0000000..5fb67b9 --- /dev/null +++ b/tests/testthat/test-boot_ses_test.R @@ -0,0 +1,280 @@ +hush <- function(code) { + suppressWarnings(suppressMessages(capture.output(code))) +} + +# Test 1: Standard two-sided test at mu = 0 returns a plausible p-value -------- +test_that("two-sided test at mu = 0 returns plausible result", { + set.seed(4321) + # Use large separation to ensure a clearly significant result + x <- rnorm(40, mean = 0) + y <- rnorm(40, mean = 2) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 999) + ) + + expect_s3_class(res, "htest") + expect_true(res$p.value >= 0 && res$p.value <= 1) + # Groups differ substantially, so p-value should be small + expect_true(res$p.value < 0.05) + expect_true(!is.null(res$estimate)) + expect_true(!is.null(res$model.param)) +}) + +# Test 2: Equivalence test where obs_rb is clearly inside bounds -------- +test_that("equivalence test with obs_rb inside bounds yields small p-value", { + set.seed(1234) + # Generate data with no real difference, very wide bounds + x <- rnorm(50) + y <- rnorm(50) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.9, 0.9), alternative = "equivalence", B = 999) + ) + + expect_s3_class(res, "htest") + expect_true(res$p.value < 0.05) + expect_equal(res$alternative, "equivalence") +}) + +# Test 3: Equivalence test where obs_rb is clearly outside bounds -------- +test_that("equivalence test with obs_rb outside bounds yields large p-value", { + set.seed(5678) + # Generate data with large difference, narrow bounds + x <- rnorm(30, mean = 0) + y <- rnorm(30, mean = 2) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.1, 0.1), alternative = "equivalence", B = 599) + ) + + expect_s3_class(res, "htest") + expect_true(res$p.value > 0.50) +}) + +# Test 4: Complete separation triggers a warning -------- +test_that("complete separation triggers a warning", { + # Use n >= 20 per group to avoid triggering the small-n warning + x <- 1:25 + y <- 26:50 + + expect_warning( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 100), + "Complete or near-complete separation" + ) +}) + +# Test 5: Small n triggers a warning -------- +test_that("small n triggers a warning", { + set.seed(99) + x <- rnorm(10) + y <- rnorm(10, mean = 0.5) + + expect_warning( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 100), + "Sample size is small" + ) +}) + +# Test 6: Invalid mu outside the valid ses range throws an error -------- +test_that("invalid mu outside valid range throws error", { + x <- rnorm(30) + y <- rnorm(30) + + # rb must be in (-1, 1) + expect_error( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 1.5, alternative = "two.sided", B = 100), + "mu must be in the open interval" + ) + + # cstat must be in (0, 1) + expect_error( + boot_ses_test(x = x, y = y, ses = "cstat", + mu = -0.1, alternative = "two.sided", B = 100), + "mu must be in the open interval" + ) + + # odds must be positive + expect_error( + boot_ses_test(x = x, y = y, ses = "odds", + mu = -1, alternative = "two.sided", B = 100), + "mu must be positive" + ) +}) + +# Test 7: keep_boot = FALSE returns NULL for boot distribution fields -------- +test_that("keep_boot = FALSE returns NULL for boot distributions", { + set.seed(111) + x <- rnorm(25) + y <- rnorm(25, mean = 0.5) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", + B = 100, keep_boot = FALSE) + ) + + expect_null(res$boot.dist) + expect_null(res$boot.dist.low) + expect_null(res$boot.dist.high) + + # Equivalence test with keep_boot = FALSE + res_eq <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.5, 0.5), alternative = "equivalence", + B = 100, keep_boot = FALSE) + ) + + expect_null(res_eq$boot.dist) + expect_null(res_eq$boot.dist.low) + expect_null(res_eq$boot.dist.high) +}) + +# Test 8: Formula interface produces same result as default interface -------- +test_that("formula interface matches default interface", { + set.seed(2222) + dat <- data.frame( + value = c(rnorm(25, 0), rnorm(25, 0.5)), + group = factor(rep(c("a", "b"), each = 25)) + ) + + x <- dat$value[dat$group == "a"] + y <- dat$value[dat$group == "b"] + + res_default <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 599) + ) + + res_formula <- suppressWarnings( + boot_ses_test(formula = value ~ group, data = dat, + ses = "rb", mu = 0, + alternative = "two.sided", B = 599) + ) + + # Estimates should be identical (same data, same method) + expect_equal(res_default$estimate, res_formula$estimate, tolerance = 1e-10) + # p-values may differ due to stochastic bootstrap if seed isn't perfectly aligned, + # but the method and alternative should match + expect_equal(res_default$method, res_formula$method) + expect_equal(res_default$alternative, res_formula$alternative) +}) + +# Test 9: conf.int is NOT present in returned object -------- +test_that("conf.int is intentionally absent from output", { + set.seed(333) + x <- rnorm(25) + y <- rnorm(25, mean = 0.3) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 100) + ) + + expect_null(res$conf.int) +}) + +# Test 10: One-sample design is not supported -------- +test_that("one-sample design errors", { + expect_error( + boot_ses_test(x = rnorm(20), ses = "rb", + mu = 0, alternative = "two.sided", B = 100), + "requires two samples" + ) +}) + +# Test 11: B must be >= 100 -------- +test_that("B must be at least 100", { + x <- rnorm(20) + y <- rnorm(20) + expect_error( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", B = 50), + "B must be an integer >= 100" + ) +}) + +# Test 12: Paired samples work -------- +test_that("paired samples produce valid result", { + set.seed(444) + pre <- rnorm(25, mean = 5) + post <- pre + rnorm(25, mean = 0.3, sd = 0.5) + + res <- suppressWarnings( + boot_ses_test(x = pre, y = post, paired = TRUE, + ses = "rb", mu = 0, alternative = "two.sided", B = 599) + ) + + expect_s3_class(res, "htest") + expect_true(res$p.value >= 0 && res$p.value <= 1) + expect_true(grepl("Paired", res$method)) +}) + +# Test 13: Different ses scales produce valid results -------- +test_that("all ses scales produce valid output", { + set.seed(555) + x <- rnorm(25) + y <- rnorm(25, mean = 0.5) + + for (scale in c("rb", "cstat", "odds", "logodds")) { + mu_val <- switch(scale, + "rb" = 0, "cstat" = 0.5, "odds" = 1, "logodds" = 0) + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = scale, + mu = mu_val, alternative = "two.sided", B = 200) + ) + expect_s3_class(res, "htest") + expect_true(res$p.value >= 0 && res$p.value <= 1) + } +}) + +# Test 14: Minimal effect test -------- +test_that("minimal effect test returns valid result", { + set.seed(666) + # Very large group separation, narrow bounds: obs_rb should be well outside + x <- rnorm(40, mean = 0) + y <- rnorm(40, mean = 3) + + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.2, 0.2), alternative = "minimal.effect", B = 999) + ) + + expect_s3_class(res, "htest") + expect_equal(res$alternative, "minimal.effect") + # Large effect well outside narrow bounds: should reject equivalence + expect_true(res$p.value < 0.05) +}) + +# Test 15: keep_boot = TRUE returns bootstrap distributions -------- +test_that("keep_boot = TRUE returns bootstrap distributions", { + set.seed(777) + x <- rnorm(25) + y <- rnorm(25, mean = 0.3) + + # Standard alternative + res <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = 0, alternative = "two.sided", + B = 200, keep_boot = TRUE) + ) + expect_true(!is.null(res$boot.dist)) + expect_equal(length(res$boot.dist), 200) + + # Equivalence + res_eq <- suppressWarnings( + boot_ses_test(x = x, y = y, ses = "rb", + mu = c(-0.5, 0.5), alternative = "equivalence", + B = 200, keep_boot = TRUE) + ) + expect_true(!is.null(res_eq$boot.dist.low)) + expect_true(!is.null(res_eq$boot.dist.high)) + expect_equal(length(res_eq$boot.dist.low), 200) + expect_equal(length(res_eq$boot.dist.high), 200) +}) diff --git a/tests/testthat/test-boot_t_test_trimmed.R b/tests/testthat/test-boot_t_test_trimmed.R new file mode 100644 index 0000000..efac789 --- /dev/null +++ b/tests/testthat/test-boot_t_test_trimmed.R @@ -0,0 +1,245 @@ +# Tests for trimmed means support in boot_t_test + +hush = function(code) { + sink(nullfile()) + on.exit(sink()) + invisible(force(suppressMessages(code))) +} + +# --- 10.1 Input validation --- +test_that("tr validation works", { + x <- rnorm(20) + + # Invalid tr values + expect_error(hush(boot_t_test(x, tr = -0.1)), "'tr' must be") + expect_error(hush(boot_t_test(x, tr = 0.5)), "'tr' must be") + expect_error(hush(boot_t_test(x, tr = 1.0)), "'tr' must be") + expect_error(hush(boot_t_test(x, tr = c(0.1, 0.2))), "'tr' must be") + expect_error(hush(boot_t_test(x, tr = NA)), "'tr' must be") + + # Sample too small for trimming + expect_error(hush(boot_t_test(rnorm(3), tr = 0.4)), "Sample size too small") +}) + +# --- 10.2 Backward compatibility (tr = 0) --- +test_that("tr = 0 matches existing behavior", { + data(sleep) + + set.seed(100) + res_default <- hush(boot_t_test(extra ~ group, data = sleep, R = 599)) + + set.seed(100) + res_tr0 <- hush(boot_t_test(extra ~ group, data = sleep, tr = 0, R = 599)) + + expect_equal(res_default$statistic, res_tr0$statistic) + expect_equal(res_default$p.value, res_tr0$p.value) + expect_equal(res_default$conf.int, res_tr0$conf.int) + expect_equal(res_default$estimate, res_tr0$estimate) +}) + +# --- 10.3 One-sample trimmed bootstrap --- +test_that("one-sample trimmed bootstrap works", { + set.seed(42) + x <- c(rnorm(18), 10, -10) # data with outliers + + set.seed(100) + res <- hush(boot_t_test(x, tr = 0.1, R = 599)) + + expect_s3_class(res, "htest") + expect_true(grepl("Yuen", res$method)) + expect_true(grepl("trimmed mean", names(res$estimate))) + expect_equal(unname(res$estimate), mean(x, trim = 0.1), tolerance = 1e-10) +}) + +# --- 10.4 Paired trimmed bootstrap --- +test_that("paired trimmed bootstrap works", { + set.seed(42) + x <- rnorm(20, mean = 5) + y <- rnorm(20, mean = 4.5) + + set.seed(100) + res <- hush(boot_t_test(x = x, y = y, paired = TRUE, tr = 0.2, R = 599)) + + expect_s3_class(res, "htest") + expect_true(grepl("Paired Yuen", res$method)) + expect_true(grepl("trimmed mean of the differences", names(res$estimate))) +}) + +# --- 10.5 Two-sample trimmed bootstrap (Welch and equal variance) --- +test_that("two-sample Welch trimmed bootstrap works", { + set.seed(42) + x <- c(rnorm(20, mean = 1), 15) # outlier in x + y <- c(rnorm(25, mean = 0), -12) # outlier in y + + set.seed(100) + res <- hush(boot_t_test(x = x, y = y, tr = 0.1, R = 599)) + + expect_s3_class(res, "htest") + expect_true(grepl("Welch Yuen", res$method)) + expect_length(res$estimate, 3) + expect_true(all(grepl("trimmed mean", names(res$estimate)))) +}) + +test_that("two-sample equal variance trimmed bootstrap works", { + set.seed(42) + x <- rnorm(20, mean = 1) + y <- rnorm(20, mean = 0) + + set.seed(100) + res <- hush(boot_t_test(x = x, y = y, var.equal = TRUE, tr = 0.1, R = 599)) + + expect_s3_class(res, "htest") + expect_true(grepl("Yuen", res$method)) + expect_false(grepl("Welch", res$method)) +}) + +# --- 10.6 All CI methods with trimming --- +test_that("all boot_ci methods work with trimming", { + set.seed(42) + x <- rnorm(30) + + for (ci_method in c("stud", "basic", "perc", "bca")) { + set.seed(100) + res <- hush(boot_t_test(x, tr = 0.1, boot_ci = ci_method, R = 599)) + + expect_s3_class(res, "htest") + expect_true(!is.na(res$conf.int[1]) && !is.na(res$conf.int[2]), + info = paste("CI method:", ci_method)) + expect_true(res$conf.int[1] < res$conf.int[2], + info = paste("CI method:", ci_method)) + } +}) + +# --- 10.7 Equivalence and minimal effect with trimming --- +test_that("equivalence testing works with trimming", { + set.seed(42) + x <- rnorm(30, mean = 0.1) + y <- rnorm(30, mean = 0) + + set.seed(100) + res <- hush(boot_t_test(x = x, y = y, alternative = "equivalence", + mu = c(-1, 1), tr = 0.2, R = 599)) + + expect_s3_class(res, "htest") + expect_equal(res$alternative, "equivalence") + expect_true(grepl("Yuen", res$method)) +}) + +test_that("minimal.effect testing works with trimming", { + set.seed(42) + x <- rnorm(30, mean = 5) + y <- rnorm(30, mean = 0) + + set.seed(100) + res <- hush(boot_t_test(x = x, y = y, alternative = "minimal.effect", + mu = c(-1, 1), tr = 0.2, R = 599)) + + expect_s3_class(res, "htest") + expect_equal(res$alternative, "minimal.effect") +}) + +# --- 10.8 Formula interface passes tr through --- +test_that("formula interface passes tr correctly", { + data(sleep) + + set.seed(100) + res_formula <- hush(boot_t_test(extra ~ group, data = sleep, tr = 0.1, R = 599)) + + set.seed(100) + res_xy <- hush(boot_t_test(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], + tr = 0.1, R = 599)) + + expect_equal(res_formula$statistic, res_xy$statistic, tolerance = 1e-10) + expect_equal(res_formula$p.value, res_xy$p.value, tolerance = 1e-10) +}) + +# --- 10.9 Trimming reduces outlier influence --- +test_that("trimming reduces outlier influence on CIs", { + set.seed(42) + x_clean <- rnorm(20) + x_contaminated <- c(x_clean, 50, -50) # extreme outliers + + set.seed(100) + res_no_trim <- hush(boot_t_test(x_contaminated, R = 999)) + + set.seed(100) + res_trimmed <- hush(boot_t_test(x_contaminated, tr = 0.1, R = 999)) + + # Trimmed CI should be narrower since outliers are downweighted + width_no_trim <- diff(res_no_trim$conf.int) + width_trimmed <- diff(res_trimmed$conf.int) + expect_true(width_trimmed < width_no_trim) +}) + +# --- 10.10 Consistency with perm_t_test estimates --- +test_that("trimmed estimates match perm_t_test", { + set.seed(42) + x <- rnorm(25) + y <- rnorm(25) + + set.seed(100) + res_boot <- hush(boot_t_test(x = x, y = y, tr = 0.2, R = 599)) + + set.seed(100) + res_perm <- hush(perm_t_test(x = x, y = y, tr = 0.2, R = 599)) + + # Point estimates should be identical (same trimmed means) + expect_equal(unname(res_boot$estimate), unname(res_perm$estimate)) + + # Observed t-statistic and df should be identical + expect_equal(unname(res_boot$statistic), unname(res_perm$statistic), + tolerance = 1e-10) + expect_equal(unname(res_boot$parameter), unname(res_perm$parameter), + tolerance = 1e-10) +}) + +# --- 10.11 Edge cases --- +test_that("trimming edge cases are handled", { + # Very small tr (effectively no trimming for small n) + set.seed(42) + x <- rnorm(10) + + set.seed(100) + res_tiny <- hush(boot_t_test(x, tr = 0.01, R = 599)) + expect_s3_class(res_tiny, "htest") + + # Larger trimming + set.seed(100) + res_large <- hush(boot_t_test(rnorm(30), tr = 0.4, R = 599)) + expect_s3_class(res_large, "htest") + + # NA handling with trimming + x_na <- c(rnorm(20), NA, NA) + set.seed(100) + res_na <- hush(boot_t_test(x_na, tr = 0.1, R = 599)) + expect_s3_class(res_na, "htest") +}) + +# --- 10.12 Output structure completeness --- +test_that("trimmed boot_t_test returns complete htest object", { + set.seed(42) + x <- rnorm(20) + + set.seed(100) + res <- hush(boot_t_test(x, tr = 0.2, R = 599)) + + expect_true("statistic" %in% names(res)) + expect_true("parameter" %in% names(res)) + expect_true("p.value" %in% names(res)) + expect_true("stderr" %in% names(res)) + expect_true("conf.int" %in% names(res)) + expect_true("estimate" %in% names(res)) + expect_true("null.value" %in% names(res)) + expect_true("alternative" %in% names(res)) + expect_true("method" %in% names(res)) + expect_true("boot" %in% names(res)) + expect_true("data.name" %in% names(res)) + expect_true("call" %in% names(res)) + + # p-value in valid range + expect_true(res$p.value >= 0 && res$p.value <= 1) + + # boot vector has correct length + expect_length(res$boot, 599) +}) diff --git a/tests/testthat/test-boot_t_test_variance_fix.R b/tests/testthat/test-boot_t_test_variance_fix.R new file mode 100644 index 0000000..216e861 --- /dev/null +++ b/tests/testthat/test-boot_t_test_variance_fix.R @@ -0,0 +1,97 @@ +# Tests for bootstrap variance fix in boot_t_test +# Verifies that the studentized bootstrap p-value computation +# is correct after fixing the centering/sampling bug. + +hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) +} + +# Test 1: Bootstrap p-value is not anticonservatively below parametric (Welch) ---- +test_that("bootstrap Welch p-value is not anticonservative relative to parametric", { + skip_on_cran() + set.seed(42) + res_boot <- boot_t_test(extra ~ group, data = sleep, R = 4999) + res_param <- t.test(extra ~ group, data = sleep) + + # Bootstrap p should be >= parametric p (or very close), not well below it + expect_gte(res_boot$p.value, res_param$p.value - 0.01) +}) + +# Test 2: One-sample p-value near 1 when mu equals sample mean ---- +test_that("one-sample p-value near 1 when mu equals sample mean", { + skip_on_cran() + set.seed(1) + x <- rnorm(30, mean = 5, sd = 1) + set.seed(42) + res <- boot_t_test(x, mu = mean(x), R = 4999) + expect_gt(res$p.value, 0.5) +}) + +# Test 3: One-sided p-values sum to approximately 1 ---- +test_that("one-sided p-values sum to approximately 1", { + skip_on_cran() + set.seed(10) + p_less <- boot_t_test(extra ~ group, data = sleep, + alternative = "less", R = 4999)$p.value + set.seed(10) + p_greater <- boot_t_test(extra ~ group, data = sleep, + alternative = "greater", R = 4999)$p.value + expect_equal(p_less + p_greater, 1, tolerance = 0.01) +}) + +# Test 4: Equal-variance p-value is not anticonservative relative to parametric ---- +test_that("var.equal p-value is not anticonservative relative to parametric", { + skip_on_cran() + set.seed(42) + res_eq <- boot_t_test(extra ~ group, data = sleep, + var.equal = TRUE, R = 4999) + res_par <- t.test(extra ~ group, data = sleep, var.equal = TRUE) + + expect_gte(res_eq$p.value, res_par$p.value - 0.01) +}) + +# Test 5: Trimmed-mean path is unaffected (non-regression) ---- +test_that("trimmed path p-values unchanged after fix", { + skip_on_cran() + set.seed(99) + res <- boot_t_test(extra ~ group, data = sleep, tr = 0.1, R = 4999) + expect_s3_class(res, "htest") + expect_true(is.finite(res$p.value)) + expect_true(res$p.value > 0 && res$p.value < 1) +}) + +# Test 6: One-sample paired test is not anticonservative ---- +test_that("paired bootstrap p-value is not anticonservative", { + skip_on_cran() + x <- sleep$extra[sleep$group == 1] + y <- sleep$extra[sleep$group == 2] + set.seed(42) + res_boot <- boot_t_test(x = x, y = y, paired = TRUE, R = 4999) + res_param <- t.test(x = x, y = y, paired = TRUE) + + expect_gte(res_boot$p.value, res_param$p.value - 0.01) +}) + +# boot_t_test CI/p-value agreement tests ----- + +for (ci_method in c("perc", "basic", "bca", "stud")) { + test_that(paste0("boot_t_test: CI/p-value agreement for ", ci_method), { + skip_on_cran() + + # Use data with a clear effect to avoid boundary discretization issues + set.seed(42) + x <- rnorm(30, mean = 0.5) + y <- rnorm(30) + + res <- boot_t_test(x = x, y = y, + alternative = "two.sided", + boot_ci = ci_method, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = paste(ci_method, "CI/p agreement two.sided")) + }) +} diff --git a/tests/testthat/test-brunner_munzel_degenerate.R b/tests/testthat/test-brunner_munzel_degenerate.R new file mode 100644 index 0000000..2aed888 --- /dev/null +++ b/tests/testthat/test-brunner_munzel_degenerate.R @@ -0,0 +1,159 @@ +# Regression tests for brunner_munzel degenerate/edge cases +# These tests guard against the issues identified in diagnostic_report.md + +hush = function(code){ + sink(nullfile()) + on.exit(sink()) + suppressMessages(suppressWarnings(code)) +} + +# --- Fix 1: Permutation CI index-0 bug (CRITICAL) --- + +test_that("permutation CI does not contain NA for small exact tests", { + # With n=3 per group, R_actual = choose(6,3) = 20. + + # floor(alpha/2 * 20) = floor(0.5) = 0, which caused index-0 -> NA + res <- hush(brunner_munzel( + x = c(0, 0, 0), y = c(0, 0, 0), + test_method = "perm", alternative = "two.sided" + )) + expect_false(any(is.na(res$conf.int))) + expect_true(all(is.finite(res$conf.int))) +}) + +test_that("permutation CI does not contain NA for complete separation", { + res <- hush(brunner_munzel( + x = c(1, 2, 3), y = c(10, 11, 12), + test_method = "perm", alternative = "two.sided" + )) + expect_false(any(is.na(res$conf.int))) + expect_true(all(is.finite(res$conf.int))) +}) + +# --- Fix 2: pd clamping restricted to logit path --- + +test_that("estimate is not clamped for t-approx when pd is 0 or 1", { + # Complete separation: all x < all y, so true pd = 0 + res <- hush(brunner_munzel( + x = c(1, 1, 1, 1), y = c(2, 2, 2, 2), + test_method = "t" + )) + expect_equal(unname(res$estimate), 0) +}) + +test_that("estimate is not clamped for perm when pd is 0 or 1", { + res <- hush(brunner_munzel( + x = c(1, 1, 1, 1), y = c(2, 2, 2, 2), + test_method = "perm" + )) + expect_equal(unname(res$estimate), 0) +}) + +test_that("logit method warns when pd is exactly 0 or 1", { + expect_warning( + hush2 <- suppressMessages( + brunner_munzel( + x = c(1, 1, 1, 1), y = c(2, 2, 2, 2), + test_method = "logit" + ) + ), + "Logit method is unreliable" + ) +}) + +# --- Fix 3: Paired CI clamped to [0, 1] --- + +test_that("paired t-approx CI is within [0, 1]", { + res <- hush(brunner_munzel( + x = c(0, 0, 0), y = c(0, 0, 0), + paired = TRUE, test_method = "t" + )) + expect_gte(res$conf.int[1], 0) + expect_lte(res$conf.int[2], 1) +}) + +test_that("paired t-approx CI is within [0, 1] for varied identical data", { + res <- hush(brunner_munzel( + x = c(1, 2, 3, 4, 5), y = c(1, 2, 3, 4, 5), + paired = TRUE, test_method = "t" + )) + expect_gte(res$conf.int[1], 0) + expect_lte(res$conf.int[2], 1) +}) + +# --- Fix 4: Minimum sample size guard --- + +test_that("n < 3 per group gives informative error", { + expect_error( + brunner_munzel(x = c(1), y = c(2), test_method = "t"), + "at least 3 observations" + ) + expect_error( + brunner_munzel(x = c(1, 2), y = c(3, 4), test_method = "t"), + "at least 3 observations" + ) + expect_error( + brunner_munzel(x = c(1), y = c(2), test_method = "perm"), + "at least 3 observations" + ) +}) + +# --- Fix 5: Permutation p = 0 warning --- + +test_that("exact permutation p = 0 emits a warning", { + skip_on_cran() + # Zero-inflated data where no permutation is as extreme as observed + expect_warning( + hush2 <- suppressMessages( + brunner_munzel( + x = c(0, 0, 0, 0, 0, 1), y = c(0, 0, 0, 0, 0, 0), + test_method = "perm" + ) + ), + "Exact permutation p-value is 0" + ) +}) + +# --- Identical-samples sanity checks (the original brunnermunzel bug) --- + +test_that("identical samples return p = 1 and t = 0 for all methods", { + for (method in c("t", "logit", "perm")) { + res <- hush(brunner_munzel( + x = c(0, 0, 0), y = c(0, 0, 0), + test_method = method + )) + expect_equal(unname(res$statistic), 0, + info = paste("statistic should be 0 for method =", method)) + expect_equal(res$p.value, 1, + info = paste("p.value should be 1 for method =", method)) + expect_equal(unname(res$estimate), 0.5, + info = paste("estimate should be 0.5 for method =", method)) + } +}) + +test_that("larger identical samples return p = 1 for all methods", { + for (method in c("t", "logit", "perm")) { + res <- hush(brunner_munzel( + x = rep(5, 10), y = rep(5, 10), + test_method = method + )) + expect_equal(res$p.value, 1, + info = paste("p.value should be 1 for method =", method)) + expect_equal(unname(res$estimate), 0.5, + info = paste("estimate should be 0.5 for method =", method)) + } +}) + +# --- CI clamping message --- + +test_that("clamping message is emitted when CI exceeds [0, 1]", { + expect_message( + suppressWarnings( + brunner_munzel( + x = c(0, 0, 0), y = c(0, 0, 0), + paired = TRUE, test_method = "t" + ) + ), + "clamped to the \\[0, 1\\] range" + ) +}) diff --git a/tests/testthat/test-brunner_munzel_perm_pval.R b/tests/testthat/test-brunner_munzel_perm_pval.R new file mode 100644 index 0000000..d3d1101 --- /dev/null +++ b/tests/testthat/test-brunner_munzel_perm_pval.R @@ -0,0 +1,150 @@ +# Regression tests for brunner_munzel paired permutation p_method handling +# This file tests that the paired permutation code correctly routes through +# bm_compute_perm_pval, respecting the p_method argument ("exact" vs "plusone"). + +hush = function(code){ + sink(nullfile()) + on.exit(sink()) + suppressMessages(code) +} + +# Test 1: Paired permutation equivalence respects p_method argument +test_that("paired permutation equivalence respects p_method argument", { + skip_on_cran() + set.seed(42) + n <- 20 # n > 13 forces randomization path + x <- rnorm(n, mean = 5) + y <- rnorm(n, mean = 5.1) + + res_exact <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "equivalence", + mu = c(0.3, 0.7), + test_method = "perm", + R = 999, + p_method = "exact")) + + res_plusone <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "equivalence", + mu = c(0.3, 0.7), + test_method = "perm", + R = 999, + p_method = "plusone")) + + # p-values should differ because (b+1)/(R+1) != b/R + expect_false(identical(res_exact$p.value, res_plusone$p.value)) +}) + +# Test 2: Paired permutation two.sided respects p_method argument +test_that("paired permutation two.sided respects p_method argument", { + skip_on_cran() + set.seed(42) + n <- 20 + x <- rnorm(n, mean = 5) + y <- rnorm(n, mean = 5.5) + + res_exact <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "two.sided", + test_method = "perm", + R = 999, + p_method = "exact")) + + res_plusone <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "two.sided", + test_method = "perm", + R = 999, + p_method = "plusone")) + + expect_false(identical(res_exact$p.value, res_plusone$p.value)) +}) + +# Test 3: Paired exact permutation equivalence p-values unchanged after fix +test_that("paired exact permutation equivalence p-values unchanged after fix", { + skip_on_cran() + set.seed(123) + # n <= 13 triggers exact enumeration + x <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8, 6.1, 5.3) + y <- c(5.0, 4.9, 6.1, 5.6, 5.9, 5.6, 5.0, 5.7, 6.0, 5.4) + + res <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "equivalence", + mu = c(0.3, 0.7), + test_method = "perm")) + + # For exact permutation with p_method="exact", b/R == mean(Tperm >= t) + # So the fix should not change the result + expect_true(res$p.value >= 0 && res$p.value <= 1) +}) + +# Test 4: Paired permutation minimal.effect respects p_method argument +test_that("paired permutation minimal.effect respects p_method argument", { + skip_on_cran() + set.seed(42) + n <- 20 + # Use a moderate difference so the MET p-value isn't at the floor (0) + x <- rnorm(n, mean = 5) + y <- rnorm(n, mean = 5.5) + + res_exact <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "minimal.effect", + mu = c(0.3, 0.7), + test_method = "perm", + R = 999, + p_method = "exact")) + + res_plusone <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = "minimal.effect", + mu = c(0.3, 0.7), + test_method = "perm", + R = 999, + p_method = "plusone")) + + expect_false(identical(res_exact$p.value, res_plusone$p.value)) +}) + +# Test 5: Paired permutation p-value is never zero with plusone method +test_that("paired permutation p-value is never zero with plusone", { + skip_on_cran() + set.seed(99) + n <- 20 + x <- rnorm(n, mean = 0) + y <- rnorm(n, mean = 10) # extreme difference + + # Note: minimal.effect uses 1-p internally, so plusone doesn't guarantee p > 0 + for (alt in c("two.sided", "less", "greater", "equivalence")) { + mu_val <- if (alt %in% c("equivalence", "minimal.effect")) c(0.3, 0.7) else 0.5 + res <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = alt, + mu = mu_val, + test_method = "perm", + R = 999, + p_method = "plusone")) + expect_gt(res$p.value, 0, + label = paste("p-value should be > 0 for alternative =", alt)) + } +}) + +# Test 6: Paired permutation less/greater also respect p_method +test_that("paired permutation less and greater respect p_method argument", { + skip_on_cran() + set.seed(42) + n <- 20 + x <- rnorm(n, mean = 5) + y <- rnorm(n, mean = 5.5) + + for (alt in c("less", "greater")) { + res_exact <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = alt, + test_method = "perm", + R = 999, + p_method = "exact")) + + res_plusone <- hush(brunner_munzel(x, y, paired = TRUE, + alternative = alt, + test_method = "perm", + R = 999, + p_method = "plusone")) + + expect_false(identical(res_exact$p.value, res_plusone$p.value), + label = paste("p-values should differ for alternative =", alt)) + } +}) diff --git a/tests/testthat/test-brunner_munzel_scale.R b/tests/testthat/test-brunner_munzel_scale.R new file mode 100644 index 0000000..9eb58bf --- /dev/null +++ b/tests/testthat/test-brunner_munzel_scale.R @@ -0,0 +1,118 @@ +# test-brunner_munzel_scale.R +# brunner_munzel scale argument -------- + +test_that("brunner_munzel scale='probability' is default and unchanged", { + res_default <- brunner_munzel(mpg ~ am, data = mtcars) + res_explicit <- brunner_munzel(mpg ~ am, data = mtcars, scale = "probability") + expect_equal(res_default$estimate, res_explicit$estimate) + expect_equal(res_default$conf.int, res_explicit$conf.int) + expect_equal(res_default$stderr, res_explicit$stderr) + expect_equal(res_default$p.value, res_explicit$p.value) +}) + +test_that("brunner_munzel scale='difference' transforms output correctly", { + res_prob <- brunner_munzel(mpg ~ am, data = mtcars) + res_diff <- brunner_munzel(mpg ~ am, data = mtcars, scale = "difference") + + expect_equal(as.numeric(res_diff$estimate), 2 * as.numeric(res_prob$estimate) - 1) + expect_equal(as.numeric(res_diff$conf.int), 2 * as.numeric(res_prob$conf.int) - 1) + expect_equal(as.numeric(res_diff$stderr), 2 * as.numeric(res_prob$stderr)) + + # p-value and test statistic should be identical + expect_equal(res_diff$p.value, res_prob$p.value) + expect_equal(res_diff$statistic, res_prob$statistic) + expect_equal(res_diff$parameter, res_prob$parameter) +}) + +test_that("brunner_munzel scale='logodds' transforms output correctly", { + res_prob <- brunner_munzel(mpg ~ am, data = mtcars) + res_lo <- brunner_munzel(mpg ~ am, data = mtcars, scale = "logodds") + + p <- as.numeric(res_prob$estimate) + expect_equal(as.numeric(res_lo$estimate), qlogis(p), tolerance = 1e-10) + expect_equal(as.numeric(res_lo$null.value), 0) # logit(0.5) = 0 + + # p-value unchanged + expect_equal(res_lo$p.value, res_prob$p.value) +}) + +test_that("brunner_munzel scale='odds' transforms output correctly", { + res_prob <- brunner_munzel(mpg ~ am, data = mtcars) + res_odds <- brunner_munzel(mpg ~ am, data = mtcars, scale = "odds") + + p <- as.numeric(res_prob$estimate) + expect_equal(as.numeric(res_odds$estimate), p / (1 - p), tolerance = 1e-10) + expect_equal(as.numeric(res_odds$null.value), 1) # 0.5/(1-0.5) = 1 + + # p-value unchanged + expect_equal(res_odds$p.value, res_prob$p.value) +}) + +test_that("brunner_munzel scale works with paired samples", { + x <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, + 11, 12, 13, 14, 15, 16, 17, 18, 19, 20) + y <- c(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, + 12, 13, 14, 15, 16, 17, 18, 19, 20, 21) + res <- brunner_munzel(x, y, paired = TRUE, scale = "difference") + # Check paired label uses direct notation: P(X>Y) (default method uses generic names) + expect_true(grepl("X>Y", names(res$estimate), fixed = TRUE)) +}) + +test_that("brunner_munzel scale works with equivalence tests", { + res_prob <- brunner_munzel(mpg ~ am, data = mtcars, + alternative = "equivalence", mu = c(0.35, 0.65)) + res_diff <- brunner_munzel(mpg ~ am, data = mtcars, + alternative = "equivalence", mu = c(0.35, 0.65), + scale = "difference") + # Null values should be transformed + expect_equal(as.numeric(res_diff$null.value), c(-0.3, 0.3)) + # p-value unchanged + expect_equal(res_diff$p.value, res_prob$p.value) +}) + +test_that("brunner_munzel scale works with permutation tests", { + set.seed(42) + res_prob <- brunner_munzel(mpg ~ am, data = mtcars, test_method = "perm", + scale = "probability") + set.seed(42) + res_diff <- brunner_munzel(mpg ~ am, data = mtcars, test_method = "perm", + scale = "difference") + expect_equal(as.numeric(res_diff$estimate), 2 * as.numeric(res_prob$estimate) - 1) +}) + +test_that("brunner_munzel scale works with logit test_method", { + res <- brunner_munzel(mpg ~ am, data = mtcars, + test_method = "logit", scale = "odds") + expect_true(grepl("odds(", names(res$estimate), fixed = TRUE)) + # The test_method=logit affects inference; scale=odds affects reporting + # Both should work independently +}) + +test_that("brunner_munzel formula method respects scale with group names", { + res <- brunner_munzel(mpg ~ am, data = mtcars, scale = "difference") + # Should contain quoted factor level names + expect_true(grepl("'0'", names(res$estimate), fixed = TRUE)) + expect_true(grepl("'1'", names(res$estimate), fixed = TRUE)) + expect_true(grepl("P(", names(res$estimate), fixed = TRUE)) +}) + +test_that("brunner_munzel default method uses quoted X/Y in labels", { + x <- rnorm(20) + y <- rnorm(20, mean = 1) + res <- brunner_munzel(x, y) + # Default method uses generic X and Y (unquoted since non-numeric) + expect_true(grepl("X>Y", names(res$estimate), fixed = TRUE)) +}) + +test_that("brunner_munzel label quoting is consistent across scales", { + res_prob <- brunner_munzel(mpg ~ am, data = mtcars, scale = "probability") + res_diff <- brunner_munzel(mpg ~ am, data = mtcars, scale = "difference") + res_lo <- brunner_munzel(mpg ~ am, data = mtcars, scale = "logodds") + res_odds <- brunner_munzel(mpg ~ am, data = mtcars, scale = "odds") + + # All should have quoted group names + for (res in list(res_prob, res_diff, res_lo, res_odds)) { + expect_true(grepl("'0'", names(res$estimate), fixed = TRUE)) + expect_true(grepl("'1'", names(res$estimate), fixed = TRUE)) + } +}) diff --git a/tests/testthat/test-compare_smds.R b/tests/testthat/test-compare_smds.R index d22b33a..f9b8acb 100644 --- a/tests/testthat/test-compare_smds.R +++ b/tests/testthat/test-compare_smds.R @@ -3,7 +3,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-corr.R b/tests/testthat/test-corr.R index 5822385..0fada6a 100644 --- a/tests/testthat/test-corr.R +++ b/tests/testthat/test-corr.R @@ -3,7 +3,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -66,8 +66,8 @@ test_that("Run examples for z_cor_test", { samp2, method = "k") - expect_equal(test1$estimate, - test1c$estimate) + expect_equal(unname(test1$estimate), + unname(test1c$estimate)) expect_equal(test3$estimate, test3c$estimate) expect_equal(test2$estimate, @@ -153,6 +153,7 @@ test_that("Run examples for z_cor_test", { }) test_that("cor_test: equ and met", { + skip_on_cran() set.seed(5533428) @@ -231,6 +232,7 @@ test_that("cor_test: equ and met", { }) test_that("Run examples for boot_cor_test", { + skip_on_cran() set.seed(76584441) @@ -245,17 +247,21 @@ test_that("Run examples for boot_cor_test", { null = c(-.2,.2), alternative = "t")) + # Use boot_ci = "perc" to get percentile p-values (matches legacy expectations) test1 = boot_cor_test(samp1, samp2, - method = "p") + method = "p", + boot_ci = "perc") test2 = boot_cor_test(samp1, samp2, - method = "s") + method = "s", + boot_ci = "perc") test3 = boot_cor_test(samp1, samp2, - method = "k") + method = "k", + boot_ci = "perc") expect_equal(c(unname(test1$parameter), unname(test2$parameter), @@ -284,8 +290,8 @@ test_that("Run examples for boot_cor_test", { samp2, method = "k") - expect_equal(test1$estimate, - test1c$estimate) + expect_equal(unname(test1$estimate), + unname(test1c$estimate)) expect_equal(test3$estimate, test3c$estimate) expect_equal(test2$estimate, @@ -325,16 +331,19 @@ test_that("Run examples for boot_cor_test", { test1 = boot_cor_test(samp1, samp2, method = "p", + boot_ci = "perc", alternative = "greater") test2 = boot_cor_test(samp1, samp2, method = "s", + boot_ci = "perc", alternative = "greater") test3 = boot_cor_test(samp1, samp2, method = "k", + boot_ci = "perc", alternative = "greater") @@ -351,16 +360,19 @@ test_that("Run examples for boot_cor_test", { test1 = boot_cor_test(samp1, samp2, method = "p", + boot_ci = "perc", alternative = "less") test2 = boot_cor_test(samp1, samp2, method = "s", + boot_ci = "perc", alternative = "less") test3 = boot_cor_test(samp1, samp2, method = "k", + boot_ci = "perc", alternative = "less") @@ -377,6 +389,7 @@ test_that("Run examples for boot_cor_test", { }) test_that("Run examples for boot_compare_cor", { + skip_on_cran() set.seed(8922) x1 = rnorm(40) @@ -639,3 +652,242 @@ test_that("Run examples for corsum_test",{ 0.84, tolerance = .001) }) + +test_that("z_cor_test: jackknife SE and cor.se", { + + set.seed(424242) + x <- rnorm(20) + y <- x + rnorm(20, sd = 0.5) + + # (a) jackknife SE differs from analytic (typically larger for small n) + for (m in c("pearson", "spearman", "kendall")) { + res_a <- z_cor_test(x, y, method = m) + res_j <- z_cor_test(x, y, method = m, se_method = "jackknife") + + expect_true(res_a$stderr["z.se"] != res_j$stderr["z.se"], + label = paste0("jackknife SE differs for ", m)) + } + + # (b) CI and p-value use the same SE under jackknife + # Verify CI width changes when switching to jackknife + res_a <- z_cor_test(x, y, method = "pearson") + res_j <- z_cor_test(x, y, method = "pearson", se_method = "jackknife") + + ci_width_a <- diff(res_a$conf.int) + ci_width_j <- diff(res_j$conf.int) + expect_true(ci_width_a != ci_width_j, + label = "CI width changes with jackknife SE") + + # p-values should also differ + + expect_true(res_a$p.value != res_j$p.value, + label = "p-value changes with jackknife SE") + + # (c) cor.se equals (1 - r^2) * z.se to numerical precision + for (m in c("pearson", "spearman", "kendall")) { + res <- z_cor_test(x, y, method = m) + r <- unname(res$estimate) + expected_cor_se <- (1 - r^2) * res$stderr["z.se"] + expect_equal(unname(res$stderr["cor.se"]), + unname(expected_cor_se), + tolerance = 1e-10, + label = paste0("cor.se delta method for ", m)) + + # also check jackknife path + res_j <- z_cor_test(x, y, method = m, se_method = "jackknife") + r_j <- unname(res_j$estimate) + expected_cor_se_j <- (1 - r_j^2) * res_j$stderr["z.se"] + expect_equal(unname(res_j$stderr["cor.se"]), + unname(expected_cor_se_j), + tolerance = 1e-10, + label = paste0("cor.se delta method (jackknife) for ", m)) + } + + # jackknife works with equivalence testing + res_eq <- z_cor_test(x, y, method = "pearson", + alternative = "e", null = 0.8, + se_method = "jackknife") + expect_true(is.finite(res_eq$p.value)) + expect_length(res_eq$stderr, 2) +}) + +# boot_cor_test p-value / CI consistency tests ----- + +test_that("boot_cor_test: stud validation errors", { + skip_on_cran() + + x <- rnorm(20) + y <- rnorm(20) + + expect_error( + boot_cor_test(x, y, method = "winsorized", boot_ci = "stud"), + "Studentized bootstrap" + ) + expect_error( + boot_cor_test(x, y, method = "bendpercent", boot_ci = "stud"), + "Studentized bootstrap" + ) +}) + +test_that("boot_cor_test: stud method runs for pearson/spearman/kendall", { + skip_on_cran() + + set.seed(12345) + x <- rnorm(30) + y <- x + rnorm(30, sd = 0.5) + + for (m in c("pearson", "spearman", "kendall")) { + res <- boot_cor_test(x, y, method = m, boot_ci = "stud", R = 999) + expect_true(is.finite(res$p.value), label = paste("stud p finite for", m)) + expect_equal(res$boot_ci, "stud") + expect_true(grepl("studentized", res$method), + label = paste("method string includes studentized for", m)) + expect_length(res$stderr, 2) + expect_true(all(names(res$stderr) == c("boot.se", "z.se"))) + } +}) + +test_that("boot_cor_test: boot_ci returned in result", { + skip_on_cran() + + set.seed(999) + x <- rnorm(20) + y <- rnorm(20) + + for (ci_method in c("basic", "perc", "bca", "stud")) { + res <- boot_cor_test(x, y, method = "pearson", + boot_ci = ci_method, R = 599) + expect_equal(res$boot_ci, ci_method, + label = paste("boot_ci field for", ci_method)) + } +}) + +test_that("boot_cor_test: CI/p-value agreement for perc", { + skip_on_cran() + + set.seed(42) + n <- 50 + x <- rnorm(n) + y <- 0.4 * x + rnorm(n, sd = 0.8) + + # Under perc: p < alpha iff CI excludes null + res <- boot_cor_test(x, y, method = "pearson", boot_ci = "perc", + alternative = "two.sided", null = 0, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = "perc CI/p agreement two.sided") +}) + +test_that("boot_cor_test: CI/p-value agreement for basic", { + skip_on_cran() + + set.seed(42) + n <- 50 + x <- rnorm(n) + y <- 0.4 * x + rnorm(n, sd = 0.8) + + res <- boot_cor_test(x, y, method = "pearson", boot_ci = "basic", + alternative = "two.sided", null = 0, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = "basic CI/p agreement two.sided") +}) + +test_that("boot_cor_test: CI/p-value agreement for bca", { + skip_on_cran() + + set.seed(42) + n <- 50 + x <- rnorm(n) + y <- 0.4 * x + rnorm(n, sd = 0.8) + + res <- boot_cor_test(x, y, method = "pearson", boot_ci = "bca", + alternative = "two.sided", null = 0, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = "bca CI/p agreement two.sided") +}) + +test_that("boot_cor_test: CI/p-value agreement for stud", { + skip_on_cran() + + set.seed(42) + n <- 50 + x <- rnorm(n) + y <- 0.4 * x + rnorm(n, sd = 0.8) + + res <- boot_cor_test(x, y, method = "pearson", boot_ci = "stud", + alternative = "two.sided", null = 0, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = "stud CI/p agreement two.sided") +}) + +test_that("boot_cor_test: equivalence and MET with all CI methods", { + skip_on_cran() + + set.seed(101) + n <- 80 + x <- rnorm(n) + y <- rnorm(n) # near-zero correlation + + for (ci_method in c("basic", "perc", "bca", "stud")) { + # Equivalence: wide bounds should reject (p < alpha) + res_wide <- boot_cor_test(x, y, method = "pearson", + boot_ci = ci_method, + alternative = "equivalence", + null = 0.5, R = 999) + expect_true(is.finite(res_wide$p.value), + label = paste("equ p finite for", ci_method)) + + # MET: wide bounds should fail to reject (p >= alpha) + res_met <- boot_cor_test(x, y, method = "pearson", + boot_ci = ci_method, + alternative = "minimal.effect", + null = 0.5, R = 999) + expect_true(is.finite(res_met$p.value), + label = paste("met p finite for", ci_method)) + } +}) + +test_that("boot_cor_test: equivalence with asymmetric bounds", { + skip_on_cran() + + set.seed(202) + n <- 60 + x <- rnorm(n) + y <- rnorm(n) + + for (ci_method in c("basic", "perc", "bca", "stud")) { + res <- boot_cor_test(x, y, method = "pearson", + boot_ci = ci_method, + alternative = "equivalence", + null = c(-0.3, 0.5), R = 999) + expect_true(is.finite(res$p.value), + label = paste("asymmetric equ for", ci_method)) + expect_equal(length(res$null.value), 2) + } +}) + +test_that("boot_cor_test: stud results similar to z_cor_test for large n Pearson", { + skip_on_cran() + + set.seed(303) + n <- 200 + x <- rnorm(n) + y <- 0.3 * x + rnorm(n, sd = 0.9) + + boot_res <- boot_cor_test(x, y, method = "pearson", + boot_ci = "stud", R = 1999) + z_res <- z_cor_test(x, y, method = "pearson") + + # Point estimates should be identical + expect_equal(unname(boot_res$estimate), unname(z_res$estimate)) + + # p-values should be in the same ballpark + expect_equal(boot_res$p.value, z_res$p.value, tolerance = 0.1) +}) diff --git a/tests/testthat/test-data_summary_equivalent.R b/tests/testthat/test-data_summary_equivalent.R index 232badf..623d426 100644 --- a/tests/testthat/test-data_summary_equivalent.R +++ b/tests/testthat/test-data_summary_equivalent.R @@ -7,7 +7,7 @@ test_that("p-values for TOSTr are identical using dataTOSTr and TOSTr", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-denom_param.R b/tests/testthat/test-denom_param.R new file mode 100644 index 0000000..d40f3e7 --- /dev/null +++ b/tests/testthat/test-denom_param.R @@ -0,0 +1,327 @@ +# Tests for denom parameter in smd_calc and boot_smd_calc + +hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) +} + +# Test data +set.seed(123) +x_ind <- rnorm(30, mean = 100, sd = 15) +y_ind <- rnorm(30, mean = 110, sd = 18) +x_pair <- rnorm(20, mean = 5, sd = 2) +y_pair <- x_pair + rnorm(20, mean = 1, sd = 1) +x_one <- rnorm(25, mean = 3, sd = 2) + +# --- 1. Equivalence with existing interface --- + +test_that("denom = 'pooled' matches var.equal = TRUE", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "pooled") + r2 <- smd_calc(x = x_ind, y = y_ind, var.equal = TRUE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'avg' matches var.equal = FALSE", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "avg") + r2 <- smd_calc(x = x_ind, y = y_ind, var.equal = FALSE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'rm' matches rm_correction = TRUE for paired", { + r1 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "rm") + r2 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, rm_correction = TRUE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'z' matches rm_correction = FALSE for paired", { + r1 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "z") + r2 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, rm_correction = FALSE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'glass1' matches glass = 'glass1'", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "glass1") + r2 <- smd_calc(x = x_ind, y = y_ind, glass = "glass1") + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'glass2' matches glass = 'glass2'", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "glass2") + r2 <- smd_calc(x = x_ind, y = y_ind, glass = "glass2") + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'glass1' matches glass = 'glass1' for paired", { + r1 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "glass1") + r2 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, glass = "glass1") + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) + expect_equal(r1$stderr, r2$stderr) +}) + +test_that("denom = 'z' works for one-sample", { + r1 <- smd_calc(x = x_one, denom = "z") + r2 <- smd_calc(x = x_one) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +# --- 2. Design-validity errors --- + +test_that("denom = 'z' errors for independent samples", { + expect_error( + smd_calc(x = x_ind, y = y_ind, denom = "z"), + "denom = 'z' is not valid for independent samples designs." + ) +}) + +test_that("denom = 'rm' errors for independent samples", { + expect_error( + smd_calc(x = x_ind, y = y_ind, denom = "rm"), + "denom = 'rm' is only valid for paired samples designs." + ) +}) + +test_that("denom = 'pooled' errors for paired samples", { + expect_error( + smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "pooled"), + "denom = 'pooled' is only valid for independent samples designs." + ) +}) + +test_that("denom = 'avg' errors for paired samples", { + expect_error( + smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "avg"), + "denom = 'avg' is only valid for independent samples designs." + ) +}) + +test_that("denom = 'rm' errors for one-sample", { + expect_error( + smd_calc(x = x_one, denom = "rm"), + "denom = 'rm' is only valid for paired samples designs." + ) +}) + +test_that("denom = 'glass1' errors for one-sample", { + expect_error( + smd_calc(x = x_one, denom = "glass1"), + "denom = 'glass1' is not valid for one-sample designs." + ) +}) + +test_that("denom = 'glass2' errors for one-sample", { + expect_error( + smd_calc(x = x_one, denom = "glass2"), + "denom = 'glass2' is not valid for one-sample designs." + ) +}) + +test_that("denom = 'pooled' errors for one-sample", { + expect_error( + smd_calc(x = x_one, denom = "pooled"), + "denom = 'pooled' is only valid for independent samples designs." + ) +}) + +test_that("denom = 'avg' errors for one-sample", { + expect_error( + smd_calc(x = x_one, denom = "avg"), + "denom = 'avg' is only valid for independent samples designs." + ) +}) + +# --- 3. Override messages --- + +test_that("denom = 'pooled' with var.equal = FALSE emits message", { + expect_message( + smd_calc(x = x_ind, y = y_ind, denom = "pooled", var.equal = FALSE), + "denom = 'pooled' overrides var.equal to TRUE." + ) +}) + +test_that("denom = 'rm' with rm_correction = FALSE emits message", { + expect_message( + smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "rm", rm_correction = FALSE), + "denom = 'rm' overrides rm_correction to TRUE." + ) +}) + +test_that("denom = 'glass1' with glass = 'glass2' emits message", { + expect_message( + smd_calc(x = x_ind, y = y_ind, denom = "glass1", glass = "glass2"), + "denom = 'glass1' overrides glass argument." + ) +}) + +test_that("denom = 'avg' with glass = 'glass1' emits message", { + expect_message( + smd_calc(x = x_ind, y = y_ind, denom = "avg", glass = "glass1"), + "denom = 'avg' overrides glass argument." + ) +}) + +test_that("denom = 'z' with rm_correction = TRUE emits message", { + expect_message( + smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "z", rm_correction = TRUE), + "denom = 'z' overrides rm_correction to FALSE." + ) +}) + +test_that("denom = 'avg' with var.equal = TRUE emits message", { + expect_message( + smd_calc(x = x_ind, y = y_ind, denom = "avg", var.equal = TRUE), + "denom = 'avg' overrides var.equal to FALSE." + ) +}) + +# --- No message when no conflict --- + +test_that("denom = 'pooled' with var.equal = TRUE does NOT emit message", { + expect_no_message( + smd_calc(x = x_ind, y = y_ind, denom = "pooled", var.equal = TRUE) + ) +}) + +test_that("denom = 'pooled' without explicit var.equal does NOT emit message", { + expect_no_message( + smd_calc(x = x_ind, y = y_ind, denom = "pooled") + ) +}) + +test_that("denom = 'rm' with rm_correction = TRUE does NOT emit message", { + expect_no_message( + smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "rm", rm_correction = TRUE) + ) +}) + +# --- 4. Auto preserves existing behavior --- + +test_that("denom = 'auto' is identical to omitting denom (independent)", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "auto", var.equal = TRUE) + r2 <- smd_calc(x = x_ind, y = y_ind, var.equal = TRUE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +test_that("denom = 'auto' is identical to omitting denom (paired)", { + r1 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "auto", rm_correction = TRUE) + r2 <- smd_calc(x = x_pair, y = y_pair, paired = TRUE, rm_correction = TRUE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +test_that("denom = 'auto' is identical to omitting denom (one-sample)", { + r1 <- smd_calc(x = x_one, denom = "auto") + r2 <- smd_calc(x = x_one) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +# --- 5. bias_correction independence --- + +test_that("denom does not affect bias_correction", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "pooled", bias_correction = TRUE) + r2 <- smd_calc(x = x_ind, y = y_ind, denom = "pooled", bias_correction = FALSE) + # Hedges' g and Cohen's d should differ + + expect_false(unname(r1$estimate) == unname(r2$estimate)) +}) + +# --- 6. Bootstrap: denom equivalence --- + +test_that("boot_smd_calc denom = 'pooled' matches var.equal = TRUE", { + set.seed(42) + r1 <- boot_smd_calc(x = x_ind, y = y_ind, denom = "pooled", R = 199) + set.seed(42) + r2 <- boot_smd_calc(x = x_ind, y = y_ind, var.equal = TRUE, R = 199) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +test_that("boot_smd_calc denom = 'avg' matches var.equal = FALSE", { + set.seed(42) + r1 <- boot_smd_calc(x = x_ind, y = y_ind, denom = "avg", R = 199) + set.seed(42) + r2 <- boot_smd_calc(x = x_ind, y = y_ind, var.equal = FALSE, R = 199) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +test_that("boot_smd_calc denom = 'rm' matches rm_correction = TRUE (paired)", { + set.seed(42) + r1 <- boot_smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "rm", R = 199) + set.seed(42) + r2 <- boot_smd_calc(x = x_pair, y = y_pair, paired = TRUE, rm_correction = TRUE, R = 199) + expect_equal(unname(r1$estimate), unname(r2$estimate)) + expect_equal(r1$conf.int, r2$conf.int) +}) + +# --- 7. Bootstrap: design-validity errors --- + +test_that("boot_smd_calc denom errors for invalid designs", { + expect_error( + boot_smd_calc(x = x_ind, y = y_ind, denom = "z", R = 99), + "denom = 'z' is not valid for independent samples designs." + ) + expect_error( + boot_smd_calc(x = x_pair, y = y_pair, paired = TRUE, denom = "pooled", R = 99), + "denom = 'pooled' is only valid for independent samples designs." + ) + expect_error( + boot_smd_calc(x = x_one, denom = "rm", R = 99), + "denom = 'rm' is only valid for paired samples designs." + ) +}) + +# --- 8. Bootstrap: override message emitted once --- + +test_that("boot_smd_calc emits message only once for override", { + msgs <- character(0) + withCallingHandlers( + boot_smd_calc(x = x_ind, y = y_ind, denom = "pooled", var.equal = FALSE, R = 99), + message = function(m) { + msgs <<- c(msgs, conditionMessage(m)) + invokeRestart("muffleMessage") + } + ) + override_msgs <- grep("overrides", msgs, value = TRUE) + expect_length(override_msgs, 1) +}) + +# --- 9. data.frame output also works with denom --- + +test_that("smd_calc data.frame output works with denom", { + r1 <- smd_calc(x = x_ind, y = y_ind, denom = "pooled", output = "data.frame") + r2 <- smd_calc(x = x_ind, y = y_ind, var.equal = TRUE, output = "data.frame") + expect_equal(r1$estimate, r2$estimate) + expect_equal(r1$SE, r2$SE) + expect_equal(r1$lower.ci, r2$lower.ci) + expect_equal(r1$upper.ci, r2$upper.ci) +}) + +# --- 10. Formula interface passes denom through --- + +test_that("smd_calc formula interface works with denom", { + df <- data.frame( + value = c(x_ind, y_ind), + group = factor(rep(c("A", "B"), each = 30)) + ) + r1 <- smd_calc(formula = value ~ group, data = df, denom = "pooled") + r2 <- smd_calc(formula = value ~ group, data = df, var.equal = TRUE) + expect_equal(unname(r1$estimate), unname(r2$estimate)) +}) diff --git a/tests/testthat/test-ftests.R b/tests/testthat/test-ftests.R index d78faa8..989b5dc 100644 --- a/tests/testthat/test-ftests.R +++ b/tests/testthat/test-ftests.R @@ -6,7 +6,7 @@ test_that("Equivalence F-tests",{ data('hawthorne') side_data = hawthorne hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-hodges_lehmann.R b/tests/testthat/test-hodges_lehmann.R index 05c41f1..bf78e1a 100644 --- a/tests/testthat/test-hodges_lehmann.R +++ b/tests/testthat/test-hodges_lehmann.R @@ -18,6 +18,7 @@ paired_y <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) # ============================================================================= test_that("hodges_lehmann returns htest object with all expected components", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199) @@ -40,6 +41,7 @@ test_that("hodges_lehmann returns htest object with all expected components", { }) test_that("hodges_lehmann keeps permutation distribution when keep_perm = TRUE", { + skip_on_cran() set.seed(123) result_keep <- hodges_lehmann(x_sample, y_sample, R = 99, keep_perm = TRUE) result_no_keep <- hodges_lehmann(x_sample, y_sample, R = 99, keep_perm = FALSE) @@ -130,7 +132,7 @@ test_that("one-sample hodges_lehmann works correctly (asymptotic)", { expect_true(grepl("One Sample", result$method)) expect_true(grepl("Asymptotic", result$method)) expect_equal(result$null.value, c("location" = 5)) - expect_named(result$estimate, "pseudomedian") + expect_named(result$estimate, "(pseudo)median of x") # P-value should be in valid range expect_gte(result$p.value, 0) @@ -141,6 +143,7 @@ test_that("one-sample hodges_lehmann works correctly (asymptotic)", { }) test_that("one-sample hodges_lehmann works correctly (permutation)", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, mu = 5, R = 199) @@ -150,6 +153,7 @@ test_that("one-sample hodges_lehmann works correctly (permutation)", { }) test_that("one-sample hodges_lehmann handles mu = 0 correctly", { + skip_on_cran() set.seed(123) # Generate data with mean noticeably different from 0 x_nonzero <- rnorm(20, mean = 3, sd = 1) @@ -171,10 +175,11 @@ test_that("two-sample hodges_lehmann works with asymptotic method", { expect_s3_class(result, "htest") expect_true(grepl("Two Sample", result$method)) expect_true(grepl("Asymptotic", result$method)) - expect_named(result$estimate, "difference in location") + expect_named(result$estimate, "Hodges-Lehmann estimate (x - y)") }) test_that("two-sample hodges_lehmann works with permutation method", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199) @@ -184,6 +189,7 @@ test_that("two-sample hodges_lehmann works with permutation method", { }) test_that("two-sample hodges_lehmann works with formula interface", { + skip_on_cran() set.seed(123) # Using built-in sleep data result <- hodges_lehmann(extra ~ group, data = sleep, R = 199) @@ -197,15 +203,17 @@ test_that("two-sample hodges_lehmann works with formula interface", { # ============================================================================= test_that("paired hodges_lehmann works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(paired_x, paired_y, paired = TRUE, R = 199) expect_s3_class(result, "htest") expect_true(grepl("Paired", result$method)) - expect_named(result$estimate, "pseudomedian of differences") + expect_named(result$estimate, "Hodges-Lehmann estimate (z = x - y)") }) test_that("paired hodges_lehmann detects significant difference", { + skip_on_cran() set.seed(123) # These paired samples have a consistent positive difference before <- c(5, 6, 7, 8, 9, 10, 11, 12) @@ -224,6 +232,7 @@ test_that("paired hodges_lehmann detects significant difference", { # ============================================================================= test_that("alternative = 'two.sided' works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "two.sided", R = 199) @@ -233,6 +242,7 @@ test_that("alternative = 'two.sided' works correctly", { }) test_that("alternative = 'less' works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "less", R = 199) @@ -242,6 +252,7 @@ test_that("alternative = 'less' works correctly", { }) test_that("alternative = 'greater' works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "greater", R = 199) @@ -250,11 +261,11 @@ test_that("alternative = 'greater' works correctly", { expect_equal(result$conf.int[2], Inf) }) -test_that("alternative = 'equivalence' works correctly", { +test_that("alternative = 'equivalence' works correctly (asymptotic)", { set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "equivalence", - mu = c(-2, 2), R = 199) + mu = c(-2, 2)) expect_equal(result$alternative, "equivalence") expect_length(result$null.value, 2) @@ -264,11 +275,11 @@ test_that("alternative = 'equivalence' works correctly", { expect_equal(attr(result$conf.int, "conf.level"), 0.90) }) -test_that("alternative = 'minimal.effect' works correctly", { +test_that("alternative = 'minimal.effect' works correctly (asymptotic)", { set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "minimal.effect", - mu = c(-2, 2), R = 199) + mu = c(-2, 2)) expect_equal(result$alternative, "minimal.effect") expect_length(result$null.value, 2) @@ -279,7 +290,7 @@ test_that("equivalence with single mu value creates symmetric bounds", { set.seed(123) result <- hodges_lehmann(x_sample, y_sample, alternative = "equivalence", - mu = 2, R = 199) + mu = 2) expect_equal(as.numeric(result$null.value), c(-2, 2)) }) @@ -289,6 +300,7 @@ test_that("equivalence with single mu value creates symmetric bounds", { # ============================================================================= test_that("scale = 'S1' works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199, scale = "S1") @@ -298,6 +310,7 @@ test_that("scale = 'S1' works correctly", { }) test_that("scale = 'S2' works correctly", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199, scale = "S2") @@ -307,6 +320,7 @@ test_that("scale = 'S2' works correctly", { }) test_that("different scale estimators can produce different results", { + skip_on_cran() set.seed(123) result_s1 <- hodges_lehmann(x_sample, y_sample, R = 199, scale = "S1") set.seed(123) @@ -325,6 +339,7 @@ test_that("different scale estimators can produce different results", { # ============================================================================= test_that("p_method = 'plusone' produces valid p-values", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199, p_method = "plusone") @@ -333,6 +348,7 @@ test_that("p_method = 'plusone' produces valid p-values", { }) test_that("p_method = 'exact' produces valid p-values", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199, p_method = "exact") @@ -341,6 +357,7 @@ test_that("p_method = 'exact' produces valid p-values", { }) test_that("p_method defaults to 'exact' for exact permutation", { + skip_on_cran() set.seed(123) small_x <- c(1, 2, 3, 4) small_y <- c(5, 6, 7) @@ -360,6 +377,7 @@ test_that("p_method defaults to 'exact' for exact permutation", { # ============================================================================= test_that("exact permutation is computed for small two-sample", { + skip_on_cran() set.seed(123) small_x <- c(1, 2, 3, 4) small_y <- c(5, 6, 7) @@ -376,6 +394,7 @@ test_that("exact permutation is computed for small two-sample", { }) test_that("exact permutation for one-sample small samples", { + skip_on_cran() set.seed(123) small_x <- c(1, 2, 3, 4, 5) @@ -390,6 +409,7 @@ test_that("exact permutation for one-sample small samples", { }) test_that("Randomization is used when R is specified and smaller than max perms", { + skip_on_cran() set.seed(123) # Large enough sample that R = 199 triggers Randomization result <- hodges_lehmann(x_sample, y_sample, R = 199) @@ -431,6 +451,7 @@ test_that("asymptotic CIs are finite for two-sided test", { # ============================================================================= test_that("hodges_lehmann handles NA values correctly", { + skip_on_cran() set.seed(123) x_na <- c(x_sample, NA, NA) y_na <- c(NA, y_sample, NA) @@ -441,6 +462,7 @@ test_that("hodges_lehmann handles NA values correctly", { }) test_that("paired test handles NA values correctly", { + skip_on_cran() set.seed(123) x_na <- c(paired_x, NA) y_na <- c(paired_y, NA) @@ -514,11 +536,35 @@ test_that("error for incorrect formula", { "'formula' missing or incorrect") }) +test_that("hodges_lehmann rejects permutation for equivalence/minimal.effect", { + set.seed(42) + x <- rnorm(20) + y <- rnorm(20, mean = 0.3) + + expect_error( + hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1), R = 999), + "Permutation tests.*not supported.*equivalence" + ) + + expect_error( + hodges_lehmann(x, y, alternative = "minimal.effect", mu = c(-1, 1), R = 999), + "Permutation tests.*not supported.*minimal.effect" + ) + + # Asymptotic versions should still work + res_eq <- hodges_lehmann(x, y, alternative = "equivalence", mu = c(-1, 1)) + expect_s3_class(res_eq, "htest") + + res_me <- hodges_lehmann(x, y, alternative = "minimal.effect", mu = c(-1, 1)) + expect_s3_class(res_me, "htest") +}) + # ============================================================================= # Reproducibility Tests # ============================================================================= test_that("results are reproducible with set.seed for permutation test", { + skip_on_cran() set.seed(42) result1 <- hodges_lehmann(x_sample, y_sample, R = 199) set.seed(42) @@ -543,6 +589,7 @@ test_that("asymptotic test is deterministic", { # ============================================================================= test_that("confidence level attribute is correct", { + skip_on_cran() result_two <- hodges_lehmann(x_sample, y_sample, alternative = "two.sided", alpha = 0.05, R = 199) expect_equal(attr(result_two$conf.int, "conf.level"), 0.95) @@ -552,11 +599,12 @@ test_that("confidence level attribute is correct", { expect_equal(attr(result_less$conf.int, "conf.level"), 0.95) result_equiv <- hodges_lehmann(x_sample, y_sample, alternative = "equivalence", - mu = c(-3, 3), alpha = 0.05, R = 199) + mu = c(-3, 3), alpha = 0.05) expect_equal(attr(result_equiv$conf.int, "conf.level"), 0.90) }) test_that("different alpha produces appropriate confidence intervals", { + skip_on_cran() set.seed(123) result_95 <- hodges_lehmann(x_sample, y_sample, alpha = 0.05, R = 299) @@ -574,6 +622,7 @@ test_that("different alpha produces appropriate confidence intervals", { # ============================================================================= test_that("method string reflects test type correctly", { + skip_on_cran() # Two-sample asymptotic result1 <- hodges_lehmann(x_sample, y_sample) expect_match(result1$method, "Asymptotic") @@ -598,6 +647,7 @@ test_that("method string reflects test type correctly", { # ============================================================================= test_that("permutation distribution has correct length", { + skip_on_cran() set.seed(123) R <- 199 result <- hodges_lehmann(x_sample, y_sample, R = R, keep_perm = TRUE) @@ -607,6 +657,7 @@ test_that("permutation distribution has correct length", { }) test_that("permutation distribution is numeric", { + skip_on_cran() set.seed(123) result <- hodges_lehmann(x_sample, y_sample, R = 199, keep_perm = TRUE) @@ -621,6 +672,7 @@ test_that("permutation distribution is numeric", { # ============================================================================= test_that("handles samples with equal values", { + skip_on_cran() set.seed(123) x_const <- rep(5, 10) @@ -632,6 +684,7 @@ test_that("handles samples with equal values", { }) test_that("handles samples with different variances", { + skip_on_cran() set.seed(123) x_low_var <- c(4, 5, 6) y_high_var <- c(2, 5, 8) # Same median, different variance @@ -642,6 +695,7 @@ test_that("handles samples with different variances", { }) test_that("handles very small samples for paired test", { + skip_on_cran() set.seed(123) x_tiny <- c(1, 2, 3) y_tiny <- c(2.1, 2.8, 4.2) @@ -675,6 +729,7 @@ test_that("direction of effect matches wilcox.test", { }) test_that("one-sided tests give appropriate p-values", { + skip_on_cran() set.seed(123) # x clearly less than y x_low <- c(1, 2, 3, 4, 5) @@ -695,6 +750,7 @@ test_that("one-sided tests give appropriate p-values", { # ============================================================================= test_that("print method works without error", { + skip_on_cran() result <- hodges_lehmann(x_sample, y_sample, R = 99) # Should print without error diff --git a/tests/testthat/test-htest.R b/tests/testthat/test-htest.R index 291fbdb..73e61ed 100644 --- a/tests/testthat/test-htest.R +++ b/tests/testthat/test-htest.R @@ -9,13 +9,20 @@ test_that("simple_htest: t-test & wilcox", { expect_equal(t.test(1:10, y = c(7:20, 200))$p.value, simple_htest(1:10, y = c(7:20, 200))$p.value) + # Note: simple_htest now returns 3 estimates (two group means + difference) + # and updated estimate labels, so describe_htest/df_htest output will differ + # from base t.test. Verify they still work without error: testy1 = describe_htest(simple_htest(1:10, y = c(7:20, 200))) testy2 = describe_htest(t.test(1:10, y = c(7:20, 200))) - expect_equal(testy1,testy2) + expect_type(testy1, "character") + expect_type(testy2, "character") testy1 = df_htest(simple_htest(1:10, y = c(7:20, 200))) testy2 = df_htest(t.test(1:10, y = c(7:20, 200))) - expect_equal(testy1,testy2) + expect_s3_class(testy1, "data.frame") + expect_s3_class(testy2, "data.frame") + # p-values should still match + expect_equal(testy1$p.value, testy2$p.value) testy1 = describe_htest(as_htest(t_TOST(1:10, y = c(7:20, 200), eqb = 3))) testy1 = describe_htest(as_htest(t_TOST(1:10, y = c(7:20, 200), eqb = 3, @@ -27,15 +34,20 @@ test_that("simple_htest: t-test & wilcox", { expect_equal(wilcox.test(1:10, y = c(7:20, 200))$p.value, simple_htest(1:10, y = c(7:20, 200), test = "w")$p.value) + # Note: simple_htest now relabels Wilcoxon estimates, so output will differ + # from base wilcox.test. Verify they still work and p-values match: testy1 = describe_htest(simple_htest(1:10, y = c(7:20, 200), test = "w")) testy2 = describe_htest(wilcox.test(1:10, y = c(7:20, 200), conf.int = TRUE)) - expect_equal(testy1,testy2) + expect_type(testy1, "character") + expect_type(testy2, "character") testy1 = df_htest(simple_htest(1:10, y = c(7:20, 200), test = "w")) testy2 = df_htest(wilcox.test(1:10, y = c(7:20, 200), conf.int = TRUE)) - expect_equal(testy1,testy2) + expect_s3_class(testy1, "data.frame") + expect_s3_class(testy2, "data.frame") + expect_equal(testy1$p.value, testy2$p.value) testy1 = describe_htest(as_htest(wilcox_TOST(1:10, y = c(7:20, 200), eqb = 3))) testy1 = describe_htest(as_htest(wilcox_TOST(1:10, y = c(7:20, 200), eqb = 3, @@ -114,6 +126,69 @@ test_that("simple_htest: t-test & wilcox", { NULL) }) +test_that("simple_htest always returns a numeric estimate", { + # Regression test: wilcox.test equivalence/MET were missing $estimate + # because the one-sided wilcox.test calls don't use conf.int = TRUE + + alternatives <- c("two.sided", "less", "greater", "equivalence", "minimal.effect") + tests <- c("t.test", "wilcox.test") + + # Two-sample + for (tst in tests) { + for (alt in alternatives) { + mu_val <- if (alt %in% c("equivalence", "minimal.effect")) 3 else 0 + res <- simple_htest(1:10, y = c(7:20), test = tst, + alternative = alt, mu = mu_val) + expect_true(is.numeric(res$estimate), + info = paste("two-sample", tst, alt, "estimate should be numeric")) + expect_true(length(res$estimate) >= 1, + info = paste("two-sample", tst, alt, "estimate should have length >= 1")) + } + } + + # Paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + + for (tst in tests) { + for (alt in alternatives) { + mu_val <- if (alt %in% c("equivalence", "minimal.effect")) 2 else 0 + res <- simple_htest(x_sleep, y_sleep, test = tst, paired = TRUE, + alternative = alt, mu = mu_val) + expect_true(is.numeric(res$estimate), + info = paste("paired", tst, alt, "estimate should be numeric")) + expect_true(length(res$estimate) >= 1, + info = paste("paired", tst, alt, "estimate should have length >= 1")) + } + } + + # One-sample + for (tst in tests) { + for (alt in alternatives) { + mu_val <- if (alt %in% c("equivalence", "minimal.effect")) 3 else 0 + res <- simple_htest(1:20, test = tst, + alternative = alt, mu = mu_val) + expect_true(is.numeric(res$estimate), + info = paste("one-sample", tst, alt, "estimate should be numeric")) + expect_true(length(res$estimate) >= 1, + info = paste("one-sample", tst, alt, "estimate should have length >= 1")) + } + } + + # Verify wilcox equivalence estimate matches the two-sided estimate + res_eq <- simple_htest(1:10, y = c(7:20), test = "wilcox.test", + alternative = "equivalence", mu = 3) + res_2s <- simple_htest(1:10, y = c(7:20), test = "wilcox.test", + alternative = "two.sided", mu = 0) + expect_equal(as.numeric(res_eq$estimate), as.numeric(res_2s$estimate)) + + # Same for MET + res_met <- simple_htest(1:10, y = c(7:20), test = "wilcox.test", + alternative = "minimal.effect", mu = 3) + expect_equal(as.numeric(res_met$estimate), as.numeric(res_2s$estimate)) +}) + test_that("brunner_munzel",{ set.seed(2808) diff --git a/tests/testthat/test-htest_output_updates.R b/tests/testthat/test-htest_output_updates.R new file mode 100644 index 0000000..be03963 --- /dev/null +++ b/tests/testthat/test-htest_output_updates.R @@ -0,0 +1,450 @@ +# Tests for htest output updates: +# - Estimate labeling and mean difference appending +# - Sample size in output +# - Formula interface group name substitution +# - quote_if_numeric() quoting of numeric factor levels + +hush = function(code) { + sink(nullfile()) + on.exit(sink()) + suppressMessages(code) +} + +# =========================================================================== +# simple_htest tests +# =========================================================================== + +test_that("simple_htest t-test: two-sample estimate has 3 elements with correct structure", { + res <- hush(simple_htest(1:10, y = c(7:20), mu = 0)) + + # Should have 3 estimates: mean of group x, mean of group y, mean difference + expect_equal(length(res$estimate), 3) + expect_equal(names(res$estimate)[1], "mean of group x") + expect_equal(names(res$estimate)[2], "mean of group y") + expect_true(grepl("mean difference", names(res$estimate)[3])) + expect_true(grepl("x - y", names(res$estimate)[3])) + + # Third element should equal first minus second + expect_equal(unname(res$estimate[3]), + unname(res$estimate[1] - res$estimate[2])) + + # Backwards compatibility: positional indexing still works + expect_equal(unname(res$estimate[1]), mean(1:10)) + expect_equal(unname(res$estimate[2]), mean(7:20)) + + # Named indexing with new labels + expect_equal(unname(res$estimate["mean of group x"]), mean(1:10)) + expect_equal(unname(res$estimate["mean of group y"]), mean(7:20)) +}) + +test_that("simple_htest t-test: paired label", { + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res <- hush(simple_htest(x_sleep, y_sleep, paired = TRUE, mu = 0)) + + expect_equal(length(res$estimate), 1) + expect_equal(names(res$estimate), "mean of the differences (z = x - y)") +}) + +test_that("simple_htest t-test: one-sample label unchanged", { + res <- hush(simple_htest(1:20, mu = 0)) + expect_equal(length(res$estimate), 1) + expect_equal(names(res$estimate), "mean of x") +}) + +test_that("simple_htest wilcox: estimate labels", { + # One-sample + res_one <- hush(simple_htest(1:20, test = "w", mu = 0)) + expect_equal(names(res_one$estimate), "(pseudo)median of x") + + # Paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res_paired <- hush(simple_htest(x_sleep, y_sleep, test = "w", + paired = TRUE, mu = 0)) + expect_equal(names(res_paired$estimate), "Hodges-Lehmann estimate (z = x - y)") + + # Two-sample + res_two <- hush(simple_htest(1:10, y = c(7:20), test = "w", mu = 0)) + expect_equal(names(res_two$estimate), "Hodges-Lehmann estimate (x - y)") +}) + +test_that("simple_htest: formula interface substitutes group names with quoting", { + data(sleep) + res <- hush(simple_htest(extra ~ group, data = sleep, mu = 0)) + nms <- names(res$estimate) + # sleep$group levels are "1" and "2" -> should be quoted as '1' and '2' + expect_equal(nms[1], "mean of group '1'") + expect_equal(nms[2], "mean of group '2'") + expect_true(grepl("'1' - '2'", nms[3])) + + # Wilcoxon formula + res_w <- hush(simple_htest(extra ~ group, data = sleep, test = "w", mu = 0)) + expect_true(grepl("'1' - '2'", names(res_w$estimate))) +}) + +test_that("simple_htest: formula with non-numeric factor levels", { + # Create data with text factor levels + df <- data.frame( + value = c(rnorm(10, 20), rnorm(10, 25)), + group = factor(rep(c("auto", "manual"), each = 10)) + ) + res <- hush(simple_htest(value ~ group, data = df, mu = 0)) + nms <- names(res$estimate) + # Text levels should NOT be quoted + expect_equal(nms[1], "mean of group auto") + expect_equal(nms[2], "mean of group manual") + expect_true(grepl("auto - manual", nms[3])) +}) + +test_that("simple_htest: sample_size correctness", { + # One-sample + res_one <- hush(simple_htest(1:20, mu = 0)) + expect_equal(res_one$sample_size, c(n = 20L)) + + # Two-sample + res_two <- hush(simple_htest(1:10, y = c(7:20), mu = 0)) + expect_equal(res_two$sample_size, c(nx = 10L, ny = 14L)) + + # Paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res_paired <- hush(simple_htest(x_sleep, y_sleep, paired = TRUE, mu = 0)) + expect_equal(res_paired$sample_size, c(n = 10L)) + + # Paired with NAs + x_na <- c(1, 2, NA, 4, 5, 3, 7) + y_na <- c(6, NA, 8, 9, 10, 2, 5) + res_na <- hush(simple_htest(x_na, y_na, paired = TRUE, mu = 0)) + expect_equal(res_na$sample_size, c(n = 5L)) # 5 complete pairs (indices 1,4,5,6,7) + + # Formula interface: names should be group levels + res_formula <- hush(simple_htest(extra ~ group, data = sleep, mu = 0)) + expect_equal(names(res_formula$sample_size), c("1", "2")) + expect_equal(unname(res_formula$sample_size), c(10L, 10L)) +}) + +test_that("simple_htest: equivalence/MET paths work with new estimate structure", { + # Equivalence t-test two-sample + res_eq <- hush(simple_htest(1:10, y = c(7:20), alternative = "e", mu = 3)) + expect_equal(length(res_eq$estimate), 3) + expect_true(grepl("mean difference", names(res_eq$estimate)[3])) + expect_equal(unname(res_eq$estimate[3]), + unname(res_eq$estimate[1] - res_eq$estimate[2])) + + # Equivalence wilcox two-sample + res_eq_w <- hush(simple_htest(1:10, y = c(7:20), test = "w", + alternative = "e", mu = 3)) + expect_equal(names(res_eq_w$estimate), "Hodges-Lehmann estimate (x - y)") + + # MET t-test paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res_met <- hush(simple_htest(x_sleep, y_sleep, paired = TRUE, + alternative = "m", mu = 2)) + expect_equal(names(res_met$estimate), "mean of the differences (z = x - y)") +}) + +# =========================================================================== +# boot_t_test tests +# =========================================================================== + +test_that("boot_t_test with tr == 0 inherits from simple_htest correctly", { + set.seed(123) + res <- hush(boot_t_test(1:10, y = c(7:20), mu = 0, R = 99)) + + # Should inherit 3-element estimate from simple_htest + expect_equal(length(res$estimate), 3) + expect_true(grepl("mean difference", names(res$estimate)[3])) + expect_equal(unname(res$estimate[3]), + unname(res$estimate[1] - res$estimate[2])) + + # sample_size should be inherited + expect_equal(res$sample_size, c(nx = 10L, ny = 14L)) +}) + +test_that("boot_t_test with tr > 0: two-sample estimate has 3 elements", { + set.seed(123) + tr_val <- 0.1 + res <- hush(boot_t_test(1:10, y = c(7:20), mu = 0, tr = tr_val, R = 99)) + + expect_equal(length(res$estimate), 3) + expect_equal(names(res$estimate)[1], "trimmed mean of x") + expect_equal(names(res$estimate)[2], "trimmed mean of y") + expect_true(grepl("trimmed mean difference", names(res$estimate)[3])) + expect_true(grepl(as.character(tr_val), names(res$estimate)[3])) + + # Third element should equal first minus second + expect_equal(unname(res$estimate[3]), + unname(res$estimate[1] - res$estimate[2])) +}) + +test_that("boot_t_test with tr > 0: paired label includes tr", { + set.seed(123) + tr_val <- 0.2 + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res <- hush(boot_t_test(x_sleep, y_sleep, paired = TRUE, + mu = 0, tr = tr_val, R = 99)) + + expect_equal(length(res$estimate), 1) + expect_true(grepl("x - y", names(res$estimate))) + expect_true(grepl(as.character(tr_val), names(res$estimate))) +}) + +test_that("boot_t_test: sample_size for tr > 0", { + set.seed(123) + # Two-sample + res_two <- hush(boot_t_test(1:10, y = c(7:20), mu = 0, tr = 0.1, R = 99)) + expect_equal(res_two$sample_size, c(nx = 10L, ny = 14L)) + + # One-sample + res_one <- hush(boot_t_test(1:20, mu = 0, tr = 0.1, R = 99)) + expect_equal(res_one$sample_size, c(n = 20L)) + + # Paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res_paired <- hush(boot_t_test(x_sleep, y_sleep, paired = TRUE, + mu = 0, tr = 0.1, R = 99)) + expect_equal(res_paired$sample_size, c(n = 10L)) +}) + +test_that("boot_t_test: formula interface substitutes group names", { + set.seed(123) + data(sleep) + res <- hush(boot_t_test(extra ~ group, data = sleep, mu = 0, R = 99)) + + nms <- names(res$estimate) + expect_true(grepl("'1'", nms[1])) + expect_true(grepl("'2'", nms[2])) + expect_true(grepl("'1' - '2'", nms[3])) + expect_equal(names(res$sample_size), c("1", "2")) + + # With trimming + set.seed(123) + res_tr <- hush(boot_t_test(extra ~ group, data = sleep, + mu = 0, tr = 0.1, R = 99)) + nms_tr <- names(res_tr$estimate) + expect_true(grepl("trimmed mean of '1'", nms_tr[1])) + expect_true(grepl("trimmed mean of '2'", nms_tr[2])) + expect_true(grepl("'1' - '2'", nms_tr[3])) +}) + +test_that("boot_t_test: null.value names include tr for tr > 0", { + set.seed(123) + tr_val <- 0.1 + res <- hush(boot_t_test(1:10, y = c(7:20), + mu = c(-3, 3), alternative = "equivalence", + tr = tr_val, R = 99)) + expect_true(grepl(as.character(tr_val), names(res$null.value)[1])) +}) + +# =========================================================================== +# perm_t_test tests +# =========================================================================== + +test_that("perm_t_test: two-sample estimate has 3 elements", { + set.seed(123) + res <- hush(perm_t_test(1:10, y = c(7:20), mu = 0, R = 99)) + + expect_equal(length(res$estimate), 3) + expect_equal(names(res$estimate)[1], "mean of group x") + expect_equal(names(res$estimate)[2], "mean of group y") + expect_equal(names(res$estimate)[3], "mean difference (x - y)") + expect_equal(unname(res$estimate[3]), + unname(res$estimate[1] - res$estimate[2])) +}) + +test_that("perm_t_test: paired label with and without trimming", { + set.seed(123) + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + + # Without trimming + res <- hush(perm_t_test(x_sleep, y_sleep, paired = TRUE, mu = 0, R = 99)) + expect_equal(names(res$estimate), "mean of the differences (z = x - y)") + + # With trimming + set.seed(123) + tr_val <- 0.1 + res_tr <- hush(perm_t_test(x_sleep, y_sleep, paired = TRUE, + mu = 0, tr = tr_val, R = 99)) + expect_true(grepl("x - y", names(res_tr$estimate))) + expect_true(grepl(as.character(tr_val), names(res_tr$estimate))) +}) + +test_that("perm_t_test: trimmed two-sample includes tr in label", { + set.seed(123) + tr_val <- 0.1 + res <- hush(perm_t_test(1:10, y = c(7:20), mu = 0, tr = tr_val, R = 99)) + + expect_equal(length(res$estimate), 3) + expect_true(grepl("trimmed mean of x", names(res$estimate)[1])) + expect_true(grepl("trimmed mean of y", names(res$estimate)[2])) + expect_true(grepl(as.character(tr_val), names(res$estimate)[3])) +}) + +test_that("perm_t_test: sample_size correctness", { + set.seed(123) + # Two-sample + res <- hush(perm_t_test(1:10, y = c(7:20), mu = 0, R = 99)) + expect_equal(res$sample_size, c(nx = 10L, ny = 14L)) + + # One-sample + res_one <- hush(perm_t_test(1:20, mu = 0, R = 99)) + expect_equal(res_one$sample_size, c(n = 20L)) + + # Paired + data(sleep) + x_sleep <- sleep$extra[sleep$group == 1] + y_sleep <- sleep$extra[sleep$group == 2] + res_paired <- hush(perm_t_test(x_sleep, y_sleep, paired = TRUE, + mu = 0, R = 99)) + expect_equal(res_paired$sample_size, c(n = 10L)) +}) + +test_that("perm_t_test: formula interface substitutes group names", { + set.seed(123) + data(sleep) + res <- hush(perm_t_test(extra ~ group, data = sleep, mu = 0, R = 99)) + + nms <- names(res$estimate) + expect_true(grepl("'1'", nms[1])) + expect_true(grepl("'2'", nms[2])) + expect_true(grepl("'1' - '2'", nms[3])) + expect_equal(names(res$sample_size), c("1", "2")) +}) + +# =========================================================================== +# hodges_lehmann tests +# =========================================================================== + +test_that("hodges_lehmann: estimate labels", { + # One-sample + res_one <- hush(hodges_lehmann(1:20, mu = 0)) + expect_equal(names(res_one$estimate), "(pseudo)median of x") + + # Paired + before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8) + after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) + res_paired <- hush(hodges_lehmann(before, after, paired = TRUE, mu = 0)) + expect_equal(names(res_paired$estimate), "Hodges-Lehmann estimate (z = x - y)") + + # Two-sample + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, mean = 0.5) + res_two <- hush(hodges_lehmann(x, y, mu = 0)) + expect_equal(names(res_two$estimate), "Hodges-Lehmann estimate (x - y)") + expect_equal(length(res_two$estimate), 1) # always single value +}) + +test_that("hodges_lehmann: sample_size correctness", { + # One-sample + res_one <- hush(hodges_lehmann(1:20, mu = 0)) + expect_equal(res_one$sample_size, c(n = 20L)) + + # Two-sample + set.seed(123) + x <- rnorm(15) + y <- rnorm(20) + res_two <- hush(hodges_lehmann(x, y, mu = 0)) + expect_equal(res_two$sample_size, c(nx = 15L, ny = 20L)) + + # Paired + before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8) + after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) + res_paired <- hush(hodges_lehmann(before, after, paired = TRUE, mu = 0)) + expect_equal(res_paired$sample_size, c(n = 8L)) +}) + +test_that("hodges_lehmann: formula interface substitutes group names with quoting", { + data(sleep) + res <- hush(hodges_lehmann(extra ~ group, data = sleep, mu = 0)) + + # sleep$group levels "1"/"2" should be quoted + expect_true(grepl("'1' - '2'", names(res$estimate))) + expect_equal(names(res$sample_size), c("1", "2")) +}) + +test_that("hodges_lehmann: equivalence/MET paths work with updated labels", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, mean = 0.5) + + # Equivalence (asymptotic only — permutation not supported for equivalence/MET) + res_eq <- hush(hodges_lehmann(x, y, alternative = "equivalence", + mu = c(-1, 1))) + expect_equal(names(res_eq$estimate), "Hodges-Lehmann estimate (x - y)") + expect_true(!is.null(res_eq$sample_size)) + + # MET (asymptotic only) + res_met <- hush(hodges_lehmann(x, y, alternative = "minimal.effect", + mu = c(-1, 1))) + expect_equal(names(res_met$estimate), "Hodges-Lehmann estimate (x - y)") +}) + +# =========================================================================== +# Cross-function consistency tests +# =========================================================================== + +test_that("Formula interface group names are consistent across functions", { + data(sleep) + + res_simple <- hush(simple_htest(extra ~ group, data = sleep, mu = 0)) + set.seed(1) + res_boot <- hush(boot_t_test(extra ~ group, data = sleep, mu = 0, R = 99)) + set.seed(1) + res_perm <- hush(perm_t_test(extra ~ group, data = sleep, mu = 0, R = 99)) + res_hl <- hush(hodges_lehmann(extra ~ group, data = sleep, mu = 0)) + + # All should have group-named sample sizes + for (res in list(res_simple, res_boot, res_perm, res_hl)) { + expect_equal(names(res$sample_size), c("1", "2"), + info = paste("Failed for", res$method)) + } + + # Mean-based tests should all have 3 estimates with quoted group names + for (res in list(res_simple, res_boot, res_perm)) { + expect_equal(length(res$estimate), 3, + info = paste("Failed for", res$method)) + expect_true(grepl("'1' - '2'", names(res$estimate)[3]), + info = paste("Failed for", res$method)) + } + + # HL should have 1 estimate with quoted group names + expect_equal(length(res_hl$estimate), 1) + expect_true(grepl("'1' - '2'", names(res_hl$estimate))) +}) + +test_that("quote_if_numeric quotes numeric names and leaves text names alone", { + # Numeric names get quoted + expect_equal(TOSTER:::quote_if_numeric("0"), "'0'") + expect_equal(TOSTER:::quote_if_numeric("1"), "'1'") + expect_equal(TOSTER:::quote_if_numeric("3.14"), "'3.14'") + expect_equal(TOSTER:::quote_if_numeric("-2"), "'-2'") + + # Non-numeric names are unchanged + expect_equal(TOSTER:::quote_if_numeric("auto"), "auto") + expect_equal(TOSTER:::quote_if_numeric("group_A"), "group_A") + expect_equal(TOSTER:::quote_if_numeric("1a"), "1a") +}) + +test_that("relabel_for_formula is idempotent on non-matching patterns", { + # Create a fake result with labels that don't match patterns + fake <- list(estimate = c(a = 1, b = 2), sample_size = c(n = 10)) + result <- relabel_for_formula(fake, c("groupA", "groupB")) + # Should be unchanged since "of x"/"of y" patterns don't appear + + expect_equal(names(result$estimate), c("a", "b")) + # sample_size with length 1 should not be renamed + expect_equal(names(result$sample_size), "n") +}) diff --git a/tests/testthat/test-known_results.R b/tests/testthat/test-known_results.R index 8fa9144..94657b4 100644 --- a/tests/testthat/test-known_results.R +++ b/tests/testthat/test-known_results.R @@ -3,7 +3,7 @@ test_that("Test that one-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -33,7 +33,7 @@ test_that("Test that one-sample t-test output is same as previous version", { test_that("Test that raw one-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -62,7 +62,7 @@ test_that("Test that raw one-sample t-test output is same as previous version", test_that("Test that two-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -96,7 +96,7 @@ test_that("Test that two-sample t-test output is same as previous version", { test_that("Test that raw two-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -129,7 +129,7 @@ test_that("Test that raw two-sample t-test output is same as previous version", test_that("Test that paired two-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -157,7 +157,7 @@ test_that("Test that paired two-sample t-test output is same as previous version test_that("Test that raw paired two-sample t-test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -185,7 +185,7 @@ test_that("Test that raw paired two-sample t-test output is same as previous ver test_that("Test that correlation test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -211,7 +211,7 @@ test_that("Test that correlation test output is same as previous version", { test_that("Test that meta test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -238,7 +238,7 @@ test_that("Test that meta test output is same as previous version", { test_that("Test that two proportions test output is same as previous version", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-log.R b/tests/testthat/test-log.R index 01ed476..b2c3025 100644 --- a/tests/testthat/test-log.R +++ b/tests/testthat/test-log.R @@ -1,7 +1,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -9,6 +9,7 @@ hush = function(code) { test_that("Run examples for two sample", { + skip_on_cran() set.seed(2525894) dat1 = mtcars @@ -112,11 +113,12 @@ test_that("Run examples for two sample", { test_that("Run examples for paired samples", { + skip_on_cran() set.seed(922287) sleep2 = sleep sleep2$sleep = sleep2$extra + 4 - + # Test error for negative values in extra column (using vectors for paired test) expect_error(boot_log_TOST( x = sleep2$extra[sleep2$group == 1], @@ -256,3 +258,33 @@ test_that("Run examples for paired samples", { ) }) + +# boot_log_TOST CI/p-value agreement tests ----- + +for (ci_method in c("perc", "basic", "bca", "stud")) { + test_that(paste0("boot_log_TOST: CI/p-value agreement for ", ci_method), { + skip_on_cran() + + set.seed(42) + x <- rlnorm(30, meanlog = 3.5, sdlog = 0.4) + y <- rlnorm(30, meanlog = 3.6, sdlog = 0.4) + + hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) + } + + res <- hush(boot_log_TOST(x = x, y = y, eqb = 1.25, + boot_ci = ci_method, R = 1999)) + # Check two-sided on log scale with 90% CI (TOST uses 1-2*alpha = 90%) + # 90% CI excludes null iff two-sided p < 2*alpha = 0.10 + ci <- c(res$effsize$lower.ci[1], res$effsize$upper.ci[1]) + log_null <- log(1) # = 0 + ci_excludes_null <- ci[1] > log_null || ci[2] < log_null + p_rejects <- res$TOST$p.value[1] < 0.10 + expect_equal(ci_excludes_null, p_rejects, + label = paste(ci_method, "CI/p agreement two.sided")) + }) +} diff --git a/tests/testthat/test-old_errors.R b/tests/testthat/test-old_errors.R index 747d0db..a31362c 100644 --- a/tests/testthat/test-old_errors.R +++ b/tests/testthat/test-old_errors.R @@ -1,7 +1,7 @@ test_that("Errors for TOSTtwo functions",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -52,7 +52,7 @@ test_that("Errors for TOSTtwo functions",{ test_that("Errors for TOSTpaired functions",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -111,7 +111,7 @@ test_that("Errors for TOSTpaired functions",{ test_that("Errors for TOSTmeta",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -149,7 +149,7 @@ test_that("Errors for TOSTmeta",{ test_that("Errors for TOSTone",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -216,7 +216,7 @@ test_that("Errors for TOSTone",{ test_that("Errors for TOSTr",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-perm_t_test.R b/tests/testthat/test-perm_t_test.R index a5c3dae..157ebd1 100644 --- a/tests/testthat/test-perm_t_test.R +++ b/tests/testthat/test-perm_t_test.R @@ -18,6 +18,7 @@ paired_y <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) test_that("perm_t_test returns htest object with all expected components", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, R = 199) @@ -42,6 +43,7 @@ test_that("perm_t_test returns htest object with all expected components", { }) test_that("perm_t_test keeps permutation distribution when keep_perm = TRUE", { + skip_on_cran() set.seed(123) result_keep <- perm_t_test(x_sample, y_sample, R = 99, keep_perm = TRUE) result_no_keep <- perm_t_test(x_sample, y_sample, R = 99, keep_perm = FALSE) @@ -57,6 +59,7 @@ test_that("perm_t_test keeps permutation distribution when keep_perm = TRUE", { test_that("one-sample perm_t_test works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, mu = 5, R = 199) @@ -75,6 +78,7 @@ test_that("one-sample perm_t_test works correctly", { }) test_that("one-sample perm_t_test handles mu = 0 correctly", { + skip_on_cran() set.seed(123) # Generate data with mean noticeably different from 0 x_nonzero <- rnorm(20, mean = 3, sd = 1) @@ -88,17 +92,19 @@ test_that("one-sample perm_t_test handles mu = 0 correctly", { # Two-Sample Tests----------------- test_that("two-sample perm_t_test works with default settings", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, R = 199) expect_s3_class(result, "htest") expect_true(grepl("Two Sample", result$method)) expect_true(grepl("Welch", result$method)) # Default is var.equal = FALSE - expect_length(result$estimate, 2) - expect_named(result$estimate, c("mean of x", "mean of y")) + expect_length(result$estimate, 3) + expect_named(result$estimate, c("mean of group x", "mean of group y", "mean difference (x - y)")) }) test_that("two-sample perm_t_test works with var.equal = TRUE", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, var.equal = TRUE, R = 199) @@ -108,6 +114,7 @@ test_that("two-sample perm_t_test works with var.equal = TRUE", { }) test_that("two-sample perm_t_test works with formula interface", { + skip_on_cran() set.seed(123) # Using built-in sleep data result <- perm_t_test(extra ~ group, data = sleep, R = 199) @@ -120,15 +127,17 @@ test_that("two-sample perm_t_test works with formula interface", { # Paired Tests----------------- test_that("paired perm_t_test works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(paired_x, paired_y, paired = TRUE, R = 199) expect_s3_class(result, "htest") expect_true(grepl("Paired", result$method)) - expect_named(result$estimate, "mean of the differences") + expect_named(result$estimate, "mean of the differences (z = x - y)") }) test_that("paired perm_t_test detects significant difference", { + skip_on_cran() set.seed(123) # These paired samples have a consistent positive difference with some variability before <- c(5, 6, 7, 8, 9, 10, 11, 12) @@ -145,6 +154,7 @@ test_that("paired perm_t_test detects significant difference", { # Alternative Hypotheses ----------------- test_that("alternative = 'two.sided' works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "two.sided", R = 199) @@ -154,6 +164,7 @@ test_that("alternative = 'two.sided' works correctly", }) test_that("alternative = 'less' works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "less", R = 199) @@ -163,6 +174,7 @@ test_that("alternative = 'less' works correctly", { }) test_that("alternative = 'greater' works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "greater", R = 199) @@ -172,6 +184,7 @@ test_that("alternative = 'greater' works correctly", { }) test_that("alternative = 'equivalence' works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "equivalence", @@ -186,6 +199,7 @@ test_that("alternative = 'equivalence' works correctly", { }) test_that("alternative = 'minimal.effect' works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "minimal.effect", @@ -197,6 +211,7 @@ test_that("alternative = 'minimal.effect' works correctly", { }) test_that("equivalence with single mu value creates symmetric bounds", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "equivalence", @@ -209,23 +224,29 @@ test_that("equivalence with single mu value creates symmetric bounds", { # Trimming (Yuen's Test) ----------------- test_that("trimmed t-test (tr > 0) works correctly", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, tr = 0.1, R = 199) expect_s3_class(result, "htest") expect_true(grepl("Yuen", result$method)) - expect_named(result$estimate, c("trimmed mean of x", "trimmed mean of y")) + expect_equal(length(result$estimate), 3) + expect_equal(names(result$estimate)[1:2], + c("trimmed mean of x", "trimmed mean of y")) + expect_true(grepl("trimmed mean difference", names(result$estimate)[3])) }) test_that("one-sample trimmed t-test works", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, mu = 5, tr = 0.2, R = 199) expect_true(grepl("Yuen", result$method)) - expect_named(result$estimate, "trimmed mean of x") + expect_true(grepl("trimmed mean of x", names(result$estimate))) }) test_that("paired trimmed t-test works", { + skip_on_cran() set.seed(123) result <- perm_t_test(paired_x, paired_y, paired = TRUE, tr = 0.1, R = 199) @@ -237,6 +258,7 @@ test_that("paired trimmed t-test works", { # P-value Method Tests ----------------- test_that("p_method = 'plusone' produces valid p-values", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, R = 199, p_method = "plusone") @@ -245,6 +267,7 @@ test_that("p_method = 'plusone' produces valid p-values", { }) test_that("p_method = 'exact' produces valid p-values", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, R = 199, p_method = "exact") @@ -253,6 +276,7 @@ test_that("p_method = 'exact' produces valid p-values", { }) test_that("different p_methods can produce different results", { + skip_on_cran() set.seed(123) result_plus <- perm_t_test(x_sample, y_sample, R = 99, p_method = "plusone") set.seed(123) @@ -267,6 +291,7 @@ test_that("different p_methods can produce different results", { # Studentized vs Non-Studentized Tests----------------- test_that("perm_se = TRUE (studentized) produces valid results", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, perm_se = TRUE, R = 199) @@ -276,6 +301,7 @@ test_that("perm_se = TRUE (studentized) produces valid results", { }) test_that("perm_se = FALSE (non-studentized) produces valid results", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, perm_se = FALSE, R = 199) @@ -285,6 +311,7 @@ test_that("perm_se = FALSE (non-studentized) produces valid results", { }) test_that("studentized and non-studentized can produce different results", { + skip_on_cran() set.seed(123) result_stud <- perm_t_test(x_sample, y_sample, perm_se = TRUE, R = 199) set.seed(123) @@ -303,6 +330,7 @@ test_that("studentized and non-studentized can produce different results", { # Symmetric vs Equal-Tail Two-Sided Tests----------------- test_that("symmetric = TRUE works for two-sided test", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "two.sided", @@ -313,6 +341,7 @@ test_that("symmetric = TRUE works for two-sided test", { }) test_that("symmetric = FALSE works for two-sided test", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, alternative = "two.sided", @@ -326,6 +355,7 @@ test_that("symmetric = FALSE works for two-sided test", { # Exact Permutation Tests----------------- test_that("exact permutation is computed for small samples", { + skip_on_cran() set.seed(123) small_x <- c(1, 2, 3, 4) small_y <- c(5, 6, 7) @@ -343,6 +373,7 @@ test_that("exact permutation is computed for small samples", { }) test_that("exact permutation for one-sample small samples", { + skip_on_cran() set.seed(123) small_x <- c(1, 2, 3, 4, 5) @@ -357,6 +388,7 @@ test_that("exact permutation for one-sample small samples", { }) test_that("Randomization is used when R is specified and smaller than max perms", { + skip_on_cran() set.seed(123) # Large enough sample that R = 199 triggers Randomization result <- perm_t_test(x_sample, y_sample, R = 199) @@ -369,6 +401,7 @@ test_that("Randomization is used when R is specified and smaller than max perms" # Missing Value Handling ----------------- test_that("perm_t_test handles NA values correctly", { + skip_on_cran() set.seed(123) x_na <- c(x_sample, NA, NA) y_na <- c(NA, y_sample, NA) @@ -379,6 +412,7 @@ test_that("perm_t_test handles NA values correctly", { # Should work with reduced sample }) test_that("paired test handles NA values correctly", { + skip_on_cran() set.seed(123) x_na <- c(paired_x, NA) y_na <- c(paired_y, NA) @@ -463,6 +497,7 @@ test_that("error for incorrect formula", { # Reproducibility Tests ----------------- test_that("results are reproducible with set.seed", { + skip_on_cran() set.seed(42) result1 <- perm_t_test(x_sample, y_sample, R = 199) set.seed(42) @@ -477,6 +512,7 @@ test_that("results are reproducible with set.seed", { # Specific Value Tests (Regression Tests) ----------------- test_that("t-statistic matches expected calculation", { + skip_on_cran() set.seed(123) x <- c(1, 2, 3, 4, 5) y <- c(6, 7, 8, 9, 10) @@ -495,6 +531,7 @@ test_that("t-statistic matches expected calculation", { }) test_that("one-sample t-statistic matches expected calculation", { + skip_on_cran() x <- c(1, 2, 3, 4, 5) mu <- 2 @@ -509,6 +546,7 @@ test_that("one-sample t-statistic matches expected calculation", { }) test_that("degrees of freedom are correct for two-sample Welch test", { + skip_on_cran() x <- c(1, 2, 3, 4, 5) y <- c(6, 7, 8, 9, 10) @@ -528,6 +566,7 @@ test_that("degrees of freedom are correct for two-sample Welch test", { }) test_that("degrees of freedom are correct for two-sample pooled test", { + skip_on_cran() x <- c(1, 2, 3, 4, 5) y <- c(6, 7, 8, 9, 10) @@ -541,6 +580,7 @@ test_that("degrees of freedom are correct for two-sample pooled test", { # Confidence Interval Tests----------------- test_that("confidence intervals have correct coverage property conceptually", { + skip_on_cran() set.seed(123) # Generate data where true difference is 0 x_null <- rnorm(20, mean = 5, sd = 2) @@ -555,6 +595,7 @@ test_that("confidence intervals have correct coverage property conceptually", { }) test_that("confidence level attribute is correct", { + skip_on_cran() result_two <- perm_t_test(x_sample, y_sample, alternative = "two.sided", alpha = 0.05, R = 199) expect_equal(attr(result_two$conf.int, "conf.level"), 0.95) @@ -572,6 +613,7 @@ test_that("confidence level attribute is correct", { # Method String Tests----------------- test_that("method string reflects test type correctly", { + skip_on_cran() # Two-sample Welch result1 <- perm_t_test(x_sample, y_sample, var.equal = FALSE, R = 199) expect_match(result1$method, "Welch") @@ -599,6 +641,7 @@ test_that("method string reflects test type correctly", { # Permutation Distribution Tests----------------- test_that("permutation distribution has correct length", { + skip_on_cran() set.seed(123) R <- 199 result <- perm_t_test(x_sample, y_sample, R = R, keep_perm = TRUE) @@ -608,6 +651,7 @@ test_that("permutation distribution has correct length", { }) test_that("permutation distribution is numeric", { + skip_on_cran() set.seed(123) result <- perm_t_test(x_sample, y_sample, R = 199, keep_perm = TRUE) @@ -621,6 +665,7 @@ test_that("permutation distribution is numeric", { # Edge Cases ----------------- test_that("handles equal samples", { + skip_on_cran() set.seed(123) x_eq <- c(1, 2, 3, 4, 5) @@ -631,6 +676,7 @@ test_that("handles equal samples", { }) test_that("handles samples with equal means but different variances", { + skip_on_cran() set.seed(123) x_same_mean <- c(4, 5, 6) y_same_mean <- c(2, 5, 8) # Same mean, different variance @@ -644,6 +690,7 @@ test_that("handles samples with equal means but different variances", { }) test_that("handles very small samples for paired test", { + skip_on_cran() set.seed(123) x_tiny <- c(1, 2, 3) y_tiny <- c(2.1, 2.8, 4.2) # Add variability to differences @@ -661,13 +708,14 @@ test_that("handles very small samples for paired test", { # Comparison with Standard t.test (Direction Consistency) ----------------- test_that("direction of effect matches t.test", { + skip_on_cran() set.seed(123) # Clear difference: x < y x_low <- c(1, 2, 3, 4, 5) y_high <- c(10, 11, 12, 13, 14) perm_result <- perm_t_test(x_low, y_high, R = 199) - t_result <- t.test(x_low, y_high) + t_result <- simple_htest(x_low, y_high, test = "t") # Signs should match (compare numeric values without names) @@ -680,6 +728,7 @@ test_that("direction of effect matches t.test", { }) test_that("one-sided tests give appropriate p-values", { + skip_on_cran() set.seed(123) # x clearly less than y x_low <- c(1, 2, 3, 4, 5) @@ -698,6 +747,7 @@ test_that("one-sided tests give appropriate p-values", { # Alpha Level Tests ----------------- test_that("different alpha levels produce appropriate confidence intervals", { + skip_on_cran() set.seed(123) result_05 <- perm_t_test(x_sample, y_sample, alpha = 0.05, R = 299) @@ -714,6 +764,7 @@ test_that("different alpha levels produce appropriate confidence intervals", { # Print Method Test----------------- test_that("print method works without error", { + skip_on_cran() result <- perm_t_test(x_sample, y_sample, R = 99) # Should print without error diff --git a/tests/testthat/test-power_consistent.R b/tests/testthat/test-power_consistent.R index 758989a..ebb9fb5 100644 --- a/tests/testthat/test-power_consistent.R +++ b/tests/testthat/test-power_consistent.R @@ -4,7 +4,7 @@ test_that("power functions are internally consistent", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-power_correlation.R b/tests/testthat/test-power_correlation.R index fad0fb0..a43dca7 100644 --- a/tests/testthat/test-power_correlation.R +++ b/tests/testthat/test-power_correlation.R @@ -1,5 +1,5 @@ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-powerraw.R b/tests/testthat/test-powerraw.R index 223dc81..d2e8d0c 100644 --- a/tests/testthat/test-powerraw.R +++ b/tests/testthat/test-powerraw.R @@ -6,7 +6,7 @@ test_that("powerTOSTtwo.prop is functions",{ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) diff --git a/tests/testthat/test-rank_diff.R b/tests/testthat/test-rank_diff.R new file mode 100644 index 0000000..5e49e83 --- /dev/null +++ b/tests/testthat/test-rank_diff.R @@ -0,0 +1,191 @@ +# Tests for rank_diff (Kornbrot 1990 rank difference transformation) + +# === Input validation === + +test_that("rank_diff errors when not numeric", { + expect_error(rank_diff("a", "b"), "must be numeric") + expect_error(rank_diff(1:5, letters[1:5]), "must be numeric") +}) + +test_that("rank_diff errors when lengths differ", { + expect_error(rank_diff(1:5, 1:3), "same length") +}) + +test_that("rank_diff errors when names has wrong length", { + expect_error(rank_diff(1:5, 6:10, names = "x"), "length 2") +}) + +test_that("rank_diff errors with no complete pairs", { + expect_error(rank_diff(c(NA_real_, NA_real_), c(NA_real_, NA_real_)), + "No complete pairs") +}) + +# === Basic functionality === + +test_that("rank_diff returns data frame with correct structure", { + rd <- rank_diff(1:5, 6:10) + expect_true(is.data.frame(rd)) + expect_equal(ncol(rd), 2) + expect_equal(nrow(rd), 5) + expect_equal(names(rd), c("x", "y")) +}) + +test_that("rank_diff respects custom names", { + rd <- rank_diff(1:5, 6:10, names = c("pre", "post")) + expect_equal(names(rd), c("pre", "post")) +}) + +test_that("rank_diff produces valid ranks", { + x <- c(3, 1, 5, 2, 4) + y <- c(8, 6, 10, 7, 9) + rd <- rank_diff(x, y) + + # All values should be in [1, 2*n] + all_ranks <- c(rd$x, rd$y) + expect_true(all(all_ranks >= 1)) + expect_true(all(all_ranks <= 10)) + + # Ranks should sum to n*(2n+1)/2 = 5*11/2 = 55 + expect_equal(sum(all_ranks), 55) +}) + +# === NA handling === + +test_that("rank_diff removes pairs with NAs and messages", { + x <- c(1, NA, 3, 4, 5) + y <- c(6, 7, NA, 9, 10) + + expect_message(rd <- rank_diff(x, y), "2 pairs with missing values removed") + expect_equal(nrow(rd), 3) + # Ranks should be based on 6 values: {1, 4, 5, 6, 9, 10} + expect_equal(sum(c(rd$x, rd$y)), 21) # 1+2+3+4+5+6 = 21 +}) + +# === Monotone invariance (key property from Kornbrot 1990) === + +test_that("rank_diff gives same result for monotone transformations", { + set.seed(42) + x <- abs(rnorm(15, 5, 2)) # All positive for log/exp + + y <- abs(rnorm(15, 6, 2)) + + rd_raw <- rank_diff(x, y) + rd_log <- rank_diff(log(x), log(y)) + rd_exp <- rank_diff(exp(x), exp(y)) + rd_sq <- rank_diff(x^2, y^2) + + # All monotone transformations should yield identical ranks + + expect_equal(rd_raw, rd_log) + expect_equal(rd_raw, rd_exp) + expect_equal(rd_raw, rd_sq) +}) + +# === Kornbrot (1990) Tables 1-2 consistency test === + +test_that("rank_diff: time and rate give same effect size (Kornbrot Tables 1-2)", { + time_plac <- c(4.6, 4.3, 6.7, 5.8, 5.0, 4.2, 6.0, + 2.0, 2.6, 10.0, 3.4, 7.1, 8.6) + time_drug <- c(2.9, 2.8, 12.0, 3.8, 5.9, 6.5, 3.3, + 2.3, 2.1, 14.3, 2.4, 14.0, 4.9) + rate_plac <- 60 / time_plac + rate_drug <- 60 / time_drug + + # Standard approach: time and rate give different absolute results + res_time_std <- ses_calc(time_plac, time_drug, paired = TRUE, ses = "rb") + res_rate_std <- ses_calc(rate_plac, rate_drug, paired = TRUE, ses = "rb") + expect_false(isTRUE(all.equal(abs(unname(res_time_std$estimate)), + abs(unname(res_rate_std$estimate))))) + + # Rank difference: time and rate give same absolute rb + + # (sign flips because 60/x is a decreasing monotone transform) + rd_time <- rank_diff(time_plac, time_drug) + rd_rate <- rank_diff(rate_plac, rate_drug) + + res_time_rd <- ses_calc(rd_time$x, rd_time$y, paired = TRUE, ses = "rb") + res_rate_rd <- ses_calc(rd_rate$x, rd_rate$y, paired = TRUE, ses = "rb") + expect_equal(abs(unname(res_time_rd$estimate)), + abs(unname(res_rate_rd$estimate))) +}) + +test_that("rank_diff: increasing monotone transform gives identical results", { + set.seed(42) + x <- abs(rnorm(15, 5, 2)) + y <- abs(rnorm(15, 6, 2)) + + # log is increasing on (0, Inf), so sign is preserved + rd_raw <- rank_diff(x, y) + rd_log <- rank_diff(log(x), log(y)) + + res_raw <- ses_calc(rd_raw$x, rd_raw$y, paired = TRUE, ses = "rb") + res_log <- ses_calc(rd_log$x, rd_log$y, paired = TRUE, ses = "rb") + expect_equal(unname(res_raw$estimate), unname(res_log$estimate)) +}) + +# === Works with ses_calc, boot_ses_calc === + +test_that("rank_diff output works with ses_calc", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, 0.5) + + rd <- rank_diff(x, y) + res <- ses_calc(rd$x, rd$y, paired = TRUE, ses = "rb") + expect_s3_class(res, "htest") + expect_true(is.finite(unname(res$estimate))) + expect_true(res$conf.int[1] < res$conf.int[2]) +}) + +test_that("rank_diff output works with ses_calc hypothesis testing", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, 0.5) + + rd <- rank_diff(x, y) + res <- ses_calc(rd$x, rd$y, paired = TRUE, ses = "cstat", + alternative = "two.sided", se_method = "score") + expect_true(!is.null(res$p.value)) + expect_true(res$p.value >= 0 && res$p.value <= 1) +}) + +test_that("rank_diff output works with all se_methods", { + x <- c(4.6, 4.3, 6.7, 5.8, 5.0, 4.2, 6.0, 2.0, 2.6, 10.0) + y <- c(2.9, 2.8, 12.0, 3.8, 5.9, 6.5, 3.3, 2.3, 2.1, 14.3) + + rd <- rank_diff(x, y) + for (method in c("score", "agresti", "fisher")) { + res <- ses_calc(rd$x, rd$y, paired = TRUE, ses = "rb", se_method = method) + expect_true(!is.na(unname(res$estimate)), + info = paste("se_method =", method)) + expect_true(!is.na(res$stderr), + info = paste("se_method =", method)) + } +}) + + +test_that("rank_diff output works with boot_ses_calc", { + skip_on_cran() + set.seed(789) + x <- rnorm(15) + y <- rnorm(15, 0.3) + + rd <- rank_diff(x, y) + res <- suppressMessages(boot_ses_calc(rd$x, rd$y, paired = TRUE, + ses = "rb", R = 99)) + expect_s3_class(res, "htest") + expect_true(is.finite(unname(res$estimate))) +}) + +# === Ties handling === + +test_that("rank_diff handles ties correctly (midranks)", { + x <- c(1, 2, 3) + y <- c(2, 3, 4) + + rd <- rank_diff(x, y) + # Pooled: 1, 2, 2, 3, 3, 4 + # Ranks: 1, 2.5, 2.5, 4.5, 4.5, 6 + expect_equal(rd$x, c(1, 2.5, 4.5)) + expect_equal(rd$y, c(2.5, 4.5, 6)) +}) diff --git a/tests/testthat/test-ses_calc.R b/tests/testthat/test-ses_calc.R index fbc8d16..a37d3d5 100644 --- a/tests/testthat/test-ses_calc.R +++ b/tests/testthat/test-ses_calc.R @@ -1,7 +1,7 @@ # Tests for ses_calc, boot_ses_calc, and helper functions hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -35,10 +35,12 @@ test_that("rbs_calc: one-sample with mu shift", { set.seed(8494) x <- rnorm(30, mean = 2) - # Large positive mean should give positive rb when compared to 0 - + # rbs_calc paired convention: z = (x - y) - mu + # When x=zeros, y=positive_data: z is negative, giving negative rho + # ses_calc swaps args (passes y,x) so end-user sees positive rb for positive mean + # Here we test the raw internal convention r <- TOSTER:::rbs_calc(x = rep(0, length(x)), y = x, mu = 0, paired = TRUE) - expect_true(r > 0) + expect_true(r < 0) }) test_that("Transformation round-trips", { @@ -153,9 +155,9 @@ test_that("ses_compute_agresti: boundary correction applied", { y <- c(1, 2, 3) res <- TOSTER:::ses_compute_agresti(x, y, paired = FALSE) expect_true(res$boundary_corrected) - # cstat should be near 1 but corrected + # cstat should be near 1 but corrected: 1 - 0.5/(n1*n2) = 1 - 0.5/9 ≈ 0.944 expect_true(res$cstat < 1) - expect_true(res$cstat > 0.99) + expect_true(res$cstat > 0.9) }) test_that("ses_ci_logodds returns valid CIs", { @@ -438,6 +440,7 @@ test_that("ses_calc: fisher method hypothesis test", { # === boot_ses_calc tests === test_that("boot_ses_calc: default output is htest with no hypothesis test", { + skip_on_cran() set.seed(200) x <- rnorm(15) y <- rnorm(15, mean = 0.5) @@ -458,6 +461,7 @@ test_that("boot_ses_calc: default output is htest with no hypothesis test", { }) test_that("boot_ses_calc: hypothesis test when alternative specified", { + skip_on_cran() set.seed(201) x <- rnorm(15) y <- rnorm(15, mean = 0.8) @@ -476,6 +480,7 @@ test_that("boot_ses_calc: hypothesis test when alternative specified", { }) test_that("boot_ses_calc: point estimates match ses_calc", { + skip_on_cran() set.seed(202) x <- rnorm(20) y <- rnorm(20, mean = 0.5) @@ -489,6 +494,7 @@ test_that("boot_ses_calc: point estimates match ses_calc", { }) test_that("boot_ses_calc: all bootstrap CI methods work", { + skip_on_cran() set.seed(203) x <- rnorm(15) y <- rnorm(15, mean = 0.5) @@ -502,6 +508,7 @@ test_that("boot_ses_calc: all bootstrap CI methods work", { }) test_that("boot_ses_calc: data.frame output", { + skip_on_cran() set.seed(204) x <- rnorm(15) y <- rnorm(15, mean = 0.5) @@ -513,9 +520,10 @@ test_that("boot_ses_calc: data.frame output", { }) test_that("boot_ses_calc: paired samples", { + skip_on_cran() set.seed(205) x <- rnorm(15) - y <- x + rnorm(15, mean = 0.5, sd = 0.3) + y <- x + rnorm(15, mean = 0.3, sd = 1) res <- hush(boot_ses_calc(x = x, y = y, paired = TRUE, R = 99)) expect_s3_class(res, "htest") @@ -523,6 +531,7 @@ test_that("boot_ses_calc: paired samples", { }) test_that("boot_ses_calc: one-sample", { + skip_on_cran() set.seed(206) x <- rnorm(15, mean = 1) @@ -532,6 +541,7 @@ test_that("boot_ses_calc: one-sample", { }) test_that("boot_ses_calc: equivalence testing", { + skip_on_cran() set.seed(207) x <- rnorm(20) y <- rnorm(20, mean = 0.1) @@ -547,6 +557,7 @@ test_that("boot_ses_calc: equivalence testing", { }) test_that("boot_ses_calc: minimal effect testing", { + skip_on_cran() set.seed(208) x <- rnorm(20, mean = 2) y <- rnorm(20) @@ -561,6 +572,7 @@ test_that("boot_ses_calc: minimal effect testing", { }) test_that("boot_ses_calc: equivalence requires two bounds", { + skip_on_cran() set.seed(209) x <- rnorm(15) y <- rnorm(15) @@ -573,6 +585,7 @@ test_that("boot_ses_calc: equivalence requires two bounds", { }) test_that("boot_ses_calc: complete separation stops with error", { + skip_on_cran() x <- c(10, 11, 12) y <- c(1, 2, 3) expect_error( @@ -582,6 +595,7 @@ test_that("boot_ses_calc: complete separation stops with error", { }) test_that("boot_ses_calc: formula interface", { + skip_on_cran() set.seed(210) df <- data.frame( val = c(rnorm(15), rnorm(15, mean = 0.5)), @@ -593,6 +607,7 @@ test_that("boot_ses_calc: formula interface", { }) test_that("boot_ses_calc: formula with paired warns", { + skip_on_cran() set.seed(211) df <- data.frame( val = c(rnorm(15), rnorm(15, mean = 0.5)), @@ -605,6 +620,7 @@ test_that("boot_ses_calc: formula with paired warns", { }) test_that("boot_ses_calc: one-sided alternatives", { + skip_on_cran() set.seed(212) x <- rnorm(20, mean = 2) y <- rnorm(20) @@ -618,6 +634,7 @@ test_that("boot_ses_calc: one-sided alternatives", { }) test_that("boot_ses_calc: agresti vs fisher se_method", { + skip_on_cran() set.seed(213) x <- rnorm(20) y <- rnorm(20, mean = 0.5) @@ -630,6 +647,7 @@ test_that("boot_ses_calc: agresti vs fisher se_method", { }) test_that("boot_ses_calc: boot component included in htest output", { + skip_on_cran() set.seed(214) x <- rnorm(15) y <- rnorm(15, mean = 0.5) @@ -638,3 +656,691 @@ test_that("boot_ses_calc: boot component included in htest output", { expect_true(!is.null(res$boot)) expect_equal(length(res$boot), 99) }) + + +# === Score method tests === + +test_that("score method matches wilcox.test p-values", { + set.seed(300) + x <- rnorm(20) + y <- rnorm(25, mean = 0.5) + + # With continuity correction + toster_p <- ses_calc(x, y, ses = "cstat", se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5)$p.value + wt_p <- wilcox.test(x, y, exact = FALSE, correct = TRUE)$p.value + expect_equal(toster_p, wt_p, tolerance = 1e-6) + + # Without continuity correction + toster_p_nocorr <- ses_calc(x, y, ses = "cstat", se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5)$p.value + wt_p_nocorr <- wilcox.test(x, y, exact = FALSE, correct = FALSE)$p.value + expect_equal(toster_p_nocorr, wt_p_nocorr, tolerance = 1e-6) +}) + +test_that("score method matches wilcox.test with ties", { + # Ordinal data with ties + x_ord <- c(1, 1, 2, 2, 3, 3, 3, 4) + y_ord <- c(2, 3, 3, 3, 4, 4, 5, 5, 5) + + toster_p <- ses_calc(x_ord, y_ord, ses = "cstat", se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5)$p.value + wt_p <- wilcox.test(x_ord, y_ord, exact = FALSE, correct = TRUE)$p.value + expect_equal(toster_p, wt_p, tolerance = 1e-6) +}) + +test_that("score method CI transforms correctly across scales", { + set.seed(301) + x <- rnorm(20) + y <- rnorm(20, mean = 0.5) + + res_cstat <- ses_calc(x, y, ses = "cstat", se_method = "score", correct = FALSE) + res_rb <- ses_calc(x, y, ses = "rb", se_method = "score", correct = FALSE) + + # rb CI = 2 * cstat CI - 1 + expect_equal(as.numeric(res_rb$conf.int), + 2 * as.numeric(res_cstat$conf.int) - 1, + tolerance = 1e-10) + + # Estimate relationship + expect_equal(unname(res_rb$estimate), + 2 * unname(res_cstat$estimate) - 1, + tolerance = 1e-10) +}) + +test_that("score method works for paired data", { + set.seed(302) + x <- rnorm(15) + y <- rnorm(15) + + res <- ses_calc(x, y, paired = TRUE, ses = "cstat", se_method = "score") + expect_s3_class(res, "htest") + expect_true(res$estimate > 0 && res$estimate < 1) + expect_true(res$conf.int[1] < res$conf.int[2]) +}) + +test_that("score method works for one-sample data", { + set.seed(303) + x <- rnorm(15, mean = 1) + + res <- ses_calc(x, ses = "cstat", se_method = "score") + expect_s3_class(res, "htest") + expect_true(res$estimate > 0 && res$estimate < 1) + expect_true(res$conf.int[1] < res$conf.int[2]) +}) + +test_that("score method handles boundaries naturally", { + # Complete separation: all x < y + x_sep <- 1:5 + y_sep <- 6:10 + + res <- ses_calc(x_sep, y_sep, ses = "cstat", se_method = "score", correct = FALSE) + + # Estimate should be 0 (all x < y means Pr(X > Y) = 0) + expect_equal(unname(res$estimate), 0, tolerance = 1e-10) + # CI lower should be 0 + expect_equal(res$conf.int[1], 0, tolerance = 1e-10) + # CI upper should be > 0 (found via test inversion) + expect_true(res$conf.int[2] > 0) +}) + +test_that("score method one-sided alternatives", { + set.seed(304) + x <- rnorm(25, mean = 2) # Clearly larger + y <- rnorm(25) + + res_greater <- ses_calc(x, y, ses = "cstat", se_method = "score", + alternative = "greater", null.value = 0.5) + res_less <- ses_calc(x, y, ses = "cstat", se_method = "score", + alternative = "less", null.value = 0.5) + + # With x >> y, cstat should be high (near 1) + expect_true(unname(res_greater$estimate) > 0.7) + # p-value for greater should be small, for less should be large + expect_true(res_greater$p.value < 0.05) + expect_true(res_less$p.value > 0.5) +}) + +test_that("score method equivalence testing", { + set.seed(305) + x <- rnorm(40) + y <- rnorm(40, mean = 0.1) + + res_eq <- ses_calc(x, y, ses = "cstat", se_method = "score", + alternative = "equivalence", + null.value = c(0.3, 0.7)) + expect_true(!is.null(res_eq$p.value)) + expect_equal(length(res_eq$null.value), 2) + + res_met <- ses_calc(x, y, ses = "cstat", se_method = "score", + alternative = "minimal.effect", + null.value = c(0.3, 0.7)) + expect_true(!is.null(res_met$p.value)) +}) + +test_that("score method all effect size types", { + set.seed(306) + x <- rnorm(25) + y <- rnorm(25, mean = 0.5) + + for (ses_type in c("rb", "cstat", "odds", "logodds")) { + res <- ses_calc(x, y, ses = ses_type, se_method = "score") + expect_s3_class(res, "htest") + expect_true(is.numeric(res$estimate)) + expect_true(!is.na(res$stderr)) + } +}) + +test_that("correct parameter ignored for non-score methods", { + set.seed(307) + x <- rnorm(20) + y <- rnorm(20) + + # Should produce message about ignoring correct parameter + expect_message( + ses_calc(x, y, se_method = "agresti", correct = TRUE), + "only used with se_method = 'score'" + ) +}) + + +# === Haldane boundary correction tests === + +test_that("Haldane boundary correction applies correct shrinkage", { + # Two-sample complete separation + x_sep <- 1:5 + y_sep <- 6:10 + N_pairs <- 25 + expected_p <- (N_pairs + 0.5) / (N_pairs + 1) # = 25.5/26 ≈ 0.9808 + + expect_message( + res <- ses_calc(x_sep, y_sep, ses = "cstat", se_method = "agresti"), + "Complete separation detected" + ) + + # Point estimate should be corrected (not raw 1.0) + # Note: x < y means cstat = Pr(X > Y) = 0, so correction gives (0 + 0.5)/26 + expected_corrected <- 0.5 / (N_pairs + 1) # ≈ 0.0192 + expect_equal(unname(res$estimate), expected_corrected, tolerance = 1e-4) + + # CI should not be trivially narrow + expect_true(res$conf.int[2] - res$conf.int[1] > 0.05) + + # SE should be positive + expect_true(res$stderr > 0) +}) + +test_that("Haldane boundary correction for paired data", { + # Paired complete separation + x_paired <- c(1, 2, 3, 4, 5) + y_paired <- c(6, 7, 8, 9, 10) + + expect_message( + res <- ses_calc(x_paired, y_paired, paired = TRUE, ses = "cstat", se_method = "agresti"), + "Complete separation detected" + ) + + # Should get corrected estimate (not exactly 0 or 1) + expect_true(res$estimate > 0) + expect_true(res$estimate < 1) + # SE should be positive + expect_true(res$stderr > 0) +}) + +test_that("Haldane correction negligible for non-boundary cases", { + set.seed(308) + x <- rnorm(50) + y <- rnorm(50, mean = 0.5) + + res <- ses_calc(x, y, ses = "cstat", se_method = "agresti") + + # Compute raw estimate for comparison + r_raw <- TOSTER:::rbs_calc(x, y, mu = 0, paired = FALSE) + p_raw <- (r_raw + 1) / 2 + + # Estimate should match raw (no boundary correction applied) + expect_equal(as.numeric(res$estimate), p_raw, tolerance = 1e-10) +}) + +test_that("Haldane correction message mentions score method for two-sample", { + x_sep <- 1:5 + y_sep <- 6:10 + + expect_message( + ses_calc(x_sep, y_sep, ses = "cstat", se_method = "agresti"), + "[Ss]core" # Case-insensitive match for "Score" or "score" + ) +}) + +test_that("to_cstat transformations work correctly", { + # cstat pass-through + expect_equal(TOSTER:::to_cstat(0.7, "cstat"), 0.7) + + # rb -> cstat + expect_equal(TOSTER:::to_cstat(0, "rb"), 0.5) + expect_equal(TOSTER:::to_cstat(1, "rb"), 1) + expect_equal(TOSTER:::to_cstat(-1, "rb"), 0) + expect_equal(TOSTER:::to_cstat(0.4, "rb"), 0.7) + + # odds -> cstat + expect_equal(TOSTER:::to_cstat(1, "odds"), 0.5) + expect_equal(TOSTER:::to_cstat(2, "odds"), 2/3) + + # logodds -> cstat + expect_equal(TOSTER:::to_cstat(0, "logodds"), 0.5) + expect_equal(TOSTER:::to_cstat(log(2), "logodds"), 2/3) +}) + +test_that("wmw_tie_factor returns correct values", { + # No ties + x <- c(1, 3, 5) + y <- c(2, 4, 6) + expect_equal(TOSTER:::wmw_tie_factor(x, y), 1) + + # All identical + x_eq <- rep(5, 5) + y_eq <- rep(5, 5) + expect_equal(TOSTER:::wmw_tie_factor(x_eq, y_eq), 0) +}) + +test_that("v_laph returns valid variance values", { + # At phi = 0.5 (null), variance should be positive + v_null <- TOSTER:::v_laph(0.5, tf = 1, n1 = 20, n2 = 20) + expect_true(v_null > 0) + + # At boundaries, variance should be 0 + v_0 <- TOSTER:::v_laph(0, tf = 1, n1 = 20, n2 = 20) + expect_equal(v_0, 0) + + v_1 <- TOSTER:::v_laph(1, tf = 1, n1 = 20, n2 = 20) + expect_equal(v_1, 0) + + # With ties (tf < 1), variance should be smaller + v_ties <- TOSTER:::v_laph(0.5, tf = 0.8, n1 = 20, n2 = 20) + expect_true(v_ties < v_null) +}) + +test_that("score_ci_wmw returns valid intervals", { + ci <- TOSTER:::score_ci_wmw(phi_hat = 0.6, tf = 1, n1 = 20, n2 = 20, + conf.level = 0.95, correct = FALSE) + expect_equal(length(ci), 2) + expect_true(ci[1] < ci[2]) + expect_true(ci[1] >= 0) + expect_true(ci[2] <= 1) + expect_true(ci[1] < 0.6) + expect_true(ci[2] > 0.6) +}) + +test_that("score_pvalue_wmw returns valid p-values", { + res <- TOSTER:::score_pvalue_wmw(phi_hat = 0.6, phi_null = 0.5, + tf = 1, n1 = 20, n2 = 20, + alternative = "two.sided", correct = FALSE) + expect_true(res$p.value >= 0) + expect_true(res$p.value <= 1) + expect_true(is.numeric(res$z.statistic)) +}) + +# ses_calc updated labels -------- + +test_that("ses_calc two-sample labels use P(X>Y) notation", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, mean = 1) + + res_rb <- ses_calc(x, y, ses = "rb") + expect_true(grepl("P(X>Y) - P(XY) + .5*P(X=Y)", names(res_cstat$estimate), fixed = TRUE)) + + res_odds <- ses_calc(x, y, ses = "odds") + expect_true(grepl("odds(", names(res_odds$estimate), fixed = TRUE)) + expect_true(grepl("X>Y", names(res_odds$estimate), fixed = TRUE)) + + res_lo <- ses_calc(x, y, ses = "logodds") + expect_true(grepl("logodds(", names(res_lo$estimate), fixed = TRUE)) + expect_true(grepl("X>Y", names(res_lo$estimate), fixed = TRUE)) +}) + +test_that("ses_calc paired labels use P(X - Y>0) notation", { + data(sleep) + res <- with(sleep, ses_calc(extra[group == 1], extra[group == 2], + paired = TRUE, ses = "cstat")) + # Paired ses_calc: difference-score notation P(X - Y>0) + .5*P(X - Y=0) + lbl <- names(res$estimate) + expect_true(grepl("X - Y", lbl, fixed = TRUE)) + expect_true(grepl(">0)", lbl, fixed = TRUE)) +}) + +test_that("ses_calc one-sample labels use P(X>0) notation", { + x <- rnorm(20, mean = 1) + res <- ses_calc(x, ses = "cstat") + # One-sample: P(X>0) + .5*P(X=0) — X is not numeric so unquoted + expect_true(grepl("P(X>0)", names(res$estimate), fixed = TRUE)) + expect_true(grepl(">0)", names(res$estimate), fixed = TRUE)) +}) + +test_that("ses_calc method string retains human-readable name", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, mean = 1) + res <- ses_calc(x, y, ses = "rb") + expect_true(grepl("Rank-Biserial Correlation", res$method)) +}) + +test_that("ses_calc data.frame output uses human-readable row names", { + set.seed(123) + x <- rnorm(20) + y <- rnorm(20, mean = 1) + res <- ses_calc(x, y, ses = "rb", output = "data.frame") + expect_equal(rownames(res), "Rank-Biserial Correlation") +}) + +test_that("ses_calc numeric values unchanged by label update", { + set.seed(42) + x <- rnorm(30) + y <- rnorm(30, mean = 0.5) + + res <- ses_calc(x, y, ses = "rb") + expect_true(is.numeric(res$estimate)) + expect_true(is.finite(res$estimate)) +}) + +test_that("ses_calc formula method labels use actual group names", { + res <- ses_calc(mpg ~ am, data = mtcars, ses = "rb") + # Formula method should use quoted factor level names + expect_true(grepl("'0'", names(res$estimate), fixed = TRUE)) + expect_true(grepl("'1'", names(res$estimate), fixed = TRUE)) +}) + +# === Zero differences handling tests === + +test_that("rbs_calc: paired excludes zero differences", { + # With zeros included, rbs_calc should give the same result as without zeros + z_full <- c(1, 2, 3, 4, 5, 0, 0, 0, 0, 0) + z_nz <- c(1, 2, 3, 4, 5) + + rb_full <- TOSTER:::rbs_calc(rep(0, length(z_full)), z_full, mu = 0, paired = TRUE) + rb_nz <- TOSTER:::rbs_calc(rep(0, length(z_nz)), z_nz, mu = 0, paired = TRUE) + expect_equal(rb_full, rb_nz) +}) + +test_that("rbs_calc: paired all zeros returns zero", { + z_all_zero <- c(0, 0, 0, 0, 0) + rb <- TOSTER:::rbs_calc(rep(0, 5), z_all_zero, mu = 0, paired = TRUE) + expect_equal(rb, 0) +}) + +test_that("ses_calc one-sample with zeros produces non-degenerate CI", { + z <- c(-5, -4, -3, -2, -1, 0, 0, 0, 1, 2) + result <- ses_calc(z) + ci <- result$conf.int + expect_true(ci[2] - ci[1] < 2, + info = "CI should not span the full [-1, 1] range; likely variance bug with zeros") +}) + +test_that("ses_calc one-sample p-value is consistent with wilcox.test when zeros present", { + z <- c(-5, -4, -3, -2, -1, 0, 0, 0, 1, 2) + wt <- suppressWarnings(wilcox.test(z)) + sc <- ses_calc(z, alternative = "two.sided") + expect_true( + (wt$p.value < 0.10 && sc$p.value < 0.10) || (wt$p.value >= 0.10 && sc$p.value >= 0.10), + info = paste0("Directional disagreement: wilcox.test p=", round(wt$p.value, 4), + " vs ses_calc p=", round(sc$p.value, 4)) + ) +}) + +test_that("ses_calc paired with zero differences produces non-degenerate CI", { + x <- c(10, 20, 30, 40, 50, 60, 60, 60, 70, 80) + y <- c(15, 24, 33, 42, 51, 60, 60, 60, 69, 78) + result <- ses_calc(x = x, y = y, paired = TRUE) + ci <- result$conf.int + expect_true(ci[2] - ci[1] < 2, + info = "Paired CI should not span the full range when zero differences exist") +}) + +test_that("ses_calc one-sample without zeros is unaffected by fix", { + z <- c(-5, -3, -1, 2, 4, 6, 8, 10) + result <- ses_calc(z, alternative = "two.sided") + expect_true(result$conf.int[1] > -1) + expect_true(result$conf.int[2] < 1) + expect_true(is.finite(result$p.value)) +}) + +test_that("adding zeros to one-sample data does not inflate SE", { + z_no_zeros <- c(-5, -4, -3, -2, -1) + z_with_zeros <- c(-5, -4, -3, -2, -1, 0, 0, 0) + se_no_zeros <- suppressMessages(ses_calc(z_no_zeros)$stderr) + se_with_zeros <- suppressMessages(ses_calc(z_with_zeros)$stderr) + expect_true(se_with_zeros < se_no_zeros * 5, + info = "SE with zeros should not be dramatically larger than without") +}) + +# === Paired score method tests === + +test_that("paired score p-value matches wilcox.test (sleep data, no cc)", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + wt <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE) + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res$p.value, wt$p.value, tolerance = 1e-6) +}) + +test_that("paired score p-value matches wilcox.test (sleep data, with cc)", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + wt_cc <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = TRUE) + res_cc <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res_cc$p.value, wt_cc$p.value, tolerance = 1e-6) +}) + +test_that("paired score one-sided p-value matches wilcox.test", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + # Score paired cstat computes P(X - Y > 0), which matches wilcox.test direction. + # "greater" in wilcox.test tests x - y > 0 => maps to "greater" in ses_calc. + wt_g <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE, + alternative = "greater") + res_g <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "greater", null.value = 0.5) + expect_equal(res_g$p.value, wt_g$p.value, tolerance = 1e-6) + + wt_l <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE, + alternative = "less") + res_l <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "less", null.value = 0.5) + expect_equal(res_l$p.value, wt_l$p.value, tolerance = 1e-6) +}) + +test_that("paired score p-value matches wilcox.test (data with ties)", { + x <- c(1, 2, 2, 3, 4, 5, 5, 6) + y <- c(2, 2, 3, 3, 3, 4, 5, 5) + + wt <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE) + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res$p.value, wt$p.value, tolerance = 1e-6) + + wt_cc <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = TRUE) + res_cc <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res_cc$p.value, wt_cc$p.value, tolerance = 1e-6) +}) + +test_that("paired score p-value matches wilcox.test (one-sample)", { + x <- c(1.5, 2.3, 3.1, 0.8, 4.2, 2.7, 3.9, 1.1, 5.0, 2.5) + + wt <- wilcox.test(x, mu = 0, exact = FALSE, correct = FALSE) + res <- ses_calc(x = x, ses = "cstat", mu = 0, + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res$p.value, wt$p.value, tolerance = 1e-6) + + wt_cc <- wilcox.test(x, mu = 0, exact = FALSE, correct = TRUE) + res_cc <- ses_calc(x = x, ses = "cstat", mu = 0, + se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res_cc$p.value, wt_cc$p.value, tolerance = 1e-6) +}) + +test_that("paired score p-value matches wilcox.test (heavy ties)", { + set.seed(123) + x <- sample(1:5, 20, replace = TRUE) + y <- sample(1:5, 20, replace = TRUE) + + wt <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE) + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res$p.value, wt$p.value, tolerance = 1e-6) + + wt_cc <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = TRUE) + res_cc <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = TRUE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res_cc$p.value, wt_cc$p.value, tolerance = 1e-6) +}) + +test_that("paired score CI/p-value coherence", { + set.seed(123) + x <- sample(1:5, 20, replace = TRUE) + y <- sample(1:5, 20, replace = TRUE) + + # Get 90% CI (alpha = 0.05 with equivalence -> conf.level = 1 - 2*0.05 = 0.90) + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", alpha = 0.05, + alternative = "equivalence", + null.value = c(0.3, 0.7)) + + ci <- res$conf.int + + # Test at lower bound: p for "greater" should be ~0.05 + res_lo <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", + alternative = "greater", null.value = ci[1]) + expect_equal(res_lo$p.value, 0.05, tolerance = 1e-4) + + # Test at upper bound: p for "less" should be ~0.05 + res_hi <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", + alternative = "less", null.value = ci[2]) + expect_equal(res_hi$p.value, 0.05, tolerance = 1e-4) +}) + +test_that("paired score handles complete separation", { + # All x > y: P(X - Y > 0) = 1 + x <- c(10, 11, 12, 13, 14) + y <- c(1, 2, 3, 4, 5) + + # Should not error, CI should be sensible + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score") + expect_equal(as.numeric(res$estimate), 1.0) + expect_true(res$conf.int[1] > 0.5) + expect_equal(res$conf.int[2], 1.0) + + # All y > x: P(X - Y > 0) = 0 (since x < y here) + res2 <- ses_calc(x = y, y = x, paired = TRUE, ses = "cstat", + se_method = "score") + expect_equal(as.numeric(res2$estimate), 0.0) + expect_equal(res2$conf.int[1], 0.0) + expect_true(res2$conf.int[2] < 0.5) + + # rb scale for complete separation (all x > y) + res_rb <- ses_calc(x = x, y = y, paired = TRUE, ses = "rb", + se_method = "score") + expect_true(res_rb$conf.int[1] > 0) + expect_equal(res_rb$conf.int[2], 1.0) +}) + +test_that("paired score effect size scale transformations are consistent", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + res_c <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score") + res_r <- ses_calc(x = x, y = y, paired = TRUE, ses = "rb", + se_method = "score") + res_o <- ses_calc(x = x, y = y, paired = TRUE, ses = "odds", + se_method = "score") + res_l <- ses_calc(x = x, y = y, paired = TRUE, ses = "logodds", + se_method = "score") + + # rb = 2*cstat - 1 + expect_equal(as.numeric(res_r$conf.int), + 2 * as.numeric(res_c$conf.int) - 1, tolerance = 1e-8) + + # odds = cstat / (1 - cstat) + expect_equal(as.numeric(res_o$conf.int), + as.numeric(res_c$conf.int) / (1 - as.numeric(res_c$conf.int)), + tolerance = 1e-8) + + # logodds = log(cstat / (1 - cstat)) + expect_equal(as.numeric(res_l$conf.int), + log(as.numeric(res_c$conf.int) / (1 - as.numeric(res_c$conf.int))), + tolerance = 1e-8) +}) + +test_that("paired score equivalence test on rb scale", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + # Equivalence on rb scale: bounds [-0.3, 0.3] + res_equiv_rb <- ses_calc(x = x, y = y, paired = TRUE, ses = "rb", + se_method = "score", + alternative = "equivalence", + null.value = c(-0.3, 0.3)) + expect_s3_class(res_equiv_rb, "htest") + expect_length(res_equiv_rb$null.value, 2) +}) + +test_that("paired score point estimates match agresti method (non-boundary)", { + # Both score and agresti now compute P(X - Y > 0) with the same direction. + set.seed(42) + x <- rnorm(20, mean = 0.5) + y <- rnorm(20, mean = 0) + + res_score <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score") + res_agresti <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "agresti") + + # Point estimates should be identical (when no boundary correction) + expect_equal(as.numeric(res_score$estimate), as.numeric(res_agresti$estimate)) + + # CIs should overlap substantially + expect_true(res_score$conf.int[1] < res_agresti$conf.int[2]) + expect_true(res_score$conf.int[2] > res_agresti$conf.int[1]) +}) + +test_that("paired score note string distinguishes paired from two-sample", { + data(sleep) + x <- sleep$extra[sleep$group == 2] + y <- sleep$extra[sleep$group == 1] + + res_paired <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score") + expect_true(grepl("Wilson", res_paired$note)) + + res_two <- ses_calc(x = x, y = y, paired = FALSE, ses = "cstat", + se_method = "score") + expect_true(grepl("Fay-Malinovsky", res_two$note)) +}) + +test_that("paired score handles zero differences (dropped)", { + # Include pairs where x == y (should be dropped) + x <- c(1, 2, 3, 4, 5, 6, 7) + y <- c(2, 2, 4, 4, 3, 7, 5) + # Differences: -1, 0, -1, 0, 2, -1, 2 + # Non-zero: -1, -1, 2, -1, 2 (N=5) + + res <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score") + expect_s3_class(res, "htest") + expect_true(is.finite(res$estimate)) + expect_true(res$conf.int[1] < res$conf.int[2]) + + # Verify p-value matches wilcox.test with same data + wt <- wilcox.test(x, y, paired = TRUE, exact = FALSE, correct = FALSE) + res_test <- ses_calc(x = x, y = y, paired = TRUE, ses = "cstat", + se_method = "score", correct = FALSE, + alternative = "two.sided", null.value = 0.5) + expect_equal(res_test$p.value, wt$p.value, tolerance = 1e-6) +}) + +# boot_ses_calc CI/p-value agreement tests ----- + +for (ci_method in c("perc", "basic", "bca", "stud")) { + test_that(paste0("boot_ses_calc: CI/p-value agreement for ", ci_method), { + skip_on_cran() + + set.seed(42) + x <- c(1.2, 2.3, 3.1, 4.6, 5.2, 6.7, 7.0, 8.1, 2.5, 3.3) + y <- c(3.5, 4.8, 5.6, 6.9, 7.2, 8.5, 9.0, 10.1, 4.5, 5.3) + + res <- boot_ses_calc(x = x, y = y, ses = "rb", + alternative = "two.sided", + null.value = 0, + boot_ci = ci_method, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = paste(ci_method, "CI/p agreement two.sided")) + }) +} diff --git a/tests/testthat/test-smd-se.R b/tests/testthat/test-smd-se.R index 3b33e65..fe5315c 100644 --- a/tests/testthat/test-smd-se.R +++ b/tests/testthat/test-smd-se.R @@ -3,7 +3,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -18,13 +18,15 @@ test_that("glass", { group == 1)$extra, y = subset(sleep, group == 2)$extra, - glass = "glass2") + glass = "glass2", + output = "data.frame") smc = TOSTER::smd_calc(x = subset(sleep, group == 1)$extra, y = subset(sleep, group == 2)$extra, glass = "glass1", - paired = TRUE) + paired = TRUE, + output = "data.frame") # x1 = subset(sleep, # group == 1)$extra # y1 = subset(sleep, @@ -77,13 +79,15 @@ test_that("Hedges g(s/av) and g(z)", group == 1)$extra, y = subset(sleep, group == 2)$extra, - var.equal = TRUE) + var.equal = TRUE, + output = "data.frame") smc = TOSTER::smd_calc(x = subset(sleep, group == 1)$extra, y = subset(sleep, group == 2)$extra, - paired = TRUE) + paired = TRUE, + output = "data.frame") # x1 = subset(sleep, # group == 1)$extra # y1 = subset(sleep, @@ -137,7 +141,8 @@ test_that("Hedges g(s/av) and g(z)", group == 1)$extra, y = subset(sleep, group == 2)$extra, - var.equal = FALSE) + var.equal = FALSE, + output = "data.frame") expect_equal(0.24,round(smd$SE^2,2)) }) diff --git a/tests/testthat/test-smd_calc_htest.R b/tests/testthat/test-smd_calc_htest.R new file mode 100644 index 0000000..42fd3b2 --- /dev/null +++ b/tests/testthat/test-smd_calc_htest.R @@ -0,0 +1,389 @@ +# Tests for smd_calc and boot_smd_calc htest output and hypothesis testing + +hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) +} + +# --- smd_calc htest output --- + +test_that("smd_calc returns htest by default", { + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 6, sd = 2) + + result <- smd_calc(x = x, y = y) + expect_s3_class(result, "htest") + expect_true(!is.null(result$estimate)) + expect_true(!is.null(result$stderr)) + expect_true(!is.null(result$conf.int)) + expect_true(!is.null(result$method)) + expect_true(!is.null(result$data.name)) + expect_true(!is.null(attr(result$conf.int, "conf.level"))) + expect_equal(attr(result$conf.int, "conf.level"), 0.95) + + # No hypothesis test by default + expect_null(result$statistic) + expect_null(result$p.value) + expect_null(result$null.value) +}) + +test_that("smd_calc htest matches data.frame output", { + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 6, sd = 2) + + ht <- smd_calc(x = x, y = y) + df <- smd_calc(x = x, y = y, output = "data.frame") + + expect_equal(unname(ht$estimate), df$estimate) + expect_equal(ht$stderr, df$SE) + expect_equal(ht$conf.int[1], df$lower.ci) + expect_equal(ht$conf.int[2], df$upper.ci) +}) + +test_that("smd_calc htest method string is correct", { + set.seed(42) + x <- rnorm(20, mean = 5, sd = 2) + y <- rnorm(20, mean = 6, sd = 2) + + # Two Sample SMD (default: bias_correction=TRUE, var.equal=FALSE) + r1 <- smd_calc(x = x, y = y) + expect_true(grepl("Two Sample", r1$method)) + expect_true(grepl("SMD; Hedges's g[av]=", r1$method, fixed = TRUE)) + + + # Paired Sample + r2 <- smd_calc(x = x, y = y, paired = TRUE) + expect_true(grepl("Paired Sample", r2$method)) + + # One Sample + r3 <- smd_calc(x = x) + expect_true(grepl("One Sample", r3$method)) + + # SMD (d[...]=...) when bias_correction = FALSE + r4 <- smd_calc(x = x, y = y, bias_correction = FALSE) + expect_true(grepl("SMD; Cohen's d[av]=", r4$method, fixed = TRUE)) + + # Glass with default bias correction => SMD (g[x]=...) + r5 <- smd_calc(x = x, y = y, glass = "glass1") + expect_true(grepl("bias-corrected Glass's g[x]=", r5$method, fixed = TRUE)) + +}) + +test_that("smd_calc formula interface returns htest with correct data.name", { + set.seed(42) + df <- data.frame( + value = c(rnorm(20, 5, 2), rnorm(20, 6, 2)), + group = factor(rep(c("A", "B"), each = 20)) + ) + + result <- smd_calc(formula = value ~ group, data = df) + expect_s3_class(result, "htest") + expect_equal(result$data.name, "value by group") +}) + +# --- smd_calc hypothesis testing --- + +test_that("smd_calc two.sided test works (z method)", { + set.seed(42) + x <- rnorm(50, mean = 5, sd = 2) + y <- rnorm(50, mean = 6, sd = 2) + + result <- smd_calc(x = x, y = y, alternative = "two.sided", + null.value = 0, smd_ci = "z") + expect_s3_class(result, "htest") + expect_true(!is.null(result$statistic)) + expect_true(!is.null(result$p.value)) + expect_true(!is.null(result$null.value)) + expect_equal(names(result$statistic), "z") + expect_null(result$parameter) # no df for z method + + # p-value should be symmetric + # If we flip the sign of the effect, p should be the same + expect_true(result$p.value >= 0 && result$p.value <= 1) +}) + +test_that("smd_calc two.sided test works (t method)", { + set.seed(42) + x <- rnorm(50, mean = 5, sd = 2) + y <- rnorm(50, mean = 6, sd = 2) + + result <- smd_calc(x = x, y = y, alternative = "two.sided", + null.value = 0, test_method = "t", smd_ci = "t") + expect_s3_class(result, "htest") + expect_equal(names(result$statistic), "t") + expect_true(!is.null(result$parameter)) + expect_equal(names(result$parameter), "df") + expect_true(result$p.value >= 0 && result$p.value <= 1) +}) + +test_that("smd_calc one-sided tests produce correct tail probabilities", { + set.seed(42) + x <- rnorm(50, mean = 5, sd = 2) + y <- rnorm(50, mean = 8, sd = 2) # large effect + + r_less <- smd_calc(x = x, y = y, alternative = "less", + null.value = 0, smd_ci = "z") + r_greater <- smd_calc(x = x, y = y, alternative = "greater", + null.value = 0, smd_ci = "z") + r_two <- smd_calc(x = x, y = y, alternative = "two.sided", + null.value = 0, smd_ci = "z") + + # Effect is negative (x - y < 0), so "less" p should be small + # and "greater" p should be large + # (sign depends on convention: x - y) + expect_true(r_less$p.value + r_greater$p.value == 1 || + abs(r_less$p.value + r_greater$p.value - 1) < 1e-10) +}) + +test_that("smd_calc equivalence test works", { + set.seed(42) + x <- rnorm(50, mean = 5, sd = 2) + y <- rnorm(50, mean = 5.2, sd = 2) # small effect + + result <- smd_calc(x = x, y = y, alternative = "equivalence", + null.value = c(-0.8, 0.8), smd_ci = "z") + expect_s3_class(result, "htest") + expect_equal(length(result$null.value), 2) + expect_equal(names(result$null.value), c("lower bound", "upper bound")) + expect_true(result$p.value >= 0 && result$p.value <= 1) + + # CI should be 90% for equivalence (alpha=0.05) + expect_equal(attr(result$conf.int, "conf.level"), 0.90) +}) + +test_that("smd_calc minimal.effect test works", { + set.seed(42) + x <- rnorm(50, mean = 5, sd = 2) + y <- rnorm(50, mean = 8, sd = 2) # large effect + + result <- smd_calc(x = x, y = y, alternative = "minimal.effect", + null.value = c(-0.3, 0.3), smd_ci = "z") + expect_s3_class(result, "htest") + expect_equal(length(result$null.value), 2) + expect_true(result$p.value >= 0 && result$p.value <= 1) + expect_equal(attr(result$conf.int, "conf.level"), 0.90) +}) + +test_that("smd_calc errors on bad equivalence bounds", { + set.seed(42) + x <- rnorm(20) + y <- rnorm(20) + + expect_error( + smd_calc(x = x, y = y, alternative = "equivalence", null.value = 0.5), + "null.value must be a vector of two values" + ) +}) + +test_that("smd_calc warns when null.value has >1 element for standard alternative", { + set.seed(42) + x <- rnorm(20) + y <- rnorm(20) + + expect_warning( + smd_calc(x = x, y = y, alternative = "two.sided", + null.value = c(0, 0.5), smd_ci = "z"), + "null.value has length > 1" + ) +}) + +test_that("smd_calc warns on test_method/smd_ci mismatch", { + set.seed(42) + x <- rnorm(20) + y <- rnorm(20) + + expect_warning( + smd_calc(x = x, y = y, alternative = "two.sided", + test_method = "t", smd_ci = "z"), + "test_method.*differs from smd_ci" + ) +}) + +test_that("smd_calc one-sample htest works", { + set.seed(42) + x <- rnorm(30, mean = 0.5, sd = 1) + + result <- smd_calc(x = x, alternative = "two.sided", + null.value = 0, smd_ci = "z") + expect_s3_class(result, "htest") + expect_true(!is.null(result$statistic)) + expect_true(!is.null(result$p.value)) +}) + +test_that("smd_calc paired htest works", { + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 5.5, sd = 2) + + result <- smd_calc(x = x, y = y, paired = TRUE, + alternative = "two.sided", null.value = 0, smd_ci = "z") + expect_s3_class(result, "htest") + expect_true(!is.null(result$statistic)) + expect_true(!is.null(result$p.value)) +}) + +# --- boot_smd_calc htest output --- + +test_that("boot_smd_calc returns htest by default", { + skip_on_cran() + set.seed(42) + x <- rnorm(20, mean = 5, sd = 2) + y <- rnorm(20, mean = 6, sd = 2) + + result <- boot_smd_calc(x = x, y = y, R = 99) + expect_s3_class(result, "htest") + expect_true(!is.null(result$estimate)) + expect_true(!is.null(result$stderr)) + expect_true(!is.null(result$conf.int)) + expect_true(!is.null(result$method)) + expect_true(!is.null(result$boot)) + expect_true(!is.null(result$data.name)) + expect_equal(length(result$boot), 99) + + # No hypothesis test by default + expect_null(result$statistic) + expect_null(result$p.value) + expect_null(result$null.value) +}) + +test_that("boot_smd_calc htest estimate matches data.frame", { + skip_on_cran() + set.seed(42) + x <- rnorm(20, mean = 5, sd = 2) + y <- rnorm(20, mean = 6, sd = 2) + + ht <- boot_smd_calc(x = x, y = y, R = 99) + df <- boot_smd_calc(x = x, y = y, R = 99, output = "data.frame") + + # Point estimates should match (both come from same raw_smd call) + expect_equal(unname(ht$estimate), df$estimate) +}) + +test_that("boot_smd_calc two.sided test works", { + skip_on_cran() + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 7, sd = 2) + + result <- boot_smd_calc(x = x, y = y, R = 199, + alternative = "two.sided", null.value = 0) + expect_s3_class(result, "htest") + expect_true(!is.null(result$statistic)) + expect_true(!is.null(result$p.value)) + expect_equal(names(result$statistic), "z-observed") + expect_true(result$p.value >= 0 && result$p.value <= 1) +}) + +test_that("boot_smd_calc equivalence test works", { + skip_on_cran() + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 5.1, sd = 2) + + result <- boot_smd_calc(x = x, y = y, R = 199, + alternative = "equivalence", + null.value = c(-0.8, 0.8)) + expect_s3_class(result, "htest") + expect_equal(length(result$null.value), 2) + expect_equal(names(result$null.value), c("lower bound", "upper bound")) + expect_true(result$p.value >= 0 && result$p.value <= 1) + expect_equal(attr(result$conf.int, "conf.level"), 0.90) +}) + +test_that("boot_smd_calc minimal.effect test works", { + skip_on_cran() + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 7, sd = 2) + + result <- boot_smd_calc(x = x, y = y, R = 199, + alternative = "minimal.effect", + null.value = c(-0.3, 0.3)) + expect_s3_class(result, "htest") + expect_equal(length(result$null.value), 2) + expect_true(result$p.value >= 0 && result$p.value <= 1) +}) + +test_that("boot_smd_calc one-sided tests work", { + skip_on_cran() + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 7, sd = 2) + + r_less <- boot_smd_calc(x = x, y = y, R = 199, + alternative = "less", null.value = 0) + r_greater <- boot_smd_calc(x = x, y = y, R = 199, + alternative = "greater", null.value = 0) + + expect_s3_class(r_less, "htest") + expect_s3_class(r_greater, "htest") + expect_true(r_less$p.value >= 0 && r_less$p.value <= 1) + expect_true(r_greater$p.value >= 0 && r_greater$p.value <= 1) +}) + +test_that("boot_smd_calc errors on bad equivalence bounds", { + skip_on_cran() + set.seed(42) + x <- rnorm(20) + y <- rnorm(20) + + expect_error( + boot_smd_calc(x = x, y = y, R = 99, + alternative = "equivalence", null.value = 0.5), + "null.value must be a vector of two values" + ) +}) + +test_that("boot_smd_calc formula interface returns htest", { + skip_on_cran() + set.seed(42) + df <- data.frame( + value = c(rnorm(20, 5, 2), rnorm(20, 6, 2)), + group = factor(rep(c("A", "B"), each = 20)) + ) + + result <- boot_smd_calc(formula = value ~ group, data = df, R = 99) + expect_s3_class(result, "htest") + expect_equal(result$data.name, "value by group") +}) + +test_that("boot_smd_calc method string is correct", { + skip_on_cran() + set.seed(42) + x <- rnorm(20, mean = 5, sd = 2) + y <- rnorm(20, mean = 6, sd = 2) + + r1 <- boot_smd_calc(x = x, y = y, R = 99) + expect_true(grepl("bootstrapped", r1$method)) + expect_true(grepl("Two Sample", r1$method)) + expect_true(grepl("SMD; Hedges's g[av]=", r1$method, fixed = TRUE)) + expect_true(is.null(r1$p.value)) + r2 <- boot_smd_calc(x = x, y = y, R = 99, + alternative = "two.sided", null.value = 0) + expect_true(is.numeric(r2$p.value)) +}) + +# boot_smd_calc CI/p-value agreement tests ----- + +for (ci_method in c("perc", "basic", "bca", "stud")) { + test_that(paste0("boot_smd_calc: CI/p-value agreement for ", ci_method), { + skip_on_cran() + + set.seed(42) + x <- rnorm(30, mean = 0.5) + y <- rnorm(30) + + res <- boot_smd_calc(x = x, y = y, + alternative = "two.sided", + null.value = 0, + boot_ci = ci_method, R = 1999) + ci_excludes_null <- res$conf.int[1] > 0 || res$conf.int[2] < 0 + p_rejects <- res$p.value < 0.05 + expect_equal(ci_excludes_null, p_rejects, + label = paste(ci_method, "CI/p agreement two.sided")) + }) +} diff --git a/tests/testthat/test-smd_calc_labels.R b/tests/testthat/test-smd_calc_labels.R new file mode 100644 index 0000000..708b2e6 --- /dev/null +++ b/tests/testthat/test-smd_calc_labels.R @@ -0,0 +1,227 @@ +# Tests for smd_calc label logic (estimate names, method strings, null.value names) + +hush = function(code) { + sink(nullfile()) + tmp = code + sink() + return(tmp) +} + +set.seed(42) +group1 <- rnorm(30, mean = 100, sd = 15) +group2 <- rnorm(30, mean = 110, sd = 18) +before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8) +after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2) + +# --- Estimate name tests (SMD (d/g[subscript]) format) --- + +test_that("Two-sample var.equal=FALSE bias_correction=FALSE => SMD (d[av])", { + res <- smd_calc(x = group1, y = group2, + var.equal = FALSE, bias_correction = FALSE) + expect_equal(names(res$estimate), "SMD (d[av])") +}) + +test_that("Two-sample var.equal=TRUE bias_correction=FALSE => SMD (d[s])", { + res <- smd_calc(x = group1, y = group2, + var.equal = TRUE, bias_correction = FALSE) + expect_equal(names(res$estimate), "SMD (d[s])") +}) + +test_that("Two-sample var.equal=FALSE bias_correction=TRUE => SMD (g[av])", { + res <- smd_calc(x = group1, y = group2, + var.equal = FALSE, bias_correction = TRUE) + expect_equal(names(res$estimate), "SMD (g[av])") +}) + +test_that("Two-sample var.equal=TRUE bias_correction=TRUE => SMD (g[s])", { + res <- smd_calc(x = group1, y = group2, + var.equal = TRUE, bias_correction = TRUE) + expect_equal(names(res$estimate), "SMD (g[s])") +}) + +test_that("Two-sample denom='pooled' bias_correction=FALSE => SMD (d[s])", { + res <- hush(smd_calc(x = group1, y = group2, + denom = "pooled", bias_correction = FALSE)) + expect_equal(names(res$estimate), "SMD (d[s])") +}) + +test_that("Two-sample denom='avg' bias_correction=FALSE => SMD (d[av])", { + res <- hush(smd_calc(x = group1, y = group2, + denom = "avg", bias_correction = FALSE)) + expect_equal(names(res$estimate), "SMD (d[av])") +}) + +test_that("Two-sample glass='glass1' default => SMD (g[x])", { + res <- smd_calc(x = group1, y = group2, glass = "glass1") + expect_equal(names(res$estimate), "SMD (g[x])") +}) + +test_that("Two-sample glass='glass2' default => SMD (g[y])", { + res <- smd_calc(x = group1, y = group2, glass = "glass2") + expect_equal(names(res$estimate), "SMD (g[y])") +}) + +test_that("Two-sample glass='glass1' bias_correction=FALSE => SMD (d[x])", { + res <- smd_calc(x = group1, y = group2, glass = "glass1", + bias_correction = FALSE) + expect_equal(names(res$estimate), "SMD (d[x])") +}) + +test_that("Paired default => SMD (g[z])", { + res <- smd_calc(x = before, y = after, paired = TRUE) + expect_equal(names(res$estimate), "SMD (g[z])") +}) + +test_that("Paired rm_correction=TRUE => SMD (g[rm])", { + res <- smd_calc(x = before, y = after, paired = TRUE, rm_correction = TRUE) + expect_equal(names(res$estimate), "SMD (g[rm])") +}) + +test_that("One-sample default => SMD (g[z])", { + res <- smd_calc(x = group1) + expect_equal(names(res$estimate), "SMD (g[z])") +}) + +# --- Method string SD notation tests --- + +test_that("Two-sample var.equal=FALSE method contains SD_avg", { + res <- smd_calc(x = group1, y = group2, var.equal = FALSE) + expect_true(grepl("SD_avg", res$method, fixed = TRUE)) +}) + +test_that("Two-sample var.equal=TRUE method contains SD_pooled", { + res <- smd_calc(x = group1, y = group2, var.equal = TRUE) + expect_true(grepl("SD_pooled", res$method, fixed = TRUE)) +}) + +test_that("Two-sample denom='pooled' method contains SD_pooled", { + res <- hush(smd_calc(x = group1, y = group2, denom = "pooled")) + expect_true(grepl("SD_pooled", res$method, fixed = TRUE)) +}) + +test_that("Two-sample denom='avg' method contains SD_avg", { + res <- hush(smd_calc(x = group1, y = group2, denom = "avg")) + expect_true(grepl("SD_avg", res$method, fixed = TRUE)) +}) + +test_that("Paired default method contains SD_z", { + res <- smd_calc(x = before, y = after, paired = TRUE) + expect_true(grepl("SD_z", res$method, fixed = TRUE)) +}) + +test_that("Paired rm_correction=TRUE method contains SD_rm", { + res <- smd_calc(x = before, y = after, paired = TRUE, rm_correction = TRUE) + expect_true(grepl("SD_rm", res$method, fixed = TRUE)) +}) + +test_that("One-sample default method contains SD_z", { + res <- smd_calc(x = group1) + expect_true(grepl("SD_z", res$method, fixed = TRUE)) +}) + +test_that("Two-sample glass='glass1' method contains SD_x", { + res <- smd_calc(x = group1, y = group2, glass = "glass1") + expect_true(grepl("SD_x", res$method, fixed = TRUE)) +}) + +# --- Method string contains SMD label --- + +test_that("Method string contains merged SMD label with notation", { + res <- smd_calc(x = group1, y = group2, var.equal = FALSE, + bias_correction = FALSE) + expect_true(grepl("SMD; Cohen's d[av]=(x-y)/SD_avg)", res$method, fixed = TRUE)) + + res2 <- smd_calc(x = group1, y = group2, var.equal = TRUE, + bias_correction = TRUE) + expect_true(grepl("SMD; Hedges's g[s]=(x-y)/SD_pooled)", res2$method, fixed = TRUE)) +}) + +# --- Formula method group name substitution tests --- + +test_that("Formula glass='glass1' substitutes group names in estimate and method", { + df <- data.frame( + value = c(group1, group2), + group = factor(rep(c("A", "B"), each = 30)) + ) + res <- smd_calc(formula = value ~ group, data = df, glass = "glass1") + expect_equal(names(res$estimate), "SMD (g[A])") + expect_true(grepl("g[A]", res$method, fixed = TRUE)) + expect_true(grepl("SD_A", res$method, fixed = TRUE)) +}) + +test_that("Formula glass='glass2' substitutes group names in estimate and method", { + df <- data.frame( + value = c(group1, group2), + group = factor(rep(c("A", "B"), each = 30)) + ) + res <- smd_calc(formula = value ~ group, data = df, glass = "glass2") + expect_equal(names(res$estimate), "SMD (g[B])") + expect_true(grepl("g[B]", res$method, fixed = TRUE)) + expect_true(grepl("SD_B", res$method, fixed = TRUE)) +}) + +test_that("Formula glass='glass1' bias_correction=FALSE shows d not g", { + df <- data.frame( + value = c(group1, group2), + group = factor(rep(c("A", "B"), each = 30)) + ) + res <- smd_calc(formula = value ~ group, data = df, glass = "glass1", + bias_correction = FALSE) + expect_equal(names(res$estimate), "SMD (d[A])") + expect_true(grepl("d[A]", res$method, fixed = TRUE)) +}) + +test_that("Formula var.equal=FALSE keeps bracket subscript (no group name swap)", { + df <- data.frame( + value = c(group1, group2), + group = factor(rep(c("A", "B"), each = 30)) + ) + res <- smd_calc(formula = value ~ group, data = df, var.equal = FALSE) + # Subscript [av] should remain unchanged (not a group name) + expect_equal(names(res$estimate), "SMD (g[av])") + expect_true(grepl("SD_avg", res$method, fixed = TRUE)) + expect_true(grepl("(A-B)", res$method, fixed = TRUE)) +}) + +# --- null.value name tests --- + +test_that("Standard alternative null.value names are 'SMD'", { + res <- smd_calc(x = group1, y = group2, + alternative = "two.sided", null.value = 0) + expect_equal(names(res$null.value), "SMD") +}) + +test_that("Equivalence alternative null.value names are bounds", { + res <- smd_calc(x = group1, y = group2, + alternative = "equivalence", null.value = c(-0.5, 0.5)) + expect_equal(names(res$null.value), c("lower bound", "upper bound")) +}) + +# --- Trimming note preserved --- + +test_that("Trimmed estimate label includes trim note with subscript", { + res <- hush(smd_calc(x = group1, y = group2, + tr = 0.1, var.equal = FALSE, bias_correction = FALSE)) + expect_equal(names(res$estimate), "SMD (d[av], 10% trimmed)") +}) + +# --- Consistency between smd_calc and boot_smd_calc --- + +test_that("boot_smd_calc labels match smd_calc labels", { + skip_on_cran() + set.seed(42) + x <- rnorm(20, mean = 5, sd = 2) + y <- rnorm(20, mean = 6, sd = 2) + + res_smd <- smd_calc(x = x, y = y, bias_correction = FALSE) + res_boot <- boot_smd_calc(x = x, y = y, bias_correction = FALSE, R = 99) + expect_equal(names(res_smd$estimate), names(res_boot$estimate)) + + res_smd2 <- smd_calc(x = x, y = y, bias_correction = TRUE) + res_boot2 <- boot_smd_calc(x = x, y = y, bias_correction = TRUE, R = 99) + expect_equal(names(res_smd2$estimate), names(res_boot2$estimate)) + + res_smd3 <- smd_calc(x = x, y = y, paired = TRUE) + res_boot3 <- boot_smd_calc(x = x, y = y, paired = TRUE, R = 99) + expect_equal(names(res_smd3$estimate), names(res_boot3$estimate)) +}) diff --git a/tests/testthat/test-smd_calc_trimmed.R b/tests/testthat/test-smd_calc_trimmed.R new file mode 100644 index 0000000..273713a --- /dev/null +++ b/tests/testthat/test-smd_calc_trimmed.R @@ -0,0 +1,292 @@ +# Tests for trimmed SMD functionality in smd_calc and boot_smd_calc +# Following the specification in references/working/trimmed_smd_spec.md + +# Helper to access internal functions +trim_rescale <- TOSTER:::trim_rescale +winvar <- TOSTER:::winvar +trim_h <- TOSTER:::trim_h + +# --- 11.1 Parameter Validation --- + +test_that("tr parameter validation works", { + x <- rnorm(30) + y <- rnorm(30) + + # Invalid tr values + expect_error(smd_calc(x = x, y = y, tr = -0.1), "tr") + expect_error(smd_calc(x = x, y = y, tr = 0.5), "tr") + expect_error(smd_calc(x = x, y = y, tr = "a"), "tr") + expect_error(smd_calc(x = x, y = y, tr = c(0.1, 0.2)), "tr") + + # tr = 0 should work (default) + expect_no_error(smd_calc(x = x, y = y, tr = 0)) + + # Incompatible combinations + expect_error(smd_calc(x = x, y = y, paired = TRUE, + rm_correction = TRUE, tr = 0.2), + "rm.*not.*supported.*trimming|not currently supported with trimming") + expect_error(smd_calc(x = x, y = y, tr = 0.2, smd_ci = "goulet"), + "goulet.*not.*supported.*trimming|not supported with trimming") + + # Same for boot + expect_error(boot_smd_calc(x = x, y = y, tr = -0.1, R = 99), "tr") + expect_error(boot_smd_calc(x = x, y = y, paired = TRUE, + rm_correction = TRUE, tr = 0.2, R = 99), + "rm.*not.*supported.*trimming|not currently supported with trimming") +}) + + +# --- 11.2 Backward Compatibility (tr = 0) --- + +test_that("tr = 0 gives identical results to no-tr call", { + set.seed(42) + x <- rnorm(30, mean = 5, sd = 2) + y <- rnorm(30, mean = 7, sd = 2) + + # Two-sample + res_default <- smd_calc(x = x, y = y) + res_tr0 <- smd_calc(x = x, y = y, tr = 0) + expect_equal(res_default$estimate, res_tr0$estimate) + expect_equal(res_default$conf.int, res_tr0$conf.int) + expect_equal(res_default$stderr, res_tr0$stderr) + + # Paired + res_default_p <- smd_calc(x = x, y = y, paired = TRUE) + res_tr0_p <- smd_calc(x = x, y = y, paired = TRUE, tr = 0) + expect_equal(res_default_p$estimate, res_tr0_p$estimate) + expect_equal(res_default_p$conf.int, res_tr0_p$conf.int) + + # One-sample + res_default_o <- smd_calc(x = x) + res_tr0_o <- smd_calc(x = x, tr = 0) + expect_equal(res_default_o$estimate, res_tr0_o$estimate) + expect_equal(res_default_o$conf.int, res_tr0_o$conf.int) +}) + + +# --- 11.3 Known Values Under Normality --- + +test_that("trimmed SMD approximates untrimmed under normality for large n", { + set.seed(123) + x <- rnorm(200, mean = 0, sd = 1) + y <- rnorm(200, mean = 0.5, sd = 1) + + res_std <- smd_calc(x = x, y = y, bias_correction = FALSE, smd_ci = "z") + res_trim <- smd_calc(x = x, y = y, bias_correction = FALSE, tr = 0.2, smd_ci = "z") + + # Under normality with large n, these should be in the same ballpark + expect_equal(unname(res_std$estimate), unname(res_trim$estimate), tolerance = 0.15) +}) + + +# --- 11.4 Rescaling Constant Accuracy --- + +test_that("trim_rescale returns correct known values", { + # c(0) = 1 + expect_equal(trim_rescale(0), 1) + + # c(0.2) should be approximately 0.642 + expect_equal(trim_rescale(0.2), 0.642, tolerance = 0.001) + + # c(0.1) -- compute expected value + a <- qnorm(0.9) + expected <- sqrt(1 - 0.2 + 0.2 * a^2 - 2 * a * dnorm(a)) + expect_equal(trim_rescale(0.1), expected) +}) + + +# --- 11.5 Robustness to Outliers --- + +test_that("trimmed SMD is robust to outliers", { + set.seed(456) + x <- rnorm(30, mean = 0, sd = 1) + y <- rnorm(30, mean = 0.5, sd = 1) + + # Add outliers + x_out <- c(x, 50, -50) # extreme outliers + y_out <- c(y, 55, -45) + + res_clean <- smd_calc(x = x, y = y, bias_correction = FALSE, smd_ci = "z") + res_contaminated <- smd_calc(x = x_out, y = y_out, bias_correction = FALSE, smd_ci = "z") + res_robust <- smd_calc(x = x_out, y = y_out, bias_correction = FALSE, tr = 0.2, smd_ci = "z") + + # Standard SMD should be heavily affected by outliers + expect_true(abs(unname(res_contaminated$estimate) - unname(res_clean$estimate)) > 0.1) + + # Trimmed SMD should be much closer to the clean data result + expect_true(abs(unname(res_robust$estimate) - unname(res_clean$estimate)) < + abs(unname(res_contaminated$estimate) - unname(res_clean$estimate))) +}) + + +# --- 11.6 Degrees of Freedom Modification --- + +test_that("degrees of freedom are correctly adjusted for trimming", { + set.seed(789) + x <- rnorm(30) + y <- rnorm(30) + + # For tr = 0.2, g = floor(0.2 * 30) = 6, h = 30 - 12 = 18 + # df for pooled two-sample = h1 + h2 - 2 = 18 + 18 - 2 = 34 + res <- smd_calc(x = x, y = y, tr = 0.2, smd_ci = "t", var.equal = TRUE, + alternative = "two.sided", null.value = 0, test_method = "t") + # The df should be 34 (not 58 as in the untrimmed case) + expect_equal(res$parameter[["df"]], 34) + + # For one-sample: df = h - 1 = 18 - 1 = 17 + res_one <- smd_calc(x = x, tr = 0.2, smd_ci = "t", + alternative = "two.sided", null.value = 0, test_method = "t") + expect_equal(res_one$parameter[["df"]], 17) +}) + + +# --- 11.7 All Denominator Options with Trimming --- + +test_that("all supported denom options work with tr > 0", { + set.seed(101) + x <- rnorm(30, mean = 0, sd = 1) + y <- rnorm(30, mean = 0.8, sd = 1.5) + + # Two-sample denominators + expect_no_error(smd_calc(x = x, y = y, denom = "pooled", tr = 0.1)) + expect_no_error(smd_calc(x = x, y = y, denom = "avg", tr = 0.1)) + expect_no_error(smd_calc(x = x, y = y, denom = "glass1", tr = 0.1)) + expect_no_error(smd_calc(x = x, y = y, denom = "glass2", tr = 0.1)) + + # Paired denominators + expect_no_error(smd_calc(x = x, y = y, paired = TRUE, denom = "z", tr = 0.1)) + expect_no_error(smd_calc(x = x, y = y, paired = TRUE, denom = "glass1", tr = 0.1)) + + # One-sample + expect_no_error(smd_calc(x = x, tr = 0.1)) +}) + + +# --- 11.8 Bootstrap Pass-Through --- + +test_that("boot_smd_calc correctly passes tr to internal calls", { + set.seed(202) + x <- rnorm(20, mean = 0, sd = 1) + y <- rnorm(20, mean = 0.5, sd = 1) + + # Should run without error + res <- boot_smd_calc(x = x, y = y, tr = 0.2, R = 199, boot_ci = "perc") + expect_s3_class(res, "htest") + expect_true(!is.na(res$estimate)) + expect_true(all(!is.na(res$conf.int))) + + # Estimate should match smd_calc with same trimming + res_point <- smd_calc(x = x, y = y, tr = 0.2, smd_ci = "z") + expect_equal(unname(res$estimate), unname(res_point$estimate)) +}) + + +# --- 11.9 CI Method Compatibility --- + +test_that("CI methods work with trimming", { + set.seed(303) + x <- rnorm(40) + y <- rnorm(40, mean = 0.5) + + # These should work + expect_no_error(smd_calc(x = x, y = y, tr = 0.2, smd_ci = "nct")) + expect_no_error(smd_calc(x = x, y = y, tr = 0.2, smd_ci = "t")) + expect_no_error(smd_calc(x = x, y = y, tr = 0.2, smd_ci = "z")) + + # This should fail + expect_error(smd_calc(x = x, y = y, tr = 0.2, smd_ci = "goulet"), + "goulet.*not.*supported|not supported with trimming") +}) + + +# --- 11.10 Hypothesis Testing with Trimming --- + +test_that("hypothesis testing works with trimmed SMD", { + set.seed(404) + x <- rnorm(30) + y <- rnorm(30, mean = 1) + + # Two-sided test + res <- smd_calc(x = x, y = y, tr = 0.2, + alternative = "two.sided", null.value = 0) + expect_true(!is.na(res$p.value)) + expect_true(res$p.value >= 0 && res$p.value <= 1) + + # Equivalence test + res_eq <- smd_calc(x = x, y = y, tr = 0.2, + alternative = "equivalence", null.value = c(-2, 2)) + expect_true(!is.na(res_eq$p.value)) + + # Bootstrap hypothesis test + res_boot <- boot_smd_calc(x = x, y = y, tr = 0.2, R = 199, + alternative = "two.sided", null.value = 0) + expect_true(!is.na(res_boot$p.value)) +}) + + +# --- 11.11 Edge Case: Small Sample with Trimming --- + +test_that("trimming with small samples is handled correctly", { + x <- rnorm(5) + y <- rnorm(5) + + # tr = 0.2 with n = 5: g = floor(0.2*5) = 1, h = 3, which is OK + expect_no_error(smd_calc(x = x, y = y, tr = 0.2)) + + # tr = 0.4 with n = 5: g = floor(0.4*5) = 2, h = 1, should fail + expect_error(smd_calc(x = x, y = y, tr = 0.4), + "too many observations") +}) + + +# --- 11.12 Formula Interface with Trimming --- + +test_that("formula interface passes tr correctly", { + set.seed(505) + df <- data.frame( + value = c(rnorm(25), rnorm(25, mean = 0.5)), + group = factor(rep(c("A", "B"), each = 25)) + ) + + res_formula <- smd_calc(value ~ group, data = df, tr = 0.2) + res_direct <- smd_calc(x = df$value[df$group == "A"], + y = df$value[df$group == "B"], + tr = 0.2) + expect_equal(unname(res_formula$estimate), unname(res_direct$estimate)) + expect_equal(as.numeric(res_formula$conf.int), as.numeric(res_direct$conf.int)) +}) + + +# --- Additional: Internal helper functions --- + +test_that("winvar returns correct values", { + x <- c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) + + # With tr = 0, should equal var() + expect_equal(winvar(x, tr = 0), var(x)) + + # With tr = 0.2, g = 2, Winsorize: 3,3,3,4,5,6,7,8,8,8 + y <- c(3, 3, 3, 4, 5, 6, 7, 8, 8, 8) + expect_equal(winvar(x, tr = 0.2), var(y)) +}) + +test_that("trim_h returns correct effective sample size", { + expect_equal(trim_h(30, 0), 30) + expect_equal(trim_h(30, 0.2), 18) # g = 6, h = 30 - 12 = 18 + expect_equal(trim_h(10, 0.1), 8) # g = 1, h = 10 - 2 = 8 +}) + + +# --- Additional: SMD label includes trim note --- + +test_that("SMD label includes trimming note when tr > 0", { + set.seed(606) + x <- rnorm(30) + y <- rnorm(30, mean = 0.5) + + res_trim <- smd_calc(x = x, y = y, tr = 0.2, bias_correction = FALSE) + expect_true(grepl("trimmed", res_trim$method)) + + res_notrim <- smd_calc(x = x, y = y, tr = 0, bias_correction = FALSE) + expect_false(grepl("trimmed", res_notrim$method)) +}) diff --git a/tests/testthat/test-tTOST.R b/tests/testthat/test-tTOST.R index e042a41..fbc9ade 100644 --- a/tests/testthat/test-tTOST.R +++ b/tests/testthat/test-tTOST.R @@ -3,7 +3,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -12,7 +12,7 @@ hush = function(code) { test_that("Run examples for one sample", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -41,11 +41,8 @@ test_that("Run examples for one sample", { low_eqbound = -.5, high_eqbound = .5) test1_smd = smd_calc(x = samp1, - alpha = .1) - test1_smd_boot = boot_smd_calc(x = samp1, alpha = .1, - R = 99) - expect_equal(test1_smd$estimate, test1_smd_boot$estimate) + output = "data.frame") expect_equal(test1_smd$estimate, test1$effsize$estimate[2]) expect_equal(test1_smd$lower.ci, test1$effsize$lower.ci[2]) expect_equal(test1_smd$upper.ci, test1$effsize$upper.ci[2]) @@ -270,11 +267,19 @@ test_that("Run examples for one sample", { }) +test_that("boot_smd_calc one sample matches smd_calc", { + skip_on_cran() + set.seed(3164964) + samp1 = rnorm(33) + test1_smd = smd_calc(x = samp1, alpha = .1, output = "data.frame") + test1_smd_boot = boot_smd_calc(x = samp1, alpha = .1, R = 99, output = "data.frame") + expect_equal(test1_smd$estimate, test1_smd_boot$estimate) +}) test_that("Run examples for two sample", { hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -304,32 +309,8 @@ test_that("Run examples for two sample", { test1_smd = smd_calc(x = samp1, y = samp2, - alpha = .1) - - test1_smd_boot_stud = boot_smd_calc(x = samp1, - y = samp2, alpha = .1, - boot_ci = "stud", - R = 99) - test1_smd_boot_basic = boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "b", - R = 99) - expect_error(boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "n", - R = 99)) - test1_smd_boot_perc = boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "p", - R = 99) - expect_equal(rep(test1_smd$estimate,3), - c(test1_smd_boot_stud$estimate, - test1_smd_boot_basic$estimate, - test1_smd_boot_perc$estimate)) + output = "data.frame") expect_error(smd_calc(x = samp1, y = samp2, @@ -555,39 +536,8 @@ test_that("Run examples for two sample", { test1_smd = smd_calc(formula = y ~ group, data = df_samp, var.equal = TRUE, - bias_correction = FALSE) - test1_smd_boot_stud = boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "stud", - R = 99, - var.equal = TRUE, - bias_correction = FALSE) - test1_smd_boot_basic = boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "b", - R = 99, - var.equal = TRUE, - bias_correction = FALSE) - expect_error(boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "n", - R = 99, - var.equal = TRUE, - bias_correction = FALSE)) - test1_smd_boot_perc = boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "p", - R = 99, - var.equal = TRUE, - bias_correction = FALSE) - expect_equal(rep(test1_smd$estimate,3), - c(test1_smd_boot_stud$estimate, - test1_smd_boot_basic$estimate, - test1_smd_boot_perc$estimate)) + bias_correction = FALSE, + output = "data.frame") # test htest ash = as_htest(test1) test2 = suppressMessages( t_TOST(formula = y ~ group, @@ -652,6 +602,33 @@ test_that("Run examples for two sample", { }) +test_that("boot_smd_calc two sample matches smd_calc", { + skip_on_cran() + set.seed(76584441) + samp1 = rnorm(25) + samp2 = rnorm(25) + test1_smd = smd_calc(x = samp1, y = samp2, var.equal = TRUE, + bias_correction = FALSE, output = "data.frame") + test1_smd_boot_stud = boot_smd_calc(x = samp1, y = samp2, alpha = .1, + boot_ci = "stud", R = 99, + var.equal = TRUE, bias_correction = FALSE, + output = "data.frame") + test1_smd_boot_basic = boot_smd_calc(x = samp1, y = samp2, alpha = .1, + boot_ci = "basic", R = 99, + var.equal = TRUE, bias_correction = FALSE, + output = "data.frame") + expect_error(boot_smd_calc(x = samp1, y = samp2, alpha = .1, + boot_ci = "n", R = 99, + var.equal = TRUE, bias_correction = FALSE)) + test1_smd_boot_perc = boot_smd_calc(x = samp1, y = samp2, alpha = .1, + boot_ci = "p", R = 99, + var.equal = TRUE, bias_correction = FALSE, + output = "data.frame") + expect_equal(rep(test1_smd$estimate, 3), + c(test1_smd_boot_stud$estimate, + test1_smd_boot_basic$estimate, + test1_smd_boot_perc$estimate)) +}) test_that("Run examples for paired samples", { @@ -676,37 +653,8 @@ test_that("Run examples for paired samples", { test1_smd = smd_calc(x = samp1, y = samp2, paired = TRUE, - alpha = .1) - test1_smd_boot_stud = boot_smd_calc(x = samp1, - y = samp2, - paired = TRUE, - alpha = .1, - R = 99) - test1_smd_boot_basic = boot_smd_calc(x = samp1, - y = samp2, - paired = TRUE, - alpha = .1, - boot_ci = "b", - R = 99) - expect_error(boot_smd_calc(x = samp1, - y = samp2, - alpha = .1, - boot_ci = "n", - paired = TRUE, - R = 99, - var.equal = TRUE, - bias_correction = FALSE)) - test1_smd_boot_perc = boot_smd_calc(x = samp1, - y = samp2, - paired = TRUE, - alpha = .1, - boot_ci = "p", - R = 99) - expect_equal(rep(test1_smd$estimate,3), - c(test1_smd_boot_stud$estimate, - test1_smd_boot_basic$estimate, - test1_smd_boot_perc$estimate)) - + alpha = .1, + output = "data.frame") expect_equal(test1_smd$estimate, test1$effsize$estimate[2]) expect_equal(test1_smd$lower.ci, test1$effsize$lower.ci[2]) expect_equal(test1_smd$upper.ci, test1$effsize$upper.ci[2]) @@ -1013,6 +961,31 @@ test_that("Run examples for paired samples", { }) +test_that("boot_smd_calc paired matches smd_calc", { + skip_on_cran() + set.seed(789461245) + samp1 = rnorm(25) + samp2 = rnorm(25) + test1_smd = smd_calc(x = samp1, y = samp2, paired = TRUE, + alpha = .1, output = "data.frame") + test1_smd_boot_stud = boot_smd_calc(x = samp1, y = samp2, paired = TRUE, + alpha = .1, R = 99, output = "data.frame") + test1_smd_boot_basic = boot_smd_calc(x = samp1, y = samp2, paired = TRUE, + alpha = .1, boot_ci = "basic", + R = 99, output = "data.frame") + expect_error(boot_smd_calc(x = samp1, y = samp2, alpha = .1, + boot_ci = "n", paired = TRUE, + R = 99, var.equal = TRUE, + bias_correction = FALSE)) + test1_smd_boot_perc = boot_smd_calc(x = samp1, y = samp2, paired = TRUE, + alpha = .1, boot_ci = "p", + R = 99, output = "data.frame") + expect_equal(rep(test1_smd$estimate, 3), + c(test1_smd_boot_stud$estimate, + test1_smd_boot_basic$estimate, + test1_smd_boot_perc$estimate)) +}) + test_that("Run examples for plot_smd", { set.seed(1776) @@ -1621,9 +1594,17 @@ test_that("Formula methods reject paired = TRUE", { "Using 'paired = TRUE' with the formula interface is not recommended" ) + # sleep data has complete separation after zero-exclusion, so use + + # custom data with mixed-sign differences for boot_ses_calc + set.seed(42) + df_mixed <- data.frame( + val = c(rnorm(10), rnorm(10, mean = 0.3)), + grp = factor(rep(c("A", "B"), each = 10)) + ) expect_message( - boot_ses_calc(extra ~ group, data = sleep, paired = TRUE, R = 10), + hush(boot_ses_calc(val ~ grp, data = df_mixed, paired = TRUE, R = 10)), "Using 'paired = TRUE' with the formula interface is not recommended" ) - + }) diff --git a/tests/testthat/test-trans_rank_prob.R b/tests/testthat/test-trans_rank_prob.R new file mode 100644 index 0000000..edd0951 --- /dev/null +++ b/tests/testthat/test-trans_rank_prob.R @@ -0,0 +1,154 @@ +# test-trans_rank_prob.R + +# Identity -------- +test_that("trans_rank_prob returns inputs unchanged when from == to", { + for (s in c("probability", "difference", "logodds", "odds")) { + out <- trans_rank_prob(0.7, se = 0.05, ci = c(0.6, 0.8), + null = 0.5, from = s, to = s) + expect_equal(out$estimate, 0.7) + expect_equal(out$se, 0.05) + expect_equal(out$ci, c(0.6, 0.8)) + expect_equal(out$null, 0.5) + } +}) + +# Point estimates -------- +test_that("trans_rank_prob computes correct point estimates from probability", { + p <- 0.7 + expect_equal(trans_rank_prob(p, from = "probability", to = "difference")$estimate, + 2 * p - 1) + expect_equal(trans_rank_prob(p, from = "probability", to = "odds")$estimate, + p / (1 - p)) + expect_equal(trans_rank_prob(p, from = "probability", to = "logodds")$estimate, + log(p / (1 - p))) +}) + +test_that("trans_rank_prob computes correct point estimates from difference", { + d <- 0.4 # corresponds to p = 0.7 + expect_equal(trans_rank_prob(d, from = "difference", to = "probability")$estimate, + 0.7) + expect_equal(trans_rank_prob(d, from = "difference", to = "odds")$estimate, + 0.7 / 0.3, tolerance = 1e-10) +}) + +test_that("trans_rank_prob computes correct point estimates from logodds", { + eta <- qlogis(0.7) + expect_equal(trans_rank_prob(eta, from = "logodds", to = "probability")$estimate, + 0.7, tolerance = 1e-10) + expect_equal(trans_rank_prob(eta, from = "logodds", to = "difference")$estimate, + 0.4, tolerance = 1e-10) +}) + +test_that("trans_rank_prob computes correct point estimates from odds", { + alpha <- 0.7 / 0.3 + expect_equal(trans_rank_prob(alpha, from = "odds", to = "probability")$estimate, + 0.7, tolerance = 1e-10) +}) + +# Round-trip SE -------- +test_that("trans_rank_prob SE round-trips through all scales", { + for (s in c("difference", "logodds", "odds")) { + out <- trans_rank_prob(0.7, se = 0.05, from = "probability", to = s) + back <- trans_rank_prob(out$estimate, se = out$se, from = s, to = "probability") + expect_equal(back$se, 0.05, tolerance = 1e-10) + } +}) + +# Round-trip CI -------- +test_that("trans_rank_prob CI round-trips through all scales", { + for (s in c("difference", "logodds", "odds")) { + out <- trans_rank_prob(0.7, ci = c(0.6, 0.8), from = "probability", to = s) + back <- trans_rank_prob(out$estimate, ci = out$ci, from = s, to = "probability") + expect_equal(back$ci, c(0.6, 0.8), tolerance = 1e-10) + } +}) + +# Cross-scale without going through probability -------- +test_that("trans_rank_prob handles non-probability from/to pairs", { + # difference -> logodds (should route through probability internally) + d <- 0.4 + out <- trans_rank_prob(d, se = 0.1, ci = c(0.2, 0.6), + from = "difference", to = "logodds") + # Verify against manual: d=0.4 -> p=0.7 -> logodds = qlogis(0.7) + expect_equal(out$estimate, qlogis(0.7), tolerance = 1e-10) + + # odds -> difference + alpha <- 0.7 / 0.3 + out2 <- trans_rank_prob(alpha, from = "odds", to = "difference") + expect_equal(out2$estimate, 0.4, tolerance = 1e-10) +}) + +# Null values -------- +test_that("trans_rank_prob transforms null values", { + out <- trans_rank_prob(0.7, null = 0.5, from = "probability", to = "difference") + expect_equal(out$null, 0) + + out2 <- trans_rank_prob(0.7, null = 0.5, from = "probability", to = "logodds") + expect_equal(out2$null, 0) + + out3 <- trans_rank_prob(0.7, null = 0.5, from = "probability", to = "odds") + expect_equal(out3$null, 1) +}) + +test_that("trans_rank_prob transforms equivalence bounds", { + out <- trans_rank_prob(0.7, null = c(0.35, 0.65), + from = "probability", to = "difference") + expect_equal(out$null, c(-0.3, 0.3)) +}) + +# NULL handling -------- +test_that("trans_rank_prob handles NULL optional arguments", { + out <- trans_rank_prob(0.7, from = "probability", to = "difference") + expect_null(out$se) + expect_null(out$ci) + expect_null(out$null) + expect_equal(out$estimate, 0.4) +}) + +# Boundary behavior -------- +test_that("trans_rank_prob handles boundary probability values", { + out <- trans_rank_prob(0, from = "probability", to = "logodds") + expect_equal(out$estimate, -Inf) + + out2 <- trans_rank_prob(1, from = "probability", to = "logodds") + expect_equal(out2$estimate, Inf) + + out3 <- trans_rank_prob(1, from = "probability", to = "odds") + expect_equal(out3$estimate, Inf) +}) + +# Consistency with ses_calc internals -------- +test_that("trans_rank_prob matches ses_calc transformation functions", { + # rb = 2*cstat - 1 (i.e., difference = 2*probability - 1) + p <- 0.7 + expect_equal( + trans_rank_prob(p, from = "probability", to = "difference")$estimate, + 2 * p - 1 + ) + # odds = p / (1-p) + expect_equal( + trans_rank_prob(p, from = "probability", to = "odds")$estimate, + p / (1 - p) + ) + # logodds = log(p / (1-p)) + expect_equal( + trans_rank_prob(p, from = "probability", to = "logodds")$estimate, + log(p / (1 - p)) + ) + # SE for difference = 2 * SE_p + se_p <- 0.05 + expect_equal( + trans_rank_prob(p, se = se_p, from = "probability", to = "difference")$se, + 2 * se_p + ) + # SE for logodds = SE_p / (p * (1-p)) + expect_equal( + trans_rank_prob(p, se = se_p, from = "probability", to = "logodds")$se, + se_p / (p * (1 - p)) + ) + # SE for odds = SE_p / (1-p)^2 + expect_equal( + trans_rank_prob(p, se = se_p, from = "probability", to = "odds")$se, + se_p / (1 - p)^2 + ) +}) diff --git a/tests/testthat/test-twoprop.R b/tests/testthat/test-twoprop.R index 379c3f2..c633773 100644 --- a/tests/testthat/test-twoprop.R +++ b/tests/testthat/test-twoprop.R @@ -1,7 +1,7 @@ # need hush function to run print through examples hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -158,6 +158,12 @@ test_that("Random tests against prop_test",{ expect_equal(abs(ptest_base$conf.int[1] - ptest_base$conf.int[1]),0,tolerance=.001) expect_equal(abs(ptest_base$conf.int[2] - ptest_base$conf.int[2]),0,tolerance=.001) + +}) + +test_that("Random tests against prop_test with loop",{ + skip_on_cran() + set.seed(16281940) for(i in 1:100){ #print(i) @@ -204,8 +210,8 @@ test_that("Random tests against prop_test",{ } -}) +}) test_that("power",{ expect_error(power_twoprop(p1 = .1, diff --git a/tests/testthat/test-wilcox.R b/tests/testthat/test-wilcox.R index 4db68ae..09ee589 100644 --- a/tests/testthat/test-wilcox.R +++ b/tests/testthat/test-wilcox.R @@ -1,5 +1,5 @@ hush = function(code) { - sink("NUL") # use /dev/null in UNIX + sink(nullfile()) tmp = code sink() return(tmp) @@ -27,7 +27,6 @@ test_that("Run examples for one sample", { # Test data.frame output for backward compatibility test1_ses_df = ses_calc(x = samp1, alpha = .1, - se_method = "fisher", output = "data.frame") expect_equal(test1$effsize$estimate[2], test1_ses_df$estimate) @@ -41,14 +40,37 @@ test_that("Run examples for one sample", { expect_s3_class(test1_ses_htest, "htest") expect_equal(unname(test1_ses_htest$estimate), test1$effsize$estimate[2]) +}) + +test_that("Bootstrap tests for one sample", { + skip_on_cran() + + set.seed(3164964) + samp1 = rnorm(33) + test1_ses = boot_ses_calc(x = samp1, alpha = .1, boot_ci = "s") + expect_s3_class(test1_ses, "htest") test1_ses = boot_ses_calc(x = samp1, alpha = .1, boot_ci = "p") + expect_s3_class(test1_ses, "htest") test1_ses = boot_ses_calc(x = samp1, alpha = .1) + expect_s3_class(test1_ses, "htest") + +}) + +test_that("Run examples for one sample continued", { + + set.seed(3164964) + + samp1 = rnorm(33) + + test1 = wilcox_TOST(x = samp1, + low_eqbound = -.5, + high_eqbound = .5) ash = as_htest(test1) test3 = wilcox_TOST(x = samp1, @@ -100,6 +122,59 @@ test_that("Run examples for two sample", { low_eqbound = -.5, high_eqbound = .5) # Test with data.frame output for comparison with boot_ses_calc + test1_smd = ses_calc(formula = y ~ group, + data = df_samp, + output = "data.frame") + test1_smd_cstat = ses_calc(formula = y ~ group, + data = df_samp, + ses = "cstat", + output = "data.frame") + test1_smd_odds = ses_calc(formula = y ~ group, + data = df_samp, + ses = "odds", + output = "data.frame") + test1_smd_logodds = ses_calc(formula = y ~ group, + data = df_samp, + ses = "logodds", + output = "data.frame") + + # Test htest output (new default) + test1_smd_htest = ses_calc(formula = y ~ group, data = df_samp) + expect_s3_class(test1_smd_htest, "htest") + + expect_error(ses_calc(formula = y ~ group, + data = df_samp, + alpha = 1.1)) + + test3 = wilcox_TOST(formula = y ~ group, + data = df_samp, + low_eqbound = -.5, + high_eqbound = .5, + hypothesis = "MET") + + expect_equal(1-test1$TOST$p.value[2], + test3$TOST$p.value[2], + tolerance = .003) + + expect_equal(1-test1$TOST$p.value[3], + test3$TOST$p.value[3], + tolerance = .003) + prtest = hush(print(test3)) + +}) + +test_that("Bootstrap tests for two sample", { + skip_on_cran() + + set.seed(651466441) + + samp1 = rnorm(25) + samp2 = rnorm(25) + + df_samp = data.frame(y = c(samp1,samp2), + group = c(rep("g1",25), + rep("g2",25))) + test1_smd = ses_calc(formula = y ~ group, data = df_samp, output = "data.frame") @@ -141,29 +216,6 @@ test_that("Run examples for two sample", { expect_equal(unname(test1_smd_boot_logodds$estimate), test1_smd_logodds$estimate) - # Test htest output (new default) - test1_smd_htest = ses_calc(formula = y ~ group, data = df_samp) - expect_s3_class(test1_smd_htest, "htest") - - expect_error(ses_calc(formula = y ~ group, - data = df_samp, - alpha = 1.1)) - - test3 = wilcox_TOST(formula = y ~ group, - data = df_samp, - low_eqbound = -.5, - high_eqbound = .5, - hypothesis = "MET") - - expect_equal(1-test1$TOST$p.value[2], - test3$TOST$p.value[2], - tolerance = .003) - - expect_equal(1-test1$TOST$p.value[3], - test3$TOST$p.value[3], - tolerance = .003) - prtest = hush(print(test3)) - }) @@ -205,10 +257,6 @@ test_that("Run examples for paired samples", { paired = TRUE, eqb = .5) - test1_ses = boot_ses_calc(x = samp1, - y = samp2, - paired = TRUE) - test3 = wilcox_TOST(x = samp1, y = samp2, paired = TRUE, @@ -228,6 +276,21 @@ test_that("Run examples for paired samples", { }) +test_that("Bootstrap tests for paired samples", { + skip_on_cran() + + set.seed(789461245) + + samp1 = rnorm(25) + samp2 = rnorm(25) + + test1_ses = boot_ses_calc(x = samp1, + y = samp2, + paired = TRUE) + expect_s3_class(test1_ses, "htest") + +}) + test_that("Check rbs",{ set.seed(1847501) diff --git a/vignettes/IntroTOSTt.Rmd b/vignettes/IntroTOSTt.Rmd index 7a526f2..c28fb89 100644 --- a/vignettes/IntroTOSTt.Rmd +++ b/vignettes/IntroTOSTt.Rmd @@ -3,6 +3,7 @@ title: "An Introduction to t_TOST" subtitle: "A new function for TOST with t-tests" author: "Aaron R. Caldwell" date: "`r Sys.Date()`" +link-citations: true output: rmarkdown::html_vignette: toc: TRUE diff --git a/vignettes/IntroTOSTt.html b/vignettes/IntroTOSTt.html index a3694a0..1944426 100644 --- a/vignettes/IntroTOSTt.html +++ b/vignettes/IntroTOSTt.html @@ -12,7 +12,7 @@ - + An Introduction to t_TOST @@ -365,7 +365,7 @@

An Introduction to t_TOST

A new function for TOST with t-tests

Aaron R. Caldwell

-

2026-01-23

+

2026-02-19

@@ -465,7 +465,7 @@

Beyond Equivalence: Minimal Effects Testing

is equivalence. This reverses the typical TOST paradigm and can be valuable in contexts where you want to demonstrate that an effect exceeds some minimal threshold.

-

+

The plots above illustrate the conceptual difference between Minimal Effect Tests (left) and Equivalence Tests (right). Notice how the null (H0) and alternative (H1) hypotheses are reversed between these @@ -570,8 +570,10 @@

Viewing Results

#> 90 percent confidence interval: #> -3.0533815 -0.1066185 #> sample estimates: -#> mean of x mean of y -#> 0.75 2.33
+#> mean of group '1' mean of group '2' +#> 0.75 2.33 +#> mean difference ('1' - '2') +#> -1.58

Notice how t_TOST provides detailed information including both raw and standardized effect sizes, whereas simple_htest gives a more concise summary in the familiar @@ -586,7 +588,7 @@

1. Simple Dot-and-Whisker Plot

This is the default plot type, showing the point estimate and confidence intervals relative to the equivalence bounds:

plot(res1, type = "simple", layout = "combined")
-

+

This plot clearly shows where our observed difference (with confidence intervals) falls in relation to our equivalence bounds (dashed vertical lines).

@@ -598,7 +600,7 @@

2. Consonance Density Plot

# Shade the 90% and 95% CI areas
 plot(res1, type = "cd",
      ci_shades = c(.9, .95))
-

+

The darker shaded region represents the 90% confidence interval, while the lighter region represents the 95% confidence interval. This visualization helps illustrate the precision of our estimate.

@@ -608,7 +610,7 @@

3. Consonance Plot

This plot shows multiple confidence intervals simultaneously:

plot(res1, type = "c",
      ci_lines = c(.9, .95))
-

+

Here, we can see both the 90% and 95% confidence intervals represented as different lines.

@@ -617,7 +619,7 @@

4. Null Distribution Plot

This plot visualizes the null distribution:

plot(res1, type = "tnull")
 #> SMD cannot be plotted if type = "tnull"
-

+

This visualization is particularly useful for understanding the theoretical distribution under the null hypothesis.

@@ -642,10 +644,11 @@

Describing Results in Plain Language

The Welch Two Sample t-test is not statistically significant -(t(17.776) = -1.27, p = 0.89, mean of x = 0.75, mean of y = 2.33, 90% -C.I.[-3.05, -0.107]) at a 0.05 alpha-level. The null hypothesis cannot -be rejected. At the desired error rate, it cannot be stated that the -true difference in means is between -0.5 and 0.5.

+(t(17.776) = -1.27, p = 0.89, mean of group ‘1’ = 0.75, mean of group +‘2’ = 2.33, mean difference (‘1’ - ‘2’) = -1.58, 90% C.I.[-3.05, +-0.107]) at a 0.05 alpha-level. The null hypothesis cannot be rejected. +At the desired error rate, it cannot be stated that the true difference +in means is between -0.5 and 0.5.

These descriptions provide accessible interpretations of the statistical results, making it easier to understand and communicate @@ -706,8 +709,8 @@

Using the Sleep Data with Paired Analysis

#> 90 percent confidence interval: #> -2.2930053 -0.8669947 #> sample estimates: -#> mean difference -#> -1.58 +#> mean of the differences (z = x - y) +#> -1.58

Setting paired = TRUE changes the analysis to account for within-subject correlations. Note that for paired tests, we use separate vectors (x and y) rather than the formula notation, as formula @@ -762,8 +765,8 @@

Using Separate Vectors for Paired Data

#> 90 percent confidence interval: #> 2.653551 2.918449 #> sample estimates: -#> mean difference -#> 2.786 +#> mean of the differences (z = x - y) +#> 2.786

Here we’re testing whether the difference between Sepal.Length and Sepal.Width is equivalent within ±1 unit.

@@ -817,8 +820,8 @@

Minimal Effect Testing (MET)

#> 90 percent confidence interval: #> 2.653551 2.918449 #> sample estimates: -#> mean difference -#> 2.786 +#> mean of the differences (z = x - y) +#> 2.786

For simple_htest, we use alternative = "minimal.effect" to specify MET. The smd_ci = "t" in t_TOST specifies using the @@ -841,10 +844,10 @@

Interpreting MET Results

The Paired t-test is statistically significant (t(149) = 22.319, p -< 0.001, mean difference = 2.786, 90% C.I.[2.654, 2.918]) at a 0.05 -alpha-level. The null hypothesis can be rejected. At the desired error -rate, it can be stated that the true mean difference is less than -1 or -greater than 1.

+< 0.001, mean of the differences (z = x - y) = 2.786, 90% C.I.[2.654, +2.918]) at a 0.05 alpha-level. The null hypothesis can be rejected. At +the desired error rate, it can be stated that the true mean difference +is less than -1 or greater than 1.

@@ -973,7 +976,7 @@

Working with Summary Statistics Only

The same visualization and description methods work with tsum_TOST:

plot(res_tsum)
-

+

describe(res_tsum)
 #> [1] "Using the One-sample t-test, a null hypothesis significance test (NHST), and a equivalence test, via two one-sided tests (TOST), were performed with an alpha-level of 0.05. These tested the null hypotheses that true mean is equal to 0 (NHST), and true mean is more extreme than 5.5 and 8.5 (TOST). The equivalence test was significant, t(149) = 5.078, p < 0.001 (mean = 5.843 90% C.I.[5.731, 5.955]; Hedges's g = 7.021 90% C.I.[6.327, 7.691]). At the desired error rate, it can be stated that the true mean is between 5.5 and 8.5."
@@ -986,7 +989,7 @@

Power Analysis for TOST

functions and matches results from commercial software like PASS. The calculations are based on Owen’s Q-function or direct integration of the bivariate non-central t-distribution1. Approximate power is implemented via the -non-central t-distribution or the ‘shifted’ central t-distribution Diletti, Hauschke, and Steinijans (1992).

+non-central t-distribution or the ‘shifted’ central t-distribution Diletti, Hauschke, and Steinijans (1992).

The interface mimics base R’s power.t.test function. You specify equivalence bounds and leave one parameter blank (alpha, power, or n) to solve for @@ -1055,8 +1058,9 @@

References

  1. Inspired by Labes, Schütz, and -Lang (2021) in the PowerTOST R package. Please see -this package for more options↩︎

    2. +Lang (2021) in the +PowerTOST R package. Please see this package for more +options↩︎

diff --git a/vignettes/IntroductionToTOSTER.R b/vignettes/IntroductionToTOSTER.R index 68c0dd7..6a527de 100644 --- a/vignettes/IntroductionToTOSTER.R +++ b/vignettes/IntroductionToTOSTER.R @@ -1,8 +1,8 @@ -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- library("TOSTER") TOSTmeta(ES = 0.06, se = 0.003, low_eqbound_d=-0.1, high_eqbound_d=0.1, alpha=0.05) -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- # OLD CODE #TOSTtwo(m1=5.25,m2=5.22,sd1=0.95,sd2=0.83,n1=95,n2=89,low_eqbound_d=-0.48, high_eqbound=0.48, alpha = 0.05, var.equal=TRUE) TOSTtwo.raw(m1=5.25,m2=5.22,sd1=0.95,sd2=0.83,n1=95,n2=89,low_eqbound=-0.429, high_eqbound=0.429, alpha = 0.05, var.equal=TRUE) @@ -10,7 +10,7 @@ TOSTtwo.raw(m1=5.25,m2=5.22,sd1=0.95,sd2=0.83,n1=95,n2=89,low_eqbound=-0.429, hi # NEW CODE tsum_TOST(m1=5.25,m2=5.22,sd1=0.95,sd2=0.83,n1=95,n2=89,eqb=0.429, alpha = 0.05, var.equal=TRUE) -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- # OLD CODE TOSTtwo(m1=100.64,m2=100.48,sd1=14.1,sd2=14.9,n1=39343,n2=40033,low_eqbound_d=-0.05, high_eqbound_d=0.05, alpha = 0.05, var.equal=FALSE) @@ -27,14 +27,14 @@ powerTOSTone(alpha=0.05, statistical_power=0.8, low_eqbound_d=-0.68, high_eqboun power_t_TOST(type = "one.sample",eqb = 0.68, power = 0.8,alpha=.05) -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- # OLD CODE TOSTone(m=5.71,mu=6,sd=1.79,n=20,low_eqbound_d=-0.68, high_eqbound_d=0.68, alpha=0.05) # NEW CODE tsum_TOST(m1=5.71-6,sd1=1.79,n1=20,eqb=0.68, eqbound_type = "SMD") -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- # OLD powerTOSTr(alpha=0.05, statistical_power=0.8, low_eqbound_r=-0.24, high_eqbound_r=0.24) @@ -46,7 +46,7 @@ power_z_cor(alpha=0.05, null=0.24, alternative = "equ") -## ---- fig.width=6------------------------------------------------------------- +## ----fig.width=6-------------------------------------------------------------- # OLD CODE TOSTr(n=71, r=-0.12, low_eqbound_r=-0.24, high_eqbound_r=0.24, alpha=0.05) diff --git a/vignettes/IntroductionToTOSTER.Rmd b/vignettes/IntroductionToTOSTER.Rmd index d437592..9c2163e 100644 --- a/vignettes/IntroductionToTOSTER.Rmd +++ b/vignettes/IntroductionToTOSTER.Rmd @@ -2,6 +2,7 @@ title: "Introduction to Equivalence Testing with TOSTER" author: "Daniel Lakens; Updated by Aaron Caldwell" date: "`r Sys.Date()`" +link-citations: true output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Introduction to Equivalence Testing with TOSTER} diff --git a/vignettes/IntroductionToTOSTER.html b/vignettes/IntroductionToTOSTER.html index 12980b0..6fdb7cc 100644 --- a/vignettes/IntroductionToTOSTER.html +++ b/vignettes/IntroductionToTOSTER.html @@ -12,7 +12,7 @@ - + Introduction to Equivalence Testing with TOSTER @@ -50,6 +50,7 @@ } + + + + + + + + + + + + + + + + + + + + + + +

Hypothesis Testing with TOSTER

+ + + +
+

Introduction

+

TOSTER was originally conceived as an equivalence testing package, +but it is really a general-purpose hypothesis testing toolkit. +Equivalence testing via the two one-sided tests (TOST) procedure is one +of its core features, but the package also supports standard null +hypothesis significance tests, non-inferiority testing, and +superiority-by-a-margin testing through a single, consistent +interface.

+

Many of TOSTER’s test functions return objects of class +htest, the same structure used by base R functions like +t.test(), wilcox.test(), and +cor.test(). This means results from TOSTER plug directly +into existing R workflows. On top of this, TOSTER provides helper +functions for tabulating, describing, and plotting test results that +work with most htest objects.

+

The central idea is simple: hypothesis testing involves specifying a +null hypothesis, choosing an alternative, and evaluating by a test. By +adjusting the alternative and mu (or +null depending on the function) arguments in TOSTER’s +functions, you can move seamlessly between testing frameworks. A +standard nil-hypothesis test, an equivalence test, a non-inferiority +analysis, and a superiority-by-a-margin test are all handled by the same +interface.

+
library(TOSTER)
+

Throughout this vignette we use the built-in sleep +dataset, which contains extra hours of sleep (extra) for 10 +subjects under two drug conditions (group).

+
+
+

The simple_htest Interface

+

simple_htest() is a unified wrapper for common two-group +(and one-sample) hypothesis tests. It calls base R’s +t.test() or wilcox.test() under the hood but +improves the output in two ways:

+
    +
  1. Sample sizes are reported are saved in the output +(base R does not record n).
    2. +
  2. The effect is shown explicitly as a difference +(e.g., “mean difference (1 - 2)”) rather than listing two group means +and leaving the reader to compute the difference.
    3. +
+
+

Basic usage: two-sample t-test

+

A standard two-sided t-test with simple_htest looks just +like t.test() but with a formula interface and explicit +mu argument:

+
test1 = simple_htest(extra ~ group,
+             data = sleep,
+             mu = 0,
+             alternative = "two.sided")
+
+test1$sample_size
+#>  1  2 
+#> 10 10
+

Compare this with base R’s t.test():

+
t.test(extra ~ group, data = sleep)
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = -1.8608, df = 17.776, p-value = 0.07939
+#> alternative hypothesis: true difference in means between group 1 and group 2 is not equal to 0
+#> 95 percent confidence interval:
+#>  -3.3654832  0.2054832
+#> sample estimates:
+#> mean in group 1 mean in group 2 
+#>            0.75            2.33
+

Notice that simple_htest saves the sample sizes in each +group and appends the mean difference to the output, saving the reader a +calculation step. Additionally, notice how group labels are applied so +you don’t have to guess which group mean was sbutracted from which +(i.e., mean difference ('1' - '2')).

+
+
+

Wilcoxon test

+

To run a nonparametric Wilcoxon rank-sum test instead of a t-test, +set the test argument:

+
simple_htest(extra ~ group,
+             data = sleep,
+             test = "wilcox.test",
+             mu = 0,
+             alternative = "two.sided")
+#> Warning in wilcox.test.default(x = x, y = y, paired = paired, conf.int = TRUE,
+#> : cannot compute exact p-value with ties
+#> Warning in wilcox.test.default(x = x, y = y, paired = paired, conf.int = TRUE,
+#> : cannot compute exact confidence intervals with ties
+#> 
+#>  Wilcoxon rank sum test with continuity correction
+#> 
+#> data:  extra by group
+#> W = 25.5, p-value = 0.06933
+#> alternative hypothesis: true location shift is not equal to 0
+#> 95 percent confidence interval:
+#>  -3.59994709  0.09995356
+#> sample estimates:
+#> Hodges-Lehmann estimate ('1' - '2') 
+#>                           -1.346388
+

The output includes the Hodges-Lehmann estimate of the location +shift. Please note that this estimate is not a the mean or median +difference, but rather the median of all pairwise differences between +groups (for the two-sample case) or Walsh averages (one-sample/paired). +This is a robust measure of central tendency that is less sensitive to +outliers than the mean difference.

+
+
+

Equivalence testing (TOST)

+

To test whether the difference between groups falls within a +set of equivalence bounds, set alternative = "equivalence" +and specify the bounds via mu. The TOST procedure tests the +null hypothesis that the true effect lies outside the bounds using two +one-sided tests.

+
simple_htest(extra ~ group,
+             data = sleep,
+             mu = 2,
+             alternative = "equivalence")
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = 0.49465, df = 17.776, p-value = 0.3135
+#> alternative hypothesis: equivalence
+#> null values:
+#> difference in means difference in means 
+#>                  -2                   2 
+#> 90 percent confidence interval:
+#>  -3.0533815 -0.1066185
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+

Here, mu = 2 defines symmetric equivalence bounds of +(-2, 2). The confidence interval is reported at the 1 - 2α level (90% by +default), which is the appropriate interval for TOST. If the 90% CI +falls entirely within the bounds, the test is significant and we can +conclude equivalence.

+

You can also specify asymmetric bounds by passing a two-element +vector:

+
simple_htest(extra ~ group,
+             data = sleep,
+             mu = c(-1, 3),
+             alternative = "equivalence")
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = -0.68308, df = 17.776, p-value = 0.7483
+#> alternative hypothesis: equivalence
+#> null values:
+#> difference in means difference in means 
+#>                  -1                   3 
+#> 90 percent confidence interval:
+#>  -3.0533815 -0.1066185
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+
+
+
+

Beyond Equivalence: Non-Inferiority and Superiority by a Margin

+

TOSTER handles the full family of margin-based hypothesis tests, not +just equivalence.

+

Non-inferiority testing asks: “Is the effect not +worse than some threshold?” This is operationalized as a one-sided test +against a shifted null. For instance, if we want to show that the mean +difference between drug groups is not less than -1 (i.e., group 1 is not +meaningfully worse than group 2 by more than 1 hour), we test with +mu = -1 and alternative = "greater":

+
simple_htest(extra ~ group,
+             data = sleep,
+             mu = -1,
+             alternative = "greater")
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = -0.68308, df = 17.776, p-value = 0.7483
+#> alternative hypothesis: true difference in means is greater than -1
+#> 95 percent confidence interval:
+#>  -3.053381       Inf
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+

If the p-value is below α, we can conclude non-inferiority: the true +difference is greater than -1.

+

Superiority by a margin asks: “Does the effect +exceed a positive threshold?” For example, to test whether the +difference exceeds +1 hour:

+
simple_htest(extra ~ group,
+             data = sleep,
+             mu = 1,
+             alternative = "greater")
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = -3.0385, df = 17.776, p-value = 0.9964
+#> alternative hypothesis: true difference in means is greater than 1
+#> 95 percent confidence interval:
+#>  -3.053381       Inf
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+

These are one-sided tests against a non-zero null, not equivalence +tests. TOSTER handles them through the same simple_htest +interface by adjusting mu and alternative.

+
+
+

Other Test Functions

+

TOSTER provides several additional functions that return +htest objects. Each supports the same +alternative options (“two.sided”, “less”, “greater”, +“equivalence”, “minimal.effect”), making them interchangeable with the +helper functions described later. Here are just a few key functions in +the package:

+
+

Brunner-Munzel test

+

The Brunner-Munzel test is a robust nonparametric test for stochastic +superiority. Unlike the Wilcoxon test, it does not assume equal +variances or equal shape of distributions. The null hypothesis is that +the relative effect (probability that a random observation from one +group exceeds one from the other) equals 0.5:

+
brunner_munzel(extra ~ group, data = sleep)
+#> Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
+#> 
+#>  Two-sample Brunner-Munzel test
+#> 
+#> data:  extra by group
+#> t = -2.1447, df = 16.898, p-value = 0.04682
+#> alternative hypothesis: true relative effect is not equal to 0.5
+#> 95 percent confidence interval:
+#>  0.01387048 0.49612952
+#> sample estimates:
+#> P('1'>'2') + .5*P('1'='2') 
+#>                      0.255
+
+
+

Bootstrap Correlation test

+

boot_cor_test() tests correlations using the bootstrap +methods similar to those mentioned by @wilcox2011introduction and supports equivalence +bounds on the correlation coefficient:

+
boot_cor_test(mtcars$mpg, mtcars$hp,
+           method = "pearson",
+           alternative = "two.sided",
+           null = 0)
+#> 
+#>  Bootstrapped Pearson's product-moment correlation (BCa)
+#> 
+#> data:  mtcars$mpg and mtcars$hp
+#> N = 32, p-value = 0.01772
+#> alternative hypothesis: true correlation is not equal to 0
+#> 95 percent confidence interval:
+#>  -0.8429290 -0.6329336
+#> sample estimates:
+#>          r 
+#> -0.7761684
+
+
+

Bootstrap t-test

+

boot_t_test() provides a bootstrap alternative to the +standard t-test, which is useful when distributional assumptions are +questionable:

+
set.seed(2101)
+boot_t_test(extra ~ group,
+            data = sleep,
+            mu = 0,
+            alternative = "two.sided",
+            R = 999)
+#> 
+#>  Bootstrapped Welch Two Sample t-test (studentized)
+#> 
+#> data:  extra by group
+#> t-observed = -1.8608, df = 17.776, p-value = 0.07207
+#> alternative hypothesis: true difference in means is not equal to 0
+#> 95 percent confidence interval:
+#>  -3.3481655  0.1582626
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+
+
+

Permutation t-test

+

perm_t_test() provides a permutation-based test that +makes minimal distributional assumptions:

+
set.seed(8251)
+perm_t_test(extra ~ group,
+            data = sleep,
+            mu = 0,
+            alternative = "two.sided",
+            R = 999)
+#> Note: Number of permutations (R = 999) is less than 1000. Consider increasing R for more stable p-value estimates.
+#> 
+#>  Randomization Permutation Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t-observed = -1.8608, df = 17.776, p-value = 0.096
+#> alternative hypothesis: true difference in means is not equal to 0
+#> 95 percent confidence interval:
+#>  -3.4  0.2
+#> sample estimates:
+#>           mean of group '1'           mean of group '2' 
+#>                        0.75                        2.33 
+#> mean difference ('1' - '2') 
+#>                       -1.58
+

All of these functions return objects of class htest, so +the helper functions described next work identically with any of +them.

+
+
+
+

Converting t_TOST Results

+

Users of TOSTER’s original t_TOST() and +wilcox_TOST() functions can convert their results to +htest format using as_htest(). This allows the +full suite of helper functions to be used with older-style TOST +output.

+
tost_res <- t_TOST(extra ~ group,
+                   data = sleep,
+                   eqb = 2)
+as_htest(tost_res)
+#> 
+#>  Welch Two Sample t-test
+#> 
+#> data:  extra by group
+#> t = 0.49465, df = 17.776, p-value = 0.3135
+#> alternative hypothesis: equivalence
+#> null values:
+#> mean difference mean difference 
+#>              -2               2 
+#> 90 percent confidence interval:
+#>  -3.0533815 -0.1066185
+#> sample estimates:
+#> mean difference 
+#>           -1.58
+

The resulting htest object contains the test statistic, +p-value, confidence interval, and equivalence bounds from the original +TOST analysis. Note, the htest output will only show the +equivalence test, not the two one-sided tests separately or the +nil-hypothesis significance test, but the key information is preserved +for reporting.

+
+
+

Helper Functions for Reporting

+

TOSTER includes three helper functions that work with any +htest object: df_htest() for tabulation, +describe_htest() for text descriptions, and +plot_htest_est() for visualization.

+
+

df_htest(): Tabulating results

+

df_htest() converts an htest object into a +data frame, making it easy to build summary tables:

+
res_t <- simple_htest(extra ~ group, data = sleep, mu = 0)
+df_htest(res_t)
+#>                    method         t       df    p.value mean difference
+#> 1 Welch Two Sample t-test -1.860813 17.77647 0.07939414           -1.58
+#>         SE  lower.ci  upper.ci conf.level alternative null
+#> 1 0.849091 -3.365483 0.2054832       0.95   two.sided    0
+

The test_statistics, show_ci, and +extract_names arguments control which columns appear in the +output.

+
+
+

describe_htest(): Text descriptions

+

describe_htest() generates a formatted text summary +suitable for reporting:

+
describe_htest(res_t)
+#> [1] "The Welch Two Sample t-test is not statistically significant (t(17.776) = -1.86, p = 0.079, mean of group '1' = 0.75, mean of group '2' = 2.33, mean difference ('1' - '2') = -1.58, 95% C.I.[-3.37, 0.205]) at a 0.05 alpha-level. The null hypothesis cannot be rejected. At the desired error rate, it cannot be stated that the true difference in means is not equal to 0."
+

For an equivalence test, the description adapts to reflect the TOST +procedure:

+
res_equiv <- simple_htest(extra ~ group, data = sleep, 
+                           mu = 2, alternative = "equivalence")
+describe_htest(res_equiv)
+#> [1] "The Welch Two Sample t-test is not statistically significant (t(17.776) = 0.495, p = 0.313, mean of group '1' = 0.75, mean of group '2' = 2.33, mean difference ('1' - '2') = -1.58, 90% C.I.[-3.05, -0.107]) at a 0.05 alpha-level. The null hypothesis cannot be rejected. At the desired error rate, it cannot be stated that the true difference in means is between -2 and 2."
+

This is useful for inline reporting in R Markdown. For example, you +could write `r describe_htest(res_t)` to embed the result +directly in a sentence.

+
+
+

plot_htest_est(): Estimate plots

+

plot_htest_est() produces a point-range plot showing the +point estimate and confidence interval alongside the null value(s):

+
plot_htest_est(res_t)
+

+

For equivalence tests, the plot displays both equivalence bounds as +dashed reference lines:

+
plot_htest_est(res_equiv)
+

+

Set describe = FALSE for a cleaner plot without the +statistical summary in the subtitle:

+
plot_htest_est(res_equiv, describe = FALSE)
+

+

Because the result is a ggplot2 object, you can +customize it further with standard ggplot2 functions.

+
+
+
+

Putting It All Together

+

Here is a compact workflow tying together the full set of tools. We +run an equivalence test, tabulate the result, describe it in text, and +visualize it:

+
# Run equivalence test
+result <- simple_htest(extra ~ group,
+                       data = sleep,
+                       mu = 2,
+                       alternative = "equivalence")
+
+# Tabulate
+df_htest(result)
+#>                    method         t       df   p.value mean difference       SE
+#> 1 Welch Two Sample t-test 0.4946466 17.77647 0.3134536           -1.58 0.849091
+#>    lower.ci   upper.ci conf.level alternative null1 null2
+#> 1 -3.053381 -0.1066185        0.9 equivalence    -2     2
+
+# Describe
+describe_htest(result)
+#> [1] "The Welch Two Sample t-test is not statistically significant (t(17.776) = 0.495, p = 0.313, mean of group '1' = 0.75, mean of group '2' = 2.33, mean difference ('1' - '2') = -1.58, 90% C.I.[-3.05, -0.107]) at a 0.05 alpha-level. The null hypothesis cannot be rejected. At the desired error rate, it cannot be stated that the true difference in means is between -2 and 2."
+
+# Visualize
+plot_htest_est(result)
+

+

TOSTER provides a consistent, informative interface for hypothesis +testing that goes well beyond equivalence. Whether you need a standard +t-test with better output, a non-inferiority analysis, or a full TOST +procedure, the same tools apply.

+
+ + + + + + + + + + + diff --git a/vignettes/references.bib b/vignettes/references.bib index 0a70afc..8ae8637 100644 --- a/vignettes/references.bib +++ b/vignettes/references.bib @@ -292,6 +292,48 @@ @article{neubert2007 journal = {Computational Statistics and Data Analysis} } + @article{Algina_Keselman_Penfield_2005, title={An Alternative to Cohen’s Standardized Mean Difference Effect Size: A Robust Parameter and Confidence Interval in the Two Independent Groups Case.}, volume={10}, url={http://dx.doi.org/10.1037/1082-989X.10.3.317}, DOI={10.1037/1082-989x.10.3.317}, number={3}, journal={Psychological Methods}, publisher={American Psychological Association (APA)}, author={Algina, James and Keselman, H. J. and Penfield, Randall D.}, year={2005}, month=sept, pages={317–328}, language={en} } + + +@ARTICLE{fried2011, + title = "Robust nonparametric tests for the two-sample location problem", + author = "Fried, Roland and Dehling, Herold", + journal = "Stat. Methods Appt.", + publisher = "Springer Science and Business Media LLC", + volume = 20, + number = 4, + pages = "409--422", + month = nov, + year = 2011, + language = "en" +} + + +@ARTICLE{munzel2003, + title = "A nonparametric test for proving noninferiority in clinical + trials with ordered categorical data", + author = "Munzel, Ullrich and Hauschke, Dieter", + abstract = "AbstractWe consider the problem of proving noninferiority when + the comparison is based on ordered categorical data. We apply a + rank test based on the Wilcoxon--Mann--Whitney effect where the + asymptotic variance is estimated consistently under the + alternative and a small‐sample approximation is given. We give + the associated 100(1−$\alpha$)\% confidence interval and propose + a formula for sample size determination. Finally, we illustrate + the procedure and possible choices of the noninferiority margin + using data from a clinical trial. Copyright \copyright{} 2003 + John Wiley \& Sons, Ltd.", + journal = "Pharm. Stat.", + publisher = "Wiley", + volume = 2, + number = 1, + pages = "31--37", + month = jan, + year = 2003, + copyright = "http://onlinelibrary.wiley.com/termsAndConditions\#vor", + language = "en" +} + @article{bonett2008, title={Confidence intervals for standardized linear contrasts of means.}, author={Bonett, Douglas G}, @@ -334,6 +376,18 @@ @article{viechtbauer2007approximate year={2007} } +@article{Senn_2011, title={U is for Unease: Reasons for Mistrusting Overlap Measures for Reporting Clinical Trials}, +volume={3}, url={http://dx.doi.org/10.1198/sbr.2010.10024}, DOI={10.1198/sbr.2010.10024}, +number={2}, journal={Statistics in Biopharmaceutical Research}, +publisher={Informa UK Limited}, author={Senn, Stephen}, year={2011}, month=may, pages={302-309}, language={en} } + +@article{Baguley_2009, title={Standardized or simple effect size: What should be reported?}, +volume={100}, url={http://dx.doi.org/10.1348/000712608X377117}, +DOI={10.1348/000712608x377117}, +abstractNote={It is regarded as best practice for psychologists to report effect size when disseminating quantitative research findings. Reporting of effect size in the psychological literature is patchy – though this may be changing – and when reported it is far from clear that appropriate effect size statistics are employed. This paper considers the practice of reporting point estimates of standardized effect size and explores factors such as reliability, range restriction and differences in design that distort standardized effect size unless suitable corrections are employed. For most purposes simple (unstandardized) effect size is more robust and versatile than standardized effect size. Guidelines for deciding what effect size metric to use and how to report it are outlined. Foremost among these are: (i) a preference for simple effect size over standardized effect size, and (ii) the use of confidence intervals to indicate a plausible range of values the effect might take. Deciding on the appropriate effect size statistic to report always requires careful thought and should be influenced by the goals of the researcher, the context of the research and the potential needs of readers.}, number={3}, journal={British Journal of Psychology}, +publisher={Wiley}, author={Baguley, Thom}, +year={2009}, month=aug, pages={603-617}, language={en} } + @article{janssen1997, title={Studentized permutation tests for non-i.i.d. hypotheses and the generalized Behrens-Fisher problem}, volume={36}, url={http://dx.doi.org/10.1016/s0167-7152(97)00043-6}, DOI={10.1016/s0167-7152(97)00043-6}, number={1}, journal={Statistics and Probability Letters}, @@ -345,3 +399,54 @@ @article{chung2013 journal={The Annals of Statistics}, publisher={Institute of Mathematical Statistics}, author={Chung, EunYi and Romano, Joseph P.}, year={2013}, month=apr } +@article{divine2018, + title={The Wilcoxon--Mann--Whitney Procedure Fails as a Test of Medians}, + author={Divine, George W and Norton, H James and Bar{\'o}n, Anna E and Juarez-Colunga, Elizabeth}, + journal={The American Statistician}, + volume={72}, + number={3}, + pages={278--286}, + year={2018}, + publisher={Taylor \& Francis}, + doi={10.1080/00031305.2017.1305291}, + url={https://doi.org/10.1080/00031305.2017.1305291} +} + +@article{hodges1963, + title={Estimates of Location Based on Rank Tests}, + author={Hodges, Joseph L and Lehmann, Erich L}, + journal={The Annals of Mathematical Statistics}, + volume={34}, + number={2}, + pages={598--611}, + year={1963}, + publisher={Institute of Mathematical Statistics}, + doi={10.1214/aoms/1177704172}, + url={https://doi.org/10.1214/aoms/1177704172} +} + +@article{phipson2010, + title={Permutation P-values Should Never Be Zero: Calculating Exact P-values When Permutations Are Randomly Drawn}, + author={Phipson, Belinda and Smyth, Gordon K}, + journal={Statistical Applications in Genetics and Molecular Biology}, + volume={9}, + number={1}, + year={2010}, + publisher={De Gruyter}, + doi={10.2202/1544-6115.1585}, + url={https://doi.org/10.2202/1544-6115.1585} +} + +@article{arboretti2021, + title={Nonparametric Combination Tests for Comparing Two Treatments with Respect to a Non-Inferiority Margin Expressed as a Ratio}, + author={Arboretti, Rosa and Bonnini, Stefano and Corain, Livio and Salmaso, Luigi}, + journal={Statistics in Medicine}, + volume={40}, + number={18}, + pages={4078--4093}, + year={2021}, + publisher={Wiley}, + doi={10.1002/sim.9015}, + url={https://doi.org/10.1002/sim.9015} +} + diff --git a/vignettes/robustTOST.R b/vignettes/robustTOST.R index 5e80192..0076f90 100644 --- a/vignettes/robustTOST.R +++ b/vignettes/robustTOST.R @@ -17,19 +17,22 @@ wilcox_TOST(formula = extra ~ group, eqb = .5) # Odds - wilcox_TOST(formula = extra ~ group, data = sleep, ses = "o", eqb = .5) # Concordance - wilcox_TOST(formula = extra ~ group, data = sleep, ses = "c", eqb = .5) +## ----------------------------------------------------------------------------- +simple_htest(formula = extra ~ group, + data = sleep, + test = "w", alternative = "e", + mu = .5) ## ----------------------------------------------------------------------------- # Default studentized test (t-approximation) @@ -100,6 +103,42 @@ brunner_munzel(formula = extra ~ group, ## ----------------------------------------------------------------------------- data('sleep') +# Asymptotic Hodges-Lehmann test +hodges_lehmann(formula = extra ~ group, + data = sleep) + +## ----------------------------------------------------------------------------- +# Permutation test +hodges_lehmann(formula = extra ~ group, + data = sleep, + R = 1999) + +## ----------------------------------------------------------------------------- +# Equivalence test: is the location shift within ±2 units? +# Equivalence/minimal.effect alternatives use the asymptotic method only +hodges_lehmann(formula = extra ~ group, + data = sleep, + alternative = "equivalence", + mu = 2) + +## ----------------------------------------------------------------------------- +# Paired Hodges-Lehmann test +hodges_lehmann(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], + paired = TRUE, + R = 1999) + +## ----------------------------------------------------------------------------- +# Minimal effect test: is the location shift outside ±0.5? +# Minimal effect alternative uses the asymptotic method only +hodges_lehmann(formula = extra ~ group, + data = sleep, + alternative = "minimal.effect", + mu = 0.5) + +## ----------------------------------------------------------------------------- +data('sleep') + # Two-sample permutation t-test perm_result <- perm_t_test(extra ~ group, data = sleep, @@ -187,18 +226,33 @@ boot_log_TOST( ) ## ----------------------------------------------------------------------------- -# For paired tests, use separate vectors +# Rank-biserial correlation for paired data ses_calc(x = sleep$extra[sleep$group == 1], y = sleep$extra[sleep$group == 2], paired = TRUE, - ses = "r") + ses = "rb") -# Setting bootstrap replications low to -## reduce compiling time of vignette -boot_ses_calc(x = sleep$extra[sleep$group == 1], - y = sleep$extra[sleep$group == 2], +## ----------------------------------------------------------------------------- +# Two-sided test: does the rank-biserial differ from 0? +ses_calc(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], + paired = TRUE, + ses = "rb", + alternative = "two.sided") + +## ----------------------------------------------------------------------------- +# Equivalence test: is the rank-biserial within [-0.3, 0.3]? +ses_calc(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], paired = TRUE, - R = 199, - boot_ci = "perc", # recommend percentile bootstrap for paired SES - ses = "r") + ses = "rb", + alternative = "equivalence", + null.value = c(-0.3, 0.3)) + +## ----------------------------------------------------------------------------- +# Using the Agresti method (default) with WMW odds +ses_calc(formula = extra ~ group, + data = sleep, + ses = "odds", + alternative = "two.sided") diff --git a/vignettes/robustTOST.Rmd b/vignettes/robustTOST.Rmd index 916e6c4..2cc6f50 100644 --- a/vignettes/robustTOST.Rmd +++ b/vignettes/robustTOST.Rmd @@ -2,6 +2,7 @@ title: "Robust TOST Procedures" author: "Aaron R. Caldwell" date: "`r Sys.Date()`" +link-citations: true output: rmarkdown::html_vignette: toc: True @@ -20,6 +21,12 @@ The Two One-Sided Tests (TOST) procedure is a statistical approach used to test While the standard `t_TOST` function in TOSTER provides a parametric approach to equivalence testing, it relies on assumptions of normality and homogeneity of variance. In real-world data analysis, these assumptions are often violated, necessitating more robust alternatives. This vignette introduces several robust TOST methods available in the TOSTER package that maintain their validity under a wider range of data conditions. +## Choosing by Estimand + +Before selecting a robust method, it is worth clarifying what quantity your equivalence bounds are intended to constrain. Different methods target different estimands, and the bounds only have their intended meaning when matched to the right one. If your bounds refer to mean differences, a permutation t-test or bootstrap approach is appropriate. If they refer to trimmed mean differences due to concerns about heavy tails (outliers), Yuen's trimmed bootstrap or permutation test are natural choices. If you are interested in stochastic dominance (P(X > Y)), the Brunner-Munzel test provides a transparent framework. The Wilcoxon-Mann-Whitney and Hodges-Lehmann procedures target the pseudo-median of pairwise differences, which coincides with mean and median differences only under a location shift assumption. When that assumption is violated, bounds set on the pseudo-median may not correspond to the magnitude of difference in means or medians that you intended to declare equivalent. + +*TL;DR* choose your test carefully and this should be informed by the estimand of interest. + ## When to Use Robust TOST Methods Consider using the robust alternatives to `t_TOST` when: @@ -36,33 +43,62 @@ The following table provides a quick overview of the robust methods covered in t |--------|----------|---------------------|---------------| | Wilcoxon TOST | `wilcox_TOST()` | Rank-based, nonparametric | Ordinal data; see caveats below | | Brunner-Munzel | `brunner_munzel()` | Probability-based, robust to heteroscedasticity | Stochastic superiority is the effect of interest | +| Hodges-Lehmann | `hodges_lehmann()` | Robust location estimator, permutation or asymptotic | Robust location shift testing, outlier resistance | | Permutation t-test | `perm_t_test()` | Resampling without replacement, exact p-values possible | Small samples, mean differences, exact inference | | Bootstrap TOST | `boot_t_TOST()` | Resampling with replacement, flexible | Moderate samples, mean differences, visualization | | Log-Transformed TOST | `log_TOST()` | Ratio-based, for multiplicative comparisons | Comparing relative differences (e.g., bioequivalence) | +| SES estimation/testing | `ses_calc()` / `boot_ses_calc()` | Non-parametric effect sizes with optional hypothesis testing | Testing on the effect size scale directly | # Wilcoxon-Mann-Whitney TOST -The Wilcoxon group of tests (includes Mann-Whitney U-test) provide a non-parametric test of differences between groups, or within samples, based on ranks. This provides a test of location shift, which is a fancy way of saying differences in the center of the distribution (i.e., in parametric tests the location is mean). With TOST, there are two separate tests of directional location shift to determine if the location shift is within (equivalence) or outside (minimal effect). The exact calculations can be explored via the documentation of the `wilcox.test` function. +The Wilcoxon group of tests (includes Mann-Whitney U-test) provide a non-parametric test of differences between groups, or within samples, based on ranks. With TOST, there are two separate tests of directional location shift to determine if the location shift is within (equivalence) or outside (minimal effect). The exact calculations can be explored via the documentation of the `wilcox.test` function. + +## Why WMW Tests Can Be Misleading + +While the Wilcoxon-Mann-Whitney (WMW) tests are widely used as the "non-parametric alternative" to the t-test, there are important reasons to be cautious about their interpretation, particularly in the equivalence testing context. + +### What WMW actually tests + +A common misconception is that the WMW test compares medians [see @karch2021; @divine2018]. **Without additional assumptions**, the two-tailed WMW test is a test of stochastic equality: + +$$ +H_0: p = \Pr(X < Y) + \frac{1}{2}\Pr(X = Y) = 0.5 +$$ + +where $X$ and $Y$ are randomly selected observations from the two groups. This quantity $\hat{p} = U / (n_1 \cdot n_2)$ (where $U$ is the Mann-Whitney U statistic) has nothing directly to do with means, medians, or even the shapes of the distributions. It is the only interpretation that holds without additional assumptions. + +Only under a **location-shift assumption** (the two distributions have identical shapes, differing only in location) does the WMW test become a test about the Hodges-Lehmann pseudomedian of pairwise differences. And only if the distributions are additionally **symmetric** can this be interpreted as a test of median or mean differences. -## A Note on the Wilcoxon-Mann-Whitney Tests +### Counterexamples -While the Wilcoxon-Mann-Whitney (WMW) tests are widely used as the "non-parametric alternative" to the t-test, there are reasons to be cautious about their interpretation. As @karch2021 discusses, the WMW tests do not straightforwardly test hypotheses about means or medians. The null hypothesis being tested is that the two distributions are identical, and when this null is rejected, interpreting *what* differs between groups (location? scale? shape?) can be ambiguous. +@divine2018 demonstrate several scenarios that illustrate the disconnect between the WMW test and medians: -This interpretive difficulty becomes even more pronounced in the equivalence testing context. When we perform TOST with Wilcoxon tests, we are testing whether a location shift parameter falls within equivalence bounds, but the relationship between this parameter and familiar quantities like means or medians depends on assumptions about distributional shape that may not hold. +1. **Equal medians, significant WMW test:** Both groups can have the same median yet the WMW test rejects $H_0$ ($p < 0.001$), because the distributions differ in shape. -**Recommendation:** If your goal is to make inferences about differences in means (or trimmed means), you are better served by the resampling methods described later in this vignette: `perm_t_test` or `boot_t_TOST`. These methods test hypotheses directly about means while relaxing distributional assumptions. If your interest is in stochastic superiority (the probability that a randomly selected observation from one group exceeds one from another), the Brunner-Munzel test provides a clearer framework with an interpretable effect size. +2. **Very different medians, non-significant WMW test:** Samples can have medians of 9 vs. 99, yet $\hat{p} \approx 0.5$ with $p \approx 1.0$, because neither group stochastically dominates the other. -The `wilcox_TOST` function remains available for situations where rank-based tests are specifically desired, such as with ordinal data or when you want consistency with prior analyses that used WMW tests. +3. **Significance in the wrong direction:** The group with the higher median can have $\hat{p} > 0.5$, meaning the WMW test suggests the *opposite* direction from the median comparison. + +### The problem for equivalence testing + +This interpretive difficulty is especially pronounced for equivalence testing. When we perform TOST with Wilcoxon tests via `wilcox_TOST`, the equivalence bounds are applied to the pseudo-median of pairwise differences. But this quantity corresponds to the difference in means or medians only under the location shift assumption. When distributions differ in shape, a bound of $\pm 2$ units on the pseudo-median of pairwise differences does not guarantee that means or medians are within $\pm 2$ of each other. The researcher may believe they are bounding mean or median differences when they are in fact bounding a different quantity entirely. + +### What to use instead + +**For differences in means (or trimmed means):** Use `perm_t_test` or `boot_t_TOST`. These test hypotheses directly about means while relaxing some distributional assumptions. + +**For stochastic superiority:** Use `brunner_munzel`, which provides a clearer framework with an interpretable effect size (the relative effect, $\hat{p}$) and directly supports equivalence and minimal effect testing. + +**For robust location testing:** Use `hodges_lehmann`, which explicitly tests the Hodges-Lehmann estimator with permutation or asymptotic inference and makes the location-shift assumption transparent. + +**For testing effect sizes directly:** Use `ses_calc` to estimate and test non-parametric standardized effect sizes (rank-biserial correlation, WMW odds, concordance) with proper hypothesis testing support. + +The `wilcox_TOST` function remains available for situations where rank-based tests are specifically desired, such as with ordinal data or when consistency with prior analyses that used WMW tests is needed. ## Key Features and Usage TOSTER's version is the `wilcox_TOST` function. Overall, this function operates extremely similar to the `t_TOST` function. However, the standardized mean difference (SMD) is *not* calculated. Instead the rank-biserial correlation is calculated for *all* types of comparisons (e.g., two sample, one sample, and paired samples). Also, there is no plotting capability at this time for the output of this function. -The `wilcox_TOST` function is particularly useful when: - -- You're working with ordinal data -- You're concerned about outliers influencing your results -- You need a test that makes minimal assumptions about the underlying distributions ### Understanding the Equivalence Bounds (`eqb`) @@ -96,140 +132,11 @@ When interpreting the output of `wilcox_TOST`, pay attention to: 2. The equivalence test p-value (`TOSTp`), which should be < alpha to claim equivalence 3. The rank-biserial correlation (`rb`) and its confidence interval -A statistically significant equivalence test (p < alpha) indicates that the observed effect is statistically within your specified equivalence bounds. The rank-biserial correlation provides a measure of effect size, with values ranging from -1 to 1: - -- Values near 0 indicate negligible association -- Values around ±0.3 indicate a small effect -- Values around ±0.5 indicate a moderate effect -- Values around ±0.7 or greater indicate a large effect - -## Rank-Biserial Correlation - -The standardized effect size reported for the `wilcox_TOST` procedure is the rank-biserial correlation. This is a fairly intuitive measure of effect size which has the same interpretation of the common language effect size [@Kerby_2014]. However, instead of assuming normality and equal variances, the rank-biserial correlation calculates the number of favorable (positive) and unfavorable (negative) pairs based on their respective ranks. - -For the two sample case, the correlation is calculated as the proportion of favorable pairs minus the unfavorable pairs. - -$$ -r_{biserial} = f_{pairs} - u_{pairs} -$$ - -Where: -- $f_{pairs}$ is the proportion of favorable pairs -- $u_{pairs}$ is the proportion of unfavorable pairs - -For the one sample or paired samples cases, the correlation is calculated with ties (values equal to zero) not being dropped. This provides a *conservative* estimate of the rank biserial correlation. - -It is calculated in the following steps wherein $z$ represents the values or difference between paired observations: - -1. Calculate signed ranks: - -$$ -r_j = -1 \cdot sign(z_j) \cdot rank(|z_j|) -$$ - -Where: -- $r_j$ is the signed rank for observation $j$ -- $sign(z_j)$ is the sign of observation $z_j$ (+1 or -1) -- $rank(|z_j|)$ is the rank of the absolute value of observation $z_j$ - -2. Calculate the positive and negative sums: - -$$ - R_{+} = \sum_{1\le i \le n, \space z_i > 0}r_j -$$ - -$$ - R_{-} = \sum_{1\le i \le n, \space z_i < 0}r_j -$$ - -Where: -- $R_{+}$ is the sum of ranks for positive observations -- $R_{-}$ is the sum of ranks for negative observations - -3. Determine the smaller of the two rank sums: - -$$ -T = min(R_{+}, \space R_{-}) -$$ - -$$ -S = \begin{cases} -4 & R_{+} \ge R_{-} \\ 4 & R_{+} < R_{-} \end{cases} -$$ - -Where: -- $T$ is the smaller of the two rank sums -- $S$ is a sign factor based on which rank sum is smaller - -4. Calculate rank-biserial correlation: - -$$ -r_{biserial} = S \cdot | \frac{\frac{T - \frac{(R_{+} + R_{-})}{2}}{n}}{n + 1} | -$$ - -Where: -- $n$ is the number of observations (or pairs) -- The final value ranges from -1 to 1 - -## Confidence Intervals - -The Fisher approximation is used to calculate the confidence intervals. - -For paired samples, or one sample, the standard error is calculated as the following: - -$$ -SE_r = \sqrt{ \frac {(2 \cdot nd^3 + 3 \cdot nd^2 + nd) / 6} {(nd^2 + nd) / 2} } -$$ - -wherein, nd represents the total number of observations (or pairs). - -For independent samples, the standard error is calculated as the following: - -$$ -SE_r = \sqrt{\frac {(n1 + n2 + 1)} { (3 \cdot n1 \cdot n2)}} -$$ - -Where: - -- $n1$ and $n2$ are the sample sizes of the two groups - -The confidence intervals can then be calculated by transforming the estimate. - -$$ -r_z = atanh(r_{biserial}) -$$ - -Then the confidence interval can be calculated and back transformed. - -$$ -r_{CI} = tanh(r_z \pm Z_{(1 - \alpha / 2)} \cdot SE_r) -$$ - -Where: - -- $Z_{(1 - \alpha / 2)}$ is the critical value from the standard normal distribution -- $\alpha$ is the significance level (typically 0.05) +A statistically significant equivalence test (p < alpha) indicates that the observed effect is statistically within your specified equivalence bounds. The rank-biserial correlation provides a measure of effect size, with values ranging from -1 to 1 much like any correlation coefficient. A value of 0 indicates no difference between groups, while values closer to -1 or 1 indicate stronger effects in either direction. The confidence interval for the rank-biserial correlation can help you understand the precision of your standarized effect size estimate. -## Conversion to other effect sizes +## Standardized Effect Sizes -Two other effect sizes can be calculated for non-parametric tests. First, there is the concordance probability, which is also known as the c-statistic, c-index, or probability of superiority^[Directly inspired by this blog post from Professor Frank Harrell https://hbiostat.org/blog/post/wpo/]. The c-statistic is converted from the correlation using the following formula: - -$$ -c = \frac{(r_{biserial} + 1)}{2} -$$ - -The c-statistic can be interpreted as the probability that a randomly selected observation from one group will be greater than a randomly selected observation from another group. A value of 0.5 indicates no difference between groups, while values approaching 1 indicate perfect separation between groups. - -The Wilcoxon-Mann-Whitney odds [@wmwodds], also known as the "Generalized Odds Ratio" [@agresti], is calculated by converting the c-statistic using the following formula: - -$$ -WMW_{odds} = e^{logit(c)} -$$ - -Where $logit(c) = \ln\frac{c}{1-c}$ - -The WMW odds can be interpreted similarly to a traditional odds ratio, representing the odds that an observation from one group is greater than an observation from another group. - -Either effect size is available by simply modifying the `ses` argument for the `wilcox_TOST` function. **Note:** In all examples below, `eqb = .5` remains on the raw data scale (the scale of the `extra` variable in hours of sleep). The `ses` argument only changes which standardized effect size is calculated and reported; it does not change the equivalence bounds or the hypothesis test itself. +The `wilcox_TOST` function reports a standardized effect size (SES) alongside the equivalence test. By default, this is the rank-biserial correlation, but you can select other effect sizes (concordance probability, WMW odds, or WMW log-odds) via the `ses` argument. Changing `ses` only affects which effect size is reported; it does **not** change the equivalence test itself. ```{r} # Rank biserial @@ -239,27 +146,31 @@ wilcox_TOST(formula = extra ~ group, eqb = .5) # Odds - wilcox_TOST(formula = extra ~ group, data = sleep, ses = "o", eqb = .5) # Concordance - wilcox_TOST(formula = extra ~ group, data = sleep, ses = "c", eqb = .5) - ``` -### Guidelines for Selecting Effect Size Measures +For details on how each effect size is calculated, the available confidence interval methods, and how to perform hypothesis testing directly on the effect size scale, see the [Standardized Effect Sizes: Estimation and Testing] section later in this vignette. + +### Interface with `wilcox.test` + +You can also just directly use `wilcox.test` through the `simple_htest` function. This might be useful if you find the interface of `wilcox.test` more intuitive for certain applications than `wilcox_TOST`, or if you want to perform a standard WMW test without the TOST framework. + +```{r} +simple_htest(formula = extra ~ group, + data = sleep, + test = "w", alternative = "e", + mu = .5) +``` -- **Rank-biserial correlation (`"r"`)** is useful when you want a correlation-like measure that's easily interpretable and comparable to other correlation coefficients. -- **Concordance probability (`"c"`)** is beneficial when you want to express the effect in terms of probability, making it accessible to non-statisticians. -- **WMW odds (`"o"`)** is helpful when you want to express the effect in terms familiar to those who work with odds ratios in logistic regression or epidemiology, or interpreting probabilities as odds (e.g., betting and prediction markets). -- **WMW log-odds (`"l"`)** the log-odds can be helpful because you *could* interpret them as a percent difference/change in the odds of stochastic superiority. E.g., if the WMW log-odds were 0.10 then you could say "X increases the odds of superiority by approximately 10% over Y". # Brunner-Munzel Test @@ -268,14 +179,14 @@ Some may want a non-parametric alternative to the WMW test, and the Brunner-Munz ## Overview and Advantages -The Brunner-Munzel test (Brunner & Munzel, 2000; Neubert & Brunner, 2007) offers several advantages over the Wilcoxon-Mann-Whitney tests: +The Brunner-Munzel test [@brunner2000; @neubert2007] offers several advantages over the Wilcoxon-Mann-Whitney tests: 1. It does not assume equal distributions (shapes) between groups 2. It is robust to heteroscedasticity (unequal variances) 3. It provides a more interpretable effect size measure (the "relative effect") 4. It maintains good statistical properties even with unequal sample sizes -The Brunner-Munzel test is based on calculating the "stochastic superiority" (Karch, 2021), which is usually referred to as the relative effect, based on the ranks of the two groups being compared (X and Y). A Brunner-Munzel type test is then a directional test of an effect, and answers a question akin to "what is the probability that a randomly sampled value of X will be greater than Y?" +The Brunner-Munzel test is based on calculating the "stochastic superiority" [@karch2021], which is usually referred to as the relative effect, based on the ranks of the two groups being compared (X and Y). A Brunner-Munzel type test is then a directional test of an effect, and answers a question akin to "what is the probability that a randomly sampled value of X will be greater than Y?"^[In the literature you will often see it denoted as P(XY).] $$ \hat p = P(X>Y) + 0.5 \cdot P(X=Y) @@ -308,9 +219,9 @@ Where: - $p_{null}$ is the null hypothesis value (typically 0.5) - $s$ is the rank-based Brunner-Munzel standard error -The default null hypothesis $p_{null}$ is typically 0.5 (50% probability of superiority is the default null), and $s$ refers to the rank-based Brunner-Munzel standard error. The null can be modified, thereby allowing for equivalence testing *directly based on the relative effect*. Additionally, for paired samples the probability of superiority is based on a *hypothesis of exchangeability* and is not based on the difference scores^[This means the relative effect will *not* match the concordance probability provided by `ses_calc`.]. +The default null hypothesis $p_{null}$ is typically 0.5 (50% probability of superiority (tie) is the default null), and $s$ refers to the rank-based Brunner-Munzel standard error. The null can be modified, thereby allowing for equivalence testing *directly based on the relative effect*. Additionally, for paired samples the probability of superiority is based on a *hypothesis of exchangeability* and is not based on the difference scores^[This means the relative effect will *not* match the concordance probability provided by `ses_calc` for paired samples.]. -For more details on the calculative approach, I suggest reading Karch (2021). At small sample sizes, it is recommended that the permutation version of the test (`test_method = "perm"`) be used rather than the basic test statistic approach. +For more details on the calculative approach, I suggest reading @karch2021. At small sample sizes, it is recommended that the permutation version of the test (`test_method = "perm"`) be used rather than the basic test statistic approach. ## Test Methods @@ -320,7 +231,7 @@ The `brunner_munzel` function provides three test methods via the `test_method` - **"logit"**: Uses a logit transformation to produce range-preserving confidence intervals that are guaranteed to stay within [0, 1]. This method is recommended when the estimated relative effect is close to 0 or 1. -- **"perm"**: A studentized permutation test following Neubert & Brunner (2007). This method is highly recommended when sample sizes are small (< 15 per group) as it provides better control of Type I error rates in these situations. +- **"perm"**: A studentized permutation test following @neubert2007. This method is highly recommended when sample sizes are small (< 15 per group) as it provides better control of Type I error rates in these situations. ## Examples @@ -430,7 +341,7 @@ When interpreting the Brunner-Munzel test results: - Sample sizes are moderate to large (n ≥ 15 per group) - You want the fastest computation -- The relative effect estimate is not near the boundaries (0 or 1) +- The relative effect estimate is not near the boundaries [0, 1] **Use `test_method = "logit"` when:** @@ -444,11 +355,11 @@ When interpreting the Brunner-Munzel test results: - You want better Type I error control in small samples - Precision is more important than computational speed -Note that the permutation approach can be computationally intensive for large datasets. Additionally, with a permutation test you may observe situations where the confidence interval and the p-value would yield *different* conclusions. +Note that the permutation approach can be computationally intensive for large datasets. Additionally, with a permutation test you may observe situations where the confidence interval and the p-value would yield *different* conclusions though they should closely match in most cases. ## Non-Inferiority Testing -The Brunner-Munzel test can be used for non-inferiority testing in clinical trials with ordered categorical data (Munzel & Hauschke, 2003). By setting appropriate bounds, you can test whether a new treatment is not relevantly inferior to a standard: +The Brunner-Munzel test can be used for non-inferiority testing with ordered categorical data [@munzel2003]. By setting appropriate bounds, you can test whether a new treatment is not relevantly inferior to a standard: ```{r} # Example: test non-inferiority with lower bound of 0.35 @@ -459,6 +370,133 @@ brunner_munzel(formula = extra ~ group, mu = 0.35) ``` +# Hodges-Lehmann Estimator and Test + +The `hodges_lehmann` function provides a robust location test based on the Hodges-Lehmann estimator [@hodges1963; @fried2011]. This is a natural companion to the WMW discussion above: while `wilcox_TOST` implicitly relies on the location-shift assumption without making it explicit, `hodges_lehmann` directly estimates and tests the location shift parameter with transparent assumptions. + +## Why Use the Hodges-Lehmann Estimator? + +The Hodges-Lehmann estimator has several appealing properties: + +1. **Robustness to outliers** The Hodges-Lehmann estimator has bounded influence, meaning individual extreme observations cannot arbitrarily distort the estimate. This provides substantially greater robustness than the mean while retaining higher efficiency than the median under normal distributions. +2. **Efficiency:** Under normality, the Hodges-Lehmann estimator achieves about 95.5% of the efficiency of the sample mean, a small price for substantial robustness gains. +3. **Transparent assumptions and distinct inference:** Unlike `wilcox_TOST`, which uses the standard Wilcoxon rank-sum test (and whose confidence interval is obtained by inverting that same test), `hodges_lehmann` constructs its test statistic by dividing the HL estimator by a robust scale estimate following @fried2011. This means that `hodges_lehmann` and `wilcox_TOST` can yield different inferential conclusions despite sharing the same point estimator, particularly in the presence of outliers or heteroscedasticity. The Fried-Dehling approach trades the exact test-CI duality of the WMW framework for greater robustness to contamination. + +## Estimators + +For **one-sample and paired** designs, the function computes the HL1 estimator, the median of all Walsh averages (pairwise averages including self-pairs): + +$$ +\hat{\theta}_{HL1} = \text{med}\left\{\frac{X_i + X_j}{2} : 1 \leq i \leq j \leq n\right\} +$$ + +For **two-sample** designs, the function computes the HL2 estimator, the median of all pairwise differences between samples: + +$$ +\hat{\Delta}_{HL2} = \text{med}\{Y_j - X_i : i = 1, \ldots, m; \; j = 1, \ldots, n\} +$$ + +Both estimators are consistent with the pseudomedian and location shift estimates returned by `wilcox.test`. + +## Interpreting the Estimand + +It is important to understand what these estimators target, particularly for equivalence testing where the meaning of your bounds depends on the estimand. + +**Two-sample (HL2):** The HL2 estimates the median of the distribution of $X - Y$, where $X$ and $Y$ are independently drawn from their respective populations. In practical terms, if you repeatedly drew one observation from each group and computed the difference, the HL2 gives the value around which half of those pairwise differences would fall above and half below. This is *not* the same as the difference in population medians ($\text{median}(X) - \text{median}(Y)$), nor the difference in means. These quantities coincide under a location shift model but diverge when distributional shapes differ. + +**One-sample and paired (HL1):** The HL1 estimates the pseudo-median of the distribution, defined as the median of $(D + D') / 2$ where $D$ and $D'$ are independent draws from the same distribution. This is a measure of the center of symmetry rather than the 50th percentile. Under symmetry, the pseudo-median, median, and mean coincide. Under skewness, they do not. For paired equivalence testing, the question being answered is whether the pseudo-median of the within-subject difference distribution falls within the equivalence bounds, which is a subtly different question than whether the median or mean change score is small. + +**Implications for equivalence bounds:** When setting equivalence bounds for `hodges_lehmann`, you are bounding the pseudo-median of pairwise differences (two-sample) or the pseudo-median of within-subject differences (paired). Under the location shift assumption, these correspond directly to the difference in means or medians, and bounds have their intuitive interpretation. Without this assumption, a bound of $\pm 2$ on the pseudo-median does not guarantee that means or medians are within $\pm 2$ of each other. If your equivalence question is specifically about means, consider `perm_t_test` or `boot_t_TOST` instead. If it is about stochastic dominance, consider `brunner_munzel`. + +## Test Methods + +The `hodges_lehmann` function supports three inference approaches controlled by the `R` argument: + +- **Asymptotic test** (`R = NULL`, the default): Uses kernel density estimation to approximate the variance of the Hodges-Lehmann estimator. Suitable for moderate to large samples (n $\geq$ 30 per group). Note that this produces confidence intervals that will differ from `wilcox.test` due to the different variance estimation method. + +- **Exact permutation test** (`R` $\geq$ max permutations): Enumerates all possible permutations and provides exact p-values using an unstudentized approach. + +- **Randomization test** (`R` < max permutations): Samples `R` permutations with replacement. Uses the (b+1)/(R+1) formula by default for exact Type I error control [@phipson2010] and is also a unstudentized approach. + +## Examples + +### Basic Two-Sample Test + +```{r} +data('sleep') + +# Asymptotic Hodges-Lehmann test +hodges_lehmann(formula = extra ~ group, + data = sleep) +``` + +### Permutation-Based Test + +For small samples, the permutation approach is recommended: + +```{r} +# Permutation test +hodges_lehmann(formula = extra ~ group, + data = sleep, + R = 1999) +``` + +### Equivalence Testing + +The function directly supports equivalence testing via the `alternative` argument. Equivalence bounds are specified on the pseudomedian (or location shift) scale: + +```{r} +# Equivalence test: is the location shift within ±2 units? +# Equivalence/minimal.effect alternatives use the asymptotic method only +hodges_lehmann(formula = extra ~ group, + data = sleep, + alternative = "equivalence", + mu = 2) +``` + +**Note on equivalence testing:** Equivalence and minimal effect tests are only available with the asymptotic method (`R = NULL`). Permutation tests are not supported for these alternatives because the scale estimators (S1, S2) from @fried2011 do not produce a pivotal test statistic for the Hodges-Lehmann estimator. Without pivotality, the permutation distribution generated under the exchangeability null is not a valid reference distribution for testing at the equivalence bounds. This limitation compounds with the inherent conservatism of the naive intersection-union procedure, potentially yielding substantial power loss. The asymptotic method uses kernel density estimation to approximate the standard error, which provides a proper pivot and valid boundary-null inference. + +### Paired Samples + +```{r} +# Paired Hodges-Lehmann test +hodges_lehmann(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], + paired = TRUE, + R = 1999) +``` + +### Minimal Effect Testing + +```{r} +# Minimal effect test: is the location shift outside ±0.5? +# Minimal effect alternative uses the asymptotic method only +hodges_lehmann(formula = extra ~ group, + data = sleep, + alternative = "minimal.effect", + mu = 0.5) +``` + +## Choosing the Right Approach + +**Use the asymptotic test (`R = NULL`) when:** + +- Sample sizes are moderate to large (n $\geq$ 30 per group) +- You want the fastest computation +- Distributions are not extremely heavy-tailed or skewed +- When the null != 0 or when the alternative is "equivalence" or "minimal.effect" + +**Use the permutation test (`R` $\geq$ max permutations) when:** + +- Sample sizes are small enough for exact enumeration +- You want exact p-values with no Monte Carlo error +- For one-sample/paired: $n \leq 16$ ($2^{16}$ = 65,536 permutations) + +**Use the randomization test (set `R` to a large number) when:** + +- Exact permutation is too computationally expensive +- You want distribution-free inference without asymptotic assumptions + # Resampling Methods: Bootstrapping and Permutation Resampling methods provide robust alternatives to parametric t-tests by using the data itself to approximate the sampling distribution of the test statistic. TOSTER offers two complementary resampling approaches: bootstrapping and permutation testing. While both methods relax distributional assumptions, they differ in their mechanics and are suited to different situations. @@ -591,11 +629,7 @@ These two arguments control different aspects of the test: A key feature of `perm_t_test` is its support for trimmed means via the `tr` argument. When `tr > 0`, the function uses Yuen's approach: trimmed means for location estimation and winsorized variances for standard error calculation. This combination is particularly powerful because it provides robustness against outliers (through trimming) together with exact or near-exact inference (through permutation). -Trimming is helpful when: - -- Data contain outliers or extreme values that would unduly influence the mean -- Distributions have heavy tails -- You want robust location estimates without sacrificing the exactness of permutation inference +Trimming is helpful when you want robust location estimates without sacrificing the exactness of permutation inference (e.g., extreme values that distort the mean and/or distributions have heavy tails). A common choice is `tr = 0.1` (10% trimming) or `tr = 0.2` (20% trimming), though the optimal amount depends on the suspected degree of contamination. @@ -658,7 +692,7 @@ perm_t_test(x = before, y = after, # Bootstrap t-test -The `boot_t_TOST` function provides bootstrap-based inference using the percentile bootstrap approach outlined by @efron93 (see chapter 16). The bootstrapped p-values are derived from the studentized version of a test of mean differences. Overall, the results should be similar to `t_TOST` but with greater robustness to distributional violations. +The `boot_t_TOST` function provides bootstrap-based inference using the approach outlined by @efron93 (see chapter 16). Overall, the results should be similar to `t_TOST` but with greater robustness to distributional violations. ## Advantages of Bootstrapping @@ -692,17 +726,34 @@ Where: - $sd_x^*$ and $sd_y^*$ are the standard deviations of the bootstrap samples - $n_x$ and $n_y$ are the sample sizes -3. An approximate p-value can then be calculated as the number of bootstrapped results greater than the observed t-statistic from the sample. +3. Confidence intervals and p-values are then computed from the bootstrap distribution using the method specified by the `boot_ci` argument. + +The same process is completed for the one sample case but with the one sample solution for the equation outlined by $t(z^{*b})$. The paired sample case in this bootstrap procedure is equivalent to the one sample solution because the test is based on the difference scores. + +## Bootstrap CI Methods and P-value Consistency + +Four bootstrap confidence interval methods are available (set via the `boot_ci` argument): + +- **Studentized ("stud", default)**: Uses the bootstrap distribution of pivotal t-statistics, $t^{*b} = (\bar{x}^{*b} - \bar{x}) / se^{*b}$, to construct intervals that account for variability in the standard error. This usually provides the most accurate coverage. +- **Percentile ("perc")**: Uses quantiles of the bootstrap estimate distribution directly. +- **Basic ("basic")**: Reflects the bootstrap estimate distribution around the observed value. +- **Bias-corrected and accelerated ("bca")**: Adjusts for both bias and skewness in the bootstrap distribution using a jackknife-based acceleration correction. Most accurate when the bootstrap distribution is skewed. + +Critically, the bootstrap p-value is now computed using the same method as the confidence interval. This ensures that $p < \alpha$ if and only if the $(1 - \alpha)$ CI excludes the null value (CI inversion principle). For example, when `boot_ci = "perc"` the p-value is based on the proportion of bootstrap estimates on each side of the null: $$ -p_{boot} = \frac {\#t(z^{*b}) \ge t_{sample}}{B} +p_{perc} = 2 \min\left(\frac{\#(x^{*b} \le \theta_0)}{B},\ \frac{\#(x^{*b} \ge \theta_0)}{B}\right) $$ -Where: -- $\#t(z^{*b}) \ge t_{sample}$ is the count of bootstrap t-statistics that exceed the observed t-statistic -- B is the total number of bootstrap replications +while `boot_ci = "stud"` uses the corresponding pivot: -The same process is completed for the one sample case but with the one sample solution for the equation outlined by $t(z^{*b})$. The paired sample case in this bootstrap procedure is equivalent to the one sample solution because the test is based on the difference scores. +$$ +p_{stud} = 2 \min\left(\frac{\#(t^{*b} \ge t_{obs})}{B},\ \frac{\#(t^{*b} \le t_{obs})}{B}\right) +$$ + +where $t_{obs} = (\hat\theta - \theta_0) / \hat{se}$. + +In previous versions of the package, all bootstrap CI methods used the studentized p-value regardless of the CI method selected. This could produce p-values that disagreed with the CI (e.g., a percentile CI excluding the null while the studentized p-value was non-significant, or vice versa). The current implementation eliminates this inconsistency. ## Choosing the Number of Bootstrap Replications @@ -738,11 +789,11 @@ plot(test1) When interpreting the results of `boot_t_TOST`: -1. The bootstrap p-values (`p1` and `p2`) represent the empirical probability of observing the test statistic or more extreme values under repeated sampling -2. The confidence intervals are derived directly from the empirical distribution of bootstrap samples +1. The bootstrap p-values (`p1` and `p2`) represent the empirical probability of observing the test statistic or more extreme values under repeated sampling, computed using a method that matches the selected `boot_ci` +2. The confidence intervals are derived from the bootstrap distribution using the selected method (studentized, percentile, basic, or BCa) 3. The distribution plots provide visual insight into the variability of the effect size estimate -For equivalence testing, examine whether both bootstrap p-values are significant (< alpha) and whether the confidence interval for the effect size falls entirely within the equivalence bounds. +Because the p-values and CIs are computed with the same bootstrap method, they will always agree: if the $(1 - 2\alpha)$ CI for the mean difference falls entirely within the equivalence bounds, then both one-sided bootstrap p-values will be significant at level $\alpha$, and vice versa. # Comparing Bootstrap and Permutation Approaches @@ -779,15 +830,16 @@ Both methods test the same hypothesis and should yield similar conclusions. Key ## Summary: Choosing Between Methods -| Feature | Permutation (`perm_t_test`) | Bootstrap (`boot_t_TOST`) | +| Feature | Permutation (`perm_t_test`) | Bootstrap (`boot_t_TOST`/`boot_t_test`) | |---------|----------------------------|---------------------------| | Resampling type | Without replacement | With replacement | | Exact p-values possible | Yes (small samples) | No | -| Trimmed means support | Yes (`tr` argument) | No | +| Trimmed means support | Yes (`tr` argument) | Yes (`tr` argument in `boot_t_test`) | +| CI methods | Percentile | Studentized, percentile, basic, BCa | | Effect size plots | No | Yes | | Best for | Small samples, exact inference | Moderate samples, visualization | -For very small samples where exact permutations are feasible, permutation testing is generally preferred because it provides exact p-values (i.e., no need to set a seed). For larger samples or when you want the visualization capabilities of `boot_t_TOST`, bootstrapping is a good choice. When outliers are a concern, using `perm_t_test` with trimming combines the benefits of exact inference with robust location estimation. +For very small samples where exact permutations are feasible, permutation testing is generally preferred because it provides exact p-values (i.e., no need to set a seed). For larger samples or when you want the visualization capabilities of `boot_t_TOST` or `boot_t_test`, bootstrapping is a good choice. When outliers are a concern, using `perm_t_test` with trimming combines the benefits of exact inference with robust location estimation. # Ratio of Difference (Log Transformed) @@ -799,6 +851,7 @@ log ( \frac{y}{x} ) = log(y) - log(x) $$ Where: + - y and x are the means of the two groups being compared - The transformation converts multiplicative relationships into additive ones @@ -813,7 +866,7 @@ Log transformation offers several advantages: 1. It facilitates the analysis of **relative** rather than absolute differences 2. It often makes right-skewed distributions more symmetric 3. It stabilizes variance when variability increases with the mean -4. It provides an easy-to-interpret interpretable effect size (ratio of means) +4. It provides an easy-to-interpret effect size (ratio of means) In addition, the FDA considers two drugs as bioequivalent when the ratio between x and y is less than 1.25 and greater than 0.8 (1/1.25), which is the default equivalence bound for the log functions. @@ -880,52 +933,229 @@ The bootstrapped version is particularly recommended when: - Data show notable deviations from log-normality - You want to ensure robust confidence intervals -# Just Estimate an Effect Size +Like `boot_t_TOST`, the `boot_log_TOST` function supports multiple bootstrap CI methods (studentized, percentile, basic, and BCa) via the `boot_ci` argument, with matched p-values that are guaranteed to agree with the CI. All bootstrap computations are performed on the log scale, then back-transformed. + +# Standardized, Rank-Based, Effect Sizes: Estimation and Testing + +The `ses_calc` and `boot_ses_calc` functions calculate rank based standardized effect sizes (rank-biserial correlation, WMW odds, concordance probability, or log-odds) with confidence intervals^[The results from `ses_calc` and `boot_ses_calc` can differ substantially because the bootstrap CI method is typically more conservative than the asymptotic method. This difference is more apparent with extremely small samples like that in the `sleep` dataset.]. As of v0.9.0, `ses_calc` also supports hypothesis testing directly on the effect size scale. + +## Available Effect Sizes + +### Rank-Biserial Correlation -It was requested that a function be provided that only calculates a robust effect size. -Therefore, I created the `ses_calc` and `boot_ses_calc` functions as robust effect size calculation^[The results differ greatly because the bootstrap CI method, basic bootstrap, is more conservative than the parametric method. This difference is more apparent with extremely small samples like that in the `sleep` dataset.]. -The interface is almost the same as `wilcox_TOST` but you don't set an equivalence bound. +The rank-biserial correlation is a fairly intuitive measure of effect size which has a similar interpretation as the common language effect size [@Kerby_2014]. However, instead of assuming normality and equal variances, it calculates the number of favorable (positive) and unfavorable (negative) pairs based on their respective ranks. + +For the two sample case, the correlation is calculated as the proportion of favorable pairs minus the unfavorable pairs. + +$$ +r_{biserial} = f_{pairs} - u_{pairs} +$$ + +Where: +- $f_{pairs}$ is the proportion of favorable pairs +- $u_{pairs}$ is the proportion of unfavorable pairs + +For the one sample or paired samples cases, the correlation is calculated with ties (values equal to zero) not being dropped. This provides a *conservative* estimate of the rank biserial correlation. + +It is calculated in the following steps wherein $z$ represents the values or difference between paired observations: + +1. Calculate signed ranks: + +$$ +r_j = -1 \cdot sign(z_j) \cdot rank(|z_j|) +$$ + +Where: +- $r_j$ is the signed rank for observation $j$ +- $sign(z_j)$ is the sign of observation $z_j$ (+1 or -1) +- $rank(|z_j|)$ is the rank of the absolute value of observation $z_j$ + +2. Calculate the positive and negative sums: + +$$ + R_{+} = \sum_{1\le i \le n, \space z_i > 0}r_j +$$ + +$$ + R_{-} = \sum_{1\le i \le n, \space z_i < 0}r_j +$$ + +Where: +- $R_{+}$ is the sum of ranks for positive observations +- $R_{-}$ is the sum of ranks for negative observations + +3. Determine the smaller of the two rank sums: + +$$ +T = min(R_{+}, \space R_{-}) +$$ + +$$ +S = \begin{cases} -4 & R_{+} \ge R_{-} \\ 4 & R_{+} < R_{-} \end{cases} +$$ + +Where: +- $T$ is the smaller of the two rank sums +- $S$ is a sign factor based on which rank sum is smaller + +4. Calculate rank-biserial correlation: + +$$ +r_{biserial} = S \cdot | \frac{\frac{T - \frac{(R_{+} + R_{-})}{2}}{n}}{n + 1} | +$$ + +Where: +- $n$ is the number of observations (or pairs) +- The final value ranges from -1 to 1 + +### Concordance Probability + +The concordance probability (also known as the c-statistic, c-index, or probability of superiority^[Directly inspired by this blog post from Professor Frank Harrell https://hbiostat.org/blog/post/wpo/]) is converted from the rank-biserial correlation: + +$$ +c = \frac{(r_{biserial} + 1)}{2} +$$ + +The c-statistic can be interpreted as the probability that a randomly selected observation from one group will be greater than a randomly selected observation from another group. A value of 0.5 indicates no difference between groups, while values approaching 1 indicate perfect separation between groups. + +Please note that the c-statistic is equivalent to the area under the receiver operating characteristic curve (AUC) in binary classification contexts. For independent two-sample designs, the c-statistic estimates the same quantity as that produced by `brunner_munzel`: P(X > Y), the probability that a randomly selected observation from one group exceeds a randomly selected observation from the other. However, for paired samples and one-sample designs, the c-statistic from the Wilcoxon test is based on the difference scores rather than the cross-group comparison, estimating P(Z > 0), where Z (Z = X - Y) represents the paired differences (or deviations from the null value). Additionally, the confidence interval and standard error methods differ between `brunner_munzel` and the c-statistic reported here. + +### WMW Odds + +The Wilcoxon-Mann-Whitney odds [@wmwodds], also known as the "Generalized Odds Ratio"^[As noted by my frequent collaborator this name is quite weird since it is not a ratio of odds... but simply an odds!] [@agresti], is calculated by converting the c-statistic: + +$$ +WMW_{odds} = e^{logit(c)} +$$ + +Where $logit(c) = \ln\frac{c}{1-c}$ + +The WMW odds can be interpreted similarly to a traditional odds ratio, representing the odds that an observation from one group is greater than an observation from another group. + +### Guidelines for Selecting Effect Size Measures + +- **Rank-biserial correlation (`"rb"`)** is useful when you want a correlation-like measure that's easily interpretable and comparable to other correlation coefficients. +- **Concordance probability (`"cstat"`)** is beneficial when you want to express the effect in terms of probability, making it accessible to non-statisticians. +- **WMW odds (`"odds"`)** is helpful when you want to express the effect in terms familiar to those who work with odds ratios in logistic regression or epidemiology, or interpreting probabilities as odds (e.g., betting and prediction markets). +- **WMW log-odds (`"logodds"`)** the log-odds can be helpful because you *could* interpret them as a percent difference/change in the odds of stochastic superiority. E.g., if the WMW log-odds were 0.10 then you could say "X increases the odds of superiority by approximately 10% over Y". + +## Confidence Interval Methods + +As of `v0.9.0`, the TOSTER package defaults to the score method (`se_method = "score"`) for computing standard errors and confidence intervals for all SES functions (see function documentation for more information). There is also the **Agresti** method. This method uses placement-based variance estimation and conducts inference on the log-odds scale, which performs fairly well when the degree of seperation between groups is not high. Results are back-transformed to the requested effect size scale for reporting. The **Fisher z-transformation** method (`se_method = "fisher"`) remains available as a legacy option. This was the default in earlier versions of the package and is documented below for reference. + +### Fisher z-Transformation (Legacy Method) + +The Fisher approximation calculates confidence intervals by first computing a standard error, then transforming to a Fisher z-scale for interval construction. + +For paired samples, or one sample, the standard error is calculated as: + +$$ +SE_r = \sqrt{ \frac {(2 \cdot nd^3 + 3 \cdot nd^2 + nd) / 6} {(nd^2 + nd) / 2} } +$$ + +wherein, nd represents the total number of observations (or pairs). + +For independent samples, the standard error is: + +$$ +SE_r = \sqrt{\frac {(n1 + n2 + 1)} { (3 \cdot n1 \cdot n2)}} +$$ + +Where: + +- $n1$ and $n2$ are the sample sizes of the two groups + +The confidence intervals are then calculated by transforming the estimate: + +$$ +r_z = atanh(r_{biserial}) +$$ + +Then the confidence interval can be calculated and back transformed: + +$$ +r_{CI} = tanh(r_z \pm Z_{(1 - \alpha / 2)} \cdot SE_r) +$$ + +Where: + +- $Z_{(1 - \alpha / 2)}$ is the critical value from the standard normal distribution +- $\alpha$ is the significance level (typically 0.05) + +## Effect Size Estimation + +The interface is similar to `wilcox_TOST`, but rather than setting equivalence bounds on the raw scale, `ses_calc` works directly with the standardized effect size. By default (with `alternative = "none"`), it returns an effect size estimate and confidence interval with no hypothesis test: ```{r} -# For paired tests, use separate vectors +# Rank-biserial correlation for paired data ses_calc(x = sleep$extra[sleep$group == 1], y = sleep$extra[sleep$group == 2], paired = TRUE, - ses = "r") + ses = "rb") +``` + + +## Hypothesis Testing with `ses_calc` -# Setting bootstrap replications low to -## reduce compiling time of vignette -boot_ses_calc(x = sleep$extra[sleep$group == 1], - y = sleep$extra[sleep$group == 2], +As of v0.9.0, `ses_calc` supports hypothesis testing directly on the effect size scale by setting the `alternative` argument. This allows you to test whether a non-parametric effect size differs from a specified value, or whether it falls within equivalence bounds, without needing the raw-scale equivalence bounds required by `wilcox_TOST`. + +```{r} +# Two-sided test: does the rank-biserial differ from 0? +ses_calc(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], paired = TRUE, - R = 199, - boot_ci = "perc", # recommend percentile bootstrap for paired SES - ses = "r") + ses = "rb", + alternative = "two.sided") ``` -## Choosing Between Different Bootstrap CI Methods +### Equivalence Testing on the Effect Size Scale + +One advantage of testing directly on the effect size scale is that equivalence bounds have a more intuitive interpretation much like the `brunner_munzel` test. In fact, you should probably use the `brunner_munzel` approach for the two-sample case, but the `ses_calc` functions allow for comparison of paired samples and one-sample case in what that the Brunner-Munzel approach does not allow. Rather than specifying bounds in raw units (which depends on the location-shift assumption), you can specify bounds directly in terms of the effect size: + +```{r} +# Equivalence test: is the rank-biserial within [-0.3, 0.3]? +ses_calc(x = sleep$extra[sleep$group == 1], + y = sleep$extra[sleep$group == 2], + paired = TRUE, + ses = "rb", + alternative = "equivalence", + null.value = c(-0.3, 0.3)) +``` + +When using `ses_calc` for hypothesis testing, the `se_method` argument (described in the [Confidence Interval Methods] section above) also controls how test statistics are computed. The default Agresti method conducts tests on the log-odds scale, while the Fisher method uses z-transformation. See above for details. + +```{r} +# Using the Agresti method (default) with WMW odds +ses_calc(formula = extra ~ group, + data = sleep, + ses = "odds", + alternative = "two.sided") +``` + +## Bootstrap Based Effect Size Testing with `boot_ses_calc` + +When asymptotic approximations may be unreliable, particularly with small samples, `boot_ses_calc` uses bootstrapping to estimate the sampling distribution of the effect size. Note that bootstrap methods cannot work in situations where there is complete separation between groups (e.g., all values in one group are higher than the other), which can occur with small samples and large effects. -The `boot_ses_calc` function offers several bootstrap confidence interval methods through the `boot_ci` parameter: +Like the other bootstrap functions in the package, `boot_ses_calc` supports multiple bootstrap CI methods (studentized, percentile, basic, and BCa) via `boot_ci`, with p-values matched to the selected CI method for guaranteed CI/p-value agreement. All bootstrap computations are performed on a working scale then back-transformed to the requested effect size scale. -- **"perc"** (Percentile): Simple and intuitive, works well for symmetric distributions -- **"basic"**: Similar to percentile but adjusts for bias, more conservative -- **"stud"** (studentized): uses the standard error of each bootstrap sample, more accurate for skewed distributions # Summary Comparison of Robust TOST Methods -| Method | Key Advantages | Limitations | Best Use Cases | -|--------|---------------|-------------|---------------| -| **Wilcoxon TOST** | Simple, widely accepted | Ambiguous hypothesis; not about means or medians | legacy analyses | -| **Brunner-Munzel** | Clear interpretation, robust to heteroscedasticity | Computationally intensive with permutation | Stochastic superiority/dominance | -| **Permutation t-test** | Exact p-values (small samples), supports trimmed means | Computationally intensive for large samples | Mean differences with small samples | -| **Bootstrap TOST** | Flexible, visualization of effect distributions | Results vary between runs | Mean differences with moderate samples | -| **Log-Transformed** | Focuses on relative differences, stabilizes variance | Requires positive data | Bioequivalence, ratio comparisons | +| Method | Estimand | Key Advantages | Limitations | Best Use Cases | +|--------|----------|---------------|-------------|---------------| +| **Wilcoxon-Mann-Whitney** | Pseudo-median of pairwise differences (two-sample) or Walsh averages (paired) | Simple, widely accepted | Estimand $\neq$ mean or median difference without location shift assumption | Ordinal data; legacy analyses | +| **Brunner-Munzel** | $P(X > Y) + 0.5 \cdot P(X = Y)$ | Clear interpretation, robust to heteroscedasticity | Not a location measure | Stochastic superiority/dominance | +| **Hodges-Lehmann** | Same as WMW, with Fried-Dehling inference | Robust location, outlier resistant | Same estimand caveats as WMW; inference differs from `wilcox_TOST` | Robust location shift testing with outlier protection | +| **Permutation t-test** | $\mu_X - \mu_Y$ (or trimmed means if `tr` > 0) | Exact p-values, direct mean comparison | Outlier sensitive (unless trimmed) | Mean differences with small samples | +| **Bootstrap t-test** | $\mu_X - \mu_Y$ | Flexible, visualization | Results vary between runs | Mean differences with moderate samples | +| **Log-Transformed** | $\log(\mu_Y / \mu_X)$ | Ratio-based, stabilizes variance | Requires positive data | Bioequivalence, ratio comparisons | +| **SES calc* | Non-parametric effect sizes (rank-biserial, concordance, odds) | Tests directly on effect size scale | Requires large samples (asymptotic) or many replicates | Non-parametric effect size testing | # Conclusion -The robust TOST procedures provided in the TOSTER package offer reliable alternatives to standard parametric equivalence testing when data violate typical assumptions. By selecting the appropriate robust method for your specific data characteristics and research question, you can ensure more valid statistical inferences about equivalence or minimal effects. +The robust TOST procedures provided in the TOSTER package offer reliable alternatives to standard t-test based equivalence testing when data violate typical assumptions. By selecting the appropriate robust method for your specific data characteristics and research question, you can ensure more valid statistical inferences about equivalence or minimal effects. -Remember that no single method is universally superior - the choice depends on your data structure, sample size, and specific research question. When in doubt, running multiple approaches and comparing results can provide valuable insights into the robustness of your conclusions. +Remember that no single method is universally superior --- the choice depends on your data structure, sample size, and specific research question. When in doubt, running multiple approaches and comparing results can provide valuable insights into the robustness of your conclusions. # References diff --git a/vignettes/robustTOST.html b/vignettes/robustTOST.html index 99dbf67..876cf07 100644 --- a/vignettes/robustTOST.html +++ b/vignettes/robustTOST.html @@ -12,7 +12,7 @@ - + Robust TOST Procedures @@ -364,7 +364,7 @@

Robust TOST Procedures

Aaron R. Caldwell

-

2026-01-23

+

2026-03-13

@@ -372,26 +372,32 @@

2026-01-23

  • Introduction to Robust TOST Methods
  • Wilcoxon-Mann-Whitney TOST
  • Brunner-Munzel Test @@ -418,6 +424,27 @@

    2026-01-23

    Method
  • Non-Inferiority Testing
    • +
  • Hodges-Lehmann Estimator and +Test +
  • Resampling Methods: Bootstrapping and Permutation
    • -
  • Just Estimate an Effect Size +
  • Standardized, +Rank-Based, Effect Sizes: Estimation and Testing +
  • Summary Comparison of Robust TOST Methods
    • @@ -512,6 +562,26 @@

    Introduction to Robust TOST Methods

    alternatives. This vignette introduces several robust TOST methods available in the TOSTER package that maintain their validity under a wider range of data conditions.

    +
    +

    Choosing by Estimand

    +

    Before selecting a robust method, it is worth clarifying what +quantity your equivalence bounds are intended to constrain. Different +methods target different estimands, and the bounds only have their +intended meaning when matched to the right one. If your bounds refer to +mean differences, a permutation t-test or bootstrap approach is +appropriate. If they refer to trimmed mean differences due to concerns +about heavy tails (outliers), Yuen’s trimmed bootstrap or permutation +test are natural choices. If you are interested in stochastic dominance +(P(X > Y)), the Brunner-Munzel test provides a transparent framework. +The Wilcoxon-Mann-Whitney and Hodges-Lehmann procedures target the +pseudo-median of pairwise differences, which coincides with mean and +median differences only under a location shift assumption. When that +assumption is violated, bounds set on the pseudo-median may not +correspond to the magnitude of difference in means or medians that you +intended to declare equivalent.

    +

    TL;DR choose your test carefully and this should be informed +by the estimand of interest.

    +

    When to Use Robust TOST Methods

    Consider using the robust alternatives to t_TOST @@ -557,23 +627,35 @@

    When to Use Robust TOST Methods

    Stochastic superiority is the effect of interest +Hodges-Lehmann +hodges_lehmann() +Robust location estimator, permutation or asymptotic +Robust location shift testing, outlier resistance + + Permutation t-test perm_t_test() Resampling without replacement, exact p-values possible Small samples, mean differences, exact inference - + Bootstrap TOST boot_t_TOST() Resampling with replacement, flexible Moderate samples, mean differences, visualization - + Log-Transformed TOST log_TOST() Ratio-based, for multiplicative comparisons Comparing relative differences (e.g., bioequivalence) + +SES estimation/testing +ses_calc() / boot_ses_calc() +Non-parametric effect sizes with optional hypothesis testing +Testing on the effect size scale directly +
    @@ -582,42 +664,91 @@

    When to Use Robust TOST Methods

    Wilcoxon-Mann-Whitney TOST

    The Wilcoxon group of tests (includes Mann-Whitney U-test) provide a non-parametric test of differences between groups, or within samples, -based on ranks. This provides a test of location shift, which is a fancy -way of saying differences in the center of the distribution (i.e., in -parametric tests the location is mean). With TOST, there are two -separate tests of directional location shift to determine if the -location shift is within (equivalence) or outside (minimal effect). The -exact calculations can be explored via the documentation of the -wilcox.test function.

    -
    -

    A Note on the Wilcoxon-Mann-Whitney Tests

    +based on ranks. With TOST, there are two separate tests of directional +location shift to determine if the location shift is within +(equivalence) or outside (minimal effect). The exact calculations can be +explored via the documentation of the wilcox.test +function.

    +
    +

    Why WMW Tests Can Be Misleading

    While the Wilcoxon-Mann-Whitney (WMW) tests are widely used as the -“non-parametric alternative” to the t-test, there are reasons to be -cautious about their interpretation. As Karch -(2021) discusses, the WMW tests do not straightforwardly test -hypotheses about means or medians. The null hypothesis being tested is -that the two distributions are identical, and when this null is -rejected, interpreting what differs between groups (location? -scale? shape?) can be ambiguous.

    -

    This interpretive difficulty becomes even more pronounced in the -equivalence testing context. When we perform TOST with Wilcoxon tests, -we are testing whether a location shift parameter falls within -equivalence bounds, but the relationship between this parameter and -familiar quantities like means or medians depends on assumptions about -distributional shape that may not hold.

    -

    Recommendation: If your goal is to make inferences -about differences in means (or trimmed means), you are better served by -the resampling methods described later in this vignette: -perm_t_test or boot_t_TOST. These methods test -hypotheses directly about means while relaxing distributional -assumptions. If your interest is in stochastic superiority (the -probability that a randomly selected observation from one group exceeds -one from another), the Brunner-Munzel test provides a clearer framework -with an interpretable effect size.

    +“non-parametric alternative” to the t-test, there are important reasons +to be cautious about their interpretation, particularly in the +equivalence testing context.

    +
    +

    What WMW actually tests

    +

    A common misconception is that the WMW test compares medians (see Karch 2021; Divine et al. 2018). Without +additional assumptions, the two-tailed WMW test is a test of +stochastic equality:

    +

    \[ +H_0: p = \Pr(X < Y) + \frac{1}{2}\Pr(X = Y) = 0.5 +\]

    +

    where \(X\) and \(Y\) are randomly selected observations from +the two groups. This quantity \(\hat{p} = U / +(n_1 \cdot n_2)\) (where \(U\) +is the Mann-Whitney U statistic) has nothing directly to do with means, +medians, or even the shapes of the distributions. It is the only +interpretation that holds without additional assumptions.

    +

    Only under a location-shift assumption (the two +distributions have identical shapes, differing only in location) does +the WMW test become a test about the Hodges-Lehmann pseudomedian of +pairwise differences. And only if the distributions are additionally +symmetric can this be interpreted as a test of median +or mean differences.

    +
    +
    +

    Counterexamples

    +

    Divine et al. (2018) demonstrate several scenarios +that illustrate the disconnect between the WMW test and medians:

    +
      +

    1. Equal medians, significant WMW test: Both groups +can have the same median yet the WMW test rejects \(H_0\) (\(p < +0.001\)), because the distributions differ in shape.

      2. +

    2. Very different medians, non-significant WMW +test: Samples can have medians of 9 vs. 99, yet \(\hat{p} \approx 0.5\) with \(p \approx 1.0\), because neither group +stochastically dominates the other.

      3. +

    3. Significance in the wrong direction: The group +with the higher median can have \(\hat{p} > +0.5\), meaning the WMW test suggests the opposite +direction from the median comparison.

      4. +
    +
    +
    +

    The problem for equivalence testing

    +

    This interpretive difficulty is especially pronounced for equivalence +testing. When we perform TOST with Wilcoxon tests via +wilcox_TOST, the equivalence bounds are applied to the +pseudo-median of pairwise differences. But this quantity corresponds to +the difference in means or medians only under the location shift +assumption. When distributions differ in shape, a bound of \(\pm 2\) units on the pseudo-median of +pairwise differences does not guarantee that means or medians are within +\(\pm 2\) of each other. The researcher +may believe they are bounding mean or median differences when they are +in fact bounding a different quantity entirely.

    +
    +
    +

    What to use instead

    +

    For differences in means (or trimmed means): Use +perm_t_test or boot_t_TOST. These test +hypotheses directly about means while relaxing some distributional +assumptions.

    +

    For stochastic superiority: Use +brunner_munzel, which provides a clearer framework with an +interpretable effect size (the relative effect, \(\hat{p}\)) and directly supports +equivalence and minimal effect testing.

    +

    For robust location testing: Use +hodges_lehmann, which explicitly tests the Hodges-Lehmann +estimator with permutation or asymptotic inference and makes the +location-shift assumption transparent.

    +

    For testing effect sizes directly: Use +ses_calc to estimate and test non-parametric standardized +effect sizes (rank-biserial correlation, WMW odds, concordance) with +proper hypothesis testing support.

    The wilcox_TOST function remains available for situations where rank-based tests are specifically desired, such as with -ordinal data or when you want consistency with prior analyses that used -WMW tests.

    +ordinal data or when consistency with prior analyses that used WMW tests +is needed.

    +

    Key Features and Usage

    @@ -628,14 +759,6 @@

    Key Features and Usage

    calculated for all types of comparisons (e.g., two sample, one sample, and paired samples). Also, there is no plotting capability at this time for the output of this function.

    -

    The wilcox_TOST function is particularly useful -when:

    -
      -
    • You’re working with ordinal data
      • -
    • You’re concerned about outliers influencing your results
      • -
    • You need a test that makes minimal assumptions about the underlying -distributions
      • -

    Understanding the Equivalence Bounds (eqb)

    The equivalence bounds (eqb) are specified on the @@ -685,9 +808,9 @@

    Understanding the Equivalence Bounds (eqb)

    ## TOST Upper 20.0 0.013 ## ## Effect Sizes -## Estimate C.I. Conf. Level -## Median of Differences -1.346 [-3.4, -0.1] 0.9 -## Rank-Biserial Correlation -0.490 [-0.7493, -0.1005] 0.9 +## Estimate C.I. Conf. Level +## Median of Differences -1.346 [-3.4, -0.1] 0.9 +## Rank-Biserial Correlation -0.490 [-0.757, -0.0561] 0.9

    Interpreting the Results

    @@ -704,155 +827,22 @@

    Interpreting the Results

    A statistically significant equivalence test (p < alpha) indicates that the observed effect is statistically within your specified equivalence bounds. The rank-biserial correlation provides a measure of -effect size, with values ranging from -1 to 1:

    -
      -
    • Values near 0 indicate negligible association
      • -
    • Values around ±0.3 indicate a small effect
      • -
    • Values around ±0.5 indicate a moderate effect
      • -
    • Values around ±0.7 or greater indicate a large effect
      • -
    -
    -
    -
    -

    Rank-Biserial Correlation

    -

    The standardized effect size reported for the -wilcox_TOST procedure is the rank-biserial correlation. -This is a fairly intuitive measure of effect size which has the same -interpretation of the common language effect size (Kerby 2014). However, instead of assuming -normality and equal variances, the rank-biserial correlation calculates -the number of favorable (positive) and unfavorable (negative) pairs -based on their respective ranks.

    -

    For the two sample case, the correlation is calculated as the -proportion of favorable pairs minus the unfavorable pairs.

    -

    \[ -r_{biserial} = f_{pairs} - u_{pairs} -\]

    -

    Where: - \(f_{pairs}\) is the -proportion of favorable pairs - \(u_{pairs}\) is the proportion of -unfavorable pairs

    -

    For the one sample or paired samples cases, the correlation is -calculated with ties (values equal to zero) not being dropped. This -provides a conservative estimate of the rank biserial -correlation.

    -

    It is calculated in the following steps wherein \(z\) represents the values or difference -between paired observations:

    -
      -
    1. Calculate signed ranks:
      2. -
    -

    \[ -r_j = -1 \cdot sign(z_j) \cdot rank(|z_j|) -\]

    -

    Where: - \(r_j\) is the signed rank -for observation \(j\) - \(sign(z_j)\) is the sign of observation -\(z_j\) (+1 or -1) - \(rank(|z_j|)\) is the rank of the absolute -value of observation \(z_j\)

    -
      -
    1. Calculate the positive and negative sums:
      2. -
    -

    \[ - R_{+} = \sum_{1\le i \le n, \space z_i > 0}r_j -\]

    -

    \[ - R_{-} = \sum_{1\le i \le n, \space z_i < 0}r_j -\]

    -

    Where: - \(R_{+}\) is the sum of -ranks for positive observations - \(R_{-}\) is the sum of ranks for negative -observations

    -
      -
    1. Determine the smaller of the two rank sums:
      2. -
    -

    \[ -T = min(R_{+}, \space R_{-}) -\]

    -

    \[ -S = \begin{cases} -4 & R_{+} \ge R_{-} \\ 4 & R_{+} < R_{-} -\end{cases} -\]

    -

    Where: - \(T\) is the smaller of the -two rank sums - \(S\) is a sign factor -based on which rank sum is smaller

    -
      -
    1. Calculate rank-biserial correlation:
      2. -
    -

    \[ -r_{biserial} = S \cdot | \frac{\frac{T - \frac{(R_{+} + -R_{-})}{2}}{n}}{n + 1} | -\]

    -

    Where: - \(n\) is the number of -observations (or pairs) - The final value ranges from -1 to 1

    -
    -
    -

    Confidence Intervals

    -

    The Fisher approximation is used to calculate the confidence -intervals.

    -

    For paired samples, or one sample, the standard error is calculated -as the following:

    -

    \[ -SE_r = \sqrt{ \frac {(2 \cdot nd^3 + 3 \cdot nd^2 + nd) / 6} {(nd^2 + -nd) / 2} } -\]

    -

    wherein, nd represents the total number of observations (or -pairs).

    -

    For independent samples, the standard error is calculated as the -following:

    -

    \[ -SE_r = \sqrt{\frac {(n1 + n2 + 1)} { (3 \cdot n1 \cdot n2)}} -\]

    -

    Where:

    -
      -
    • \(n1\) and \(n2\) are the sample sizes of the two -groups
      • -
    -

    The confidence intervals can then be calculated by transforming the -estimate.

    -

    \[ -r_z = atanh(r_{biserial}) -\]

    -

    Then the confidence interval can be calculated and back -transformed.

    -

    \[ -r_{CI} = tanh(r_z \pm Z_{(1 - \alpha / 2)} \cdot SE_r) -\]

    -

    Where:

    -
      -
    • \(Z_{(1 - \alpha / 2)}\) is the -critical value from the standard normal distribution
      • -
    • \(\alpha\) is the significance -level (typically 0.05)
      • -
    -
    -
    -

    Conversion to other effect sizes

    -

    Two other effect sizes can be calculated for non-parametric tests. -First, there is the concordance probability, which is also known as the -c-statistic, c-index, or probability of superiority1. The c-statistic is -converted from the correlation using the following formula:

    -

    \[ -c = \frac{(r_{biserial} + 1)}{2} -\]

    -

    The c-statistic can be interpreted as the probability that a randomly -selected observation from one group will be greater than a randomly -selected observation from another group. A value of 0.5 indicates no -difference between groups, while values approaching 1 indicate perfect -separation between groups.

    -

    The Wilcoxon-Mann-Whitney odds (O’Brien and -Castelloe 2006), also known as the “Generalized Odds Ratio” (Agresti 1980), is calculated by converting the -c-statistic using the following formula:

    -

    \[ -WMW_{odds} = e^{logit(c)} -\]

    -

    Where \(logit(c) = -\ln\frac{c}{1-c}\)

    -

    The WMW odds can be interpreted similarly to a traditional odds -ratio, representing the odds that an observation from one group is -greater than an observation from another group.

    -

    Either effect size is available by simply modifying the -ses argument for the wilcox_TOST function. -Note: In all examples below, eqb = .5 -remains on the raw data scale (the scale of the extra -variable in hours of sleep). The ses argument only changes -which standardized effect size is calculated and reported; it does not -change the equivalence bounds or the hypothesis test itself.

    +effect size, with values ranging from -1 to 1 much like any correlation +coefficient. A value of 0 indicates no difference between groups, while +values closer to -1 or 1 indicate stronger effects in either direction. +The confidence interval for the rank-biserial correlation can help you +understand the precision of your standarized effect size estimate.

    +
    +
    +
    +

    Standardized Effect Sizes

    +

    The wilcox_TOST function reports a standardized effect +size (SES) alongside the equivalence test. By default, this is the +rank-biserial correlation, but you can select other effect sizes +(concordance probability, WMW odds, or WMW log-odds) via the +ses argument. Changing ses only affects which +effect size is reported; it does not change the +equivalence test itself.

    # Rank biserial
 wilcox_TOST(formula = extra ~ group,
                       data = sleep,
@@ -873,15 +863,14 @@ 
    Conversion to other effect sizes
    
 ## TOST Upper           20.0   0.013
 ## 
 ## Effect Sizes 
-##                           Estimate               C.I. Conf. Level
-## Median of Differences       -1.346       [-3.4, -0.1]         0.9
-## Rank-Biserial Correlation   -0.490 [-0.7493, -0.1005]         0.9
    +## Estimate C.I. Conf. Level +## Median of Differences -1.346 [-3.4, -0.1] 0.9 +## Rank-Biserial Correlation -0.490 [-0.757, -0.0561] 0.9 
    # Odds
-
-wilcox_TOST(formula = extra ~ group,
-                      data = sleep,
-                      ses = "o",
-                      eqb = .5)
    +wilcox_TOST(formula = extra ~ group, + data = sleep, + ses = "o", + eqb = .5)
    ## 
 ## Wilcoxon rank sum test with continuity correction
 ## 
@@ -899,13 +888,12 @@ 
    Conversion to other effect sizes
    
 ## Effect Sizes 
 ##                       Estimate             C.I. Conf. Level
 ## Median of Differences  -1.3464     [-3.4, -0.1]         0.9
-## WMW Odds                0.3423 [0.1433, 0.8173]         0.9
    +## WMW Odds 0.3423 [0.1383, 0.8937] 0.9 
    # Concordance
-
-wilcox_TOST(formula = extra ~ group,
-                      data = sleep,
-                      ses = "c",
-                      eqb = .5)
    +wilcox_TOST(formula = extra ~ group, + data = sleep, + ses = "c", + eqb = .5)
    ## 
 ## Wilcoxon rank sum test with continuity correction
 ## 
@@ -923,20 +911,36 @@ 
    Conversion to other effect sizes
    
 ## Effect Sizes 
 ##                       Estimate             C.I. Conf. Level
 ## Median of Differences   -1.346     [-3.4, -0.1]         0.9
-## Concordance              0.255 [0.1254, 0.4497]         0.9
    -
    -

    Guidelines for Selecting Effect Size Measures

    -
      -
    • Rank-biserial correlation ("r") is -useful when you want a correlation-like measure that’s easily -interpretable and comparable to other correlation coefficients.
      • -
    • Concordance probability ("c") is -beneficial when you want to express the effect in terms of probability, -making it accessible to non-statisticians.
      • -
    • WMW odds ("o") is helpful when you -want to express the effect in terms familiar to those who work with odds -ratios in logistic regression or epidemiology.
      • -
    +## Concordance 0.255 [0.1215, 0.4719] 0.9 +

    For details on how each effect size is calculated, the available +confidence interval methods, and how to perform hypothesis testing +directly on the effect size scale, see the [Standardized Effect Sizes: +Estimation and Testing] section later in this vignette.

    +
    +

    Interface with wilcox.test

    +

    You can also just directly use wilcox.test through the +simple_htest function. This might be useful if you find the +interface of wilcox.test more intuitive for certain +applications than wilcox_TOST, or if you want to perform a +standard WMW test without the TOST framework.

    +
    simple_htest(formula = extra ~ group,
+                      data = sleep,
+                      test = "w", alternative = "e",
+                      mu = .5)
    +
    ## 
+##  Wilcoxon rank sum exact test
+## 
+## data:  extra by group
+## W = 34, p-value = 0.8912
+## alternative hypothesis: equivalence
+## null values:
+## location shift location shift 
+##           -0.5            0.5 
+## 90 percent confidence interval:
+##  -3.39996507 -0.09995341
+## sample estimates:
+## Hodges-Lehmann estimate ('1' - '2') 
+##                           -1.346388
    @@ -945,15 +949,14 @@

    Brunner-Munzel Test

    As Karch (2021) explained, there are some reasons to dislike the Wilcoxon-Mann-Whitney (WMW) family of tests as the non-parametric alternative to the t-test. Regardless of the underlying statistical -arguments2, it can be argued that the interpretation +arguments1, it can be argued that the interpretation of the WMW tests, especially when involving equivalence testing, is difficult. Some may want a non-parametric alternative to the WMW test, and the Brunner-Munzel test(s) may be a useful option.

    Overview and Advantages

    -

    The Brunner-Munzel test (Brunner & Munzel, 2000; Neubert & -Brunner, 2007) offers several advantages over the Wilcoxon-Mann-Whitney -tests:

    +

    The Brunner-Munzel test (Brunner and Munzel 2000; Neubert and Brunner 2007) offers +several advantages over the Wilcoxon-Mann-Whitney tests:

    1. It does not assume equal distributions (shapes) between groups
    2. It is robust to heteroscedasticity (unequal variances)
      3. @@ -963,11 +966,12 @@

      Overview and Advantages

      sizes

    The Brunner-Munzel test is based on calculating the “stochastic -superiority” (Karch, 2021), which is usually referred to as the relative -effect, based on the ranks of the two groups being compared (X and Y). A +superiority” (Karch +2021), which is usually referred to as the relative effect, +based on the ranks of the two groups being compared (X and Y). A Brunner-Munzel type test is then a directional test of an effect, and answers a question akin to “what is the probability that a randomly -sampled value of X will be greater than Y?”

    +sampled value of X will be greater than Y?”2

    \[ \hat p = P(X>Y) + 0.5 \cdot P(X=Y) \]

    @@ -1008,16 +1012,16 @@

    Basics of the Calculative Approach

    Brunner-Munzel standard error

    The default null hypothesis \(p_{null}\) is typically 0.5 (50% -probability of superiority is the default null), and \(s\) refers to the rank-based Brunner-Munzel +probability of superiority (tie) is the default null), and \(s\) refers to the rank-based Brunner-Munzel standard error. The null can be modified, thereby allowing for equivalence testing directly based on the relative effect. Additionally, for paired samples the probability of superiority is based on a hypothesis of exchangeability and is not based on the difference scores3.

    -

    For more details on the calculative approach, I suggest reading Karch -(2021). At small sample sizes, it is recommended that the permutation -version of the test (test_method = "perm") be used rather -than the basic test statistic approach.

    +

    For more details on the calculative approach, I suggest reading Karch (2021). At +small sample sizes, it is recommended that the permutation version of +the test (test_method = "perm") be used rather than the +basic test statistic approach.

    Test Methods

    @@ -1033,9 +1037,10 @@

    Test Methods

    [0, 1]. This method is recommended when the estimated relative effect is close to 0 or 1.

  • “perm”: A studentized permutation test following -Neubert & Brunner (2007). This method is highly recommended when -sample sizes are small (< 15 per group) as it provides better control -of Type I error rates in these situations.

    • +Neubert and Brunner (2007). This method is highly +recommended when sample sizes are small (< 15 per group) as it +provides better control of Type I error rates in these +situations.

    @@ -1046,9 +1051,9 @@

    Basic Two-Sample Test

    brunner_munzel function allows for standard hypothesis tests (“two.sided”, “less”, “greater”) as well as equivalence and minimal effect tests.

    -
    # Default studentized test (t-approximation)
-brunner_munzel(formula = extra ~ group,
-               data = sleep)
    +
    # Default studentized test (t-approximation)
+brunner_munzel(formula = extra ~ group,
+               data = sleep)
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
 ##  Two-sample Brunner-Munzel test
@@ -1059,33 +1064,34 @@ 
    Basic Two-Sample Test
    
 ## 95 percent confidence interval:
 ##  0.01387048 0.49612952
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    -
    # Permutation test (recommended for small samples)
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               test_method = "perm")
    +## P('1'>'2') + .5*P('1'='2') +## 0.255 +
    # Permutation test (recommended for small samples)
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               test_method = "perm")
    +
    ## Note: Confidence interval bounds were clamped to the [0, 1] range.
    ## 
-##  Two-sample Brunner-Munzel permutation test
+##  Two-sample Brunner-Munzel Randomization test
 ## 
 ## data:  extra by group
-## t-observed = -2.1447, df = 16.898, p-value = 0.05559
+## t-observed = -2.1447, N-permutations = 10000, p-value = 0.05949
 ## alternative hypothesis: true relative effect is not equal to 0.5
 ## 95 percent confidence interval:
-##  0.0000000 0.5089213
+##  0.0000000 0.5144564
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    +## P('1'>'2') + .5*P('1'='2') +## 0.255

    Logit Transformation for Range-Preserving CIs

    When the relative effect estimate is close to 0 or 1, the standard confidence intervals may extend beyond the valid [0, 1] range. The logit transformation method addresses this:

    -
    # Logit transformation for range-preserving CIs
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               test_method = "logit")
    +
    # Logit transformation for range-preserving CIs
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               test_method = "logit")
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
 ##  Two-sample Brunner-Munzel test (logit)
@@ -1096,8 +1102,8 @@ 
    Logit Transformation for Range-Preserving CIs
    
 ## 95 percent confidence interval:
 ##  0.08775255 0.54912824
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    +## P('1'>'2') + .5*P('1'='2') +## 0.255

    Equivalence Testing

    @@ -1105,11 +1111,11 @@

    Equivalence Testing

    equivalence testing via the alternative argument. For equivalence tests, you specify bounds for the relative effect using the mu argument:

    -
    # Equivalence test: is the relative effect between 0.3 and 0.7?
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               alternative = "equivalence",
-               mu = c(0.3, 0.7))
    +
    # Equivalence test: is the relative effect between 0.3 and 0.7?
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               alternative = "equivalence",
+               mu = c(0.3, 0.7))
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
 ##  Two-sample Brunner-Munzel test
@@ -1123,39 +1129,39 @@ 
    Equivalence Testing
    
 ## 90 percent confidence interval:
 ##  0.0562039 0.4537961
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    -
    # Permutation-based equivalence test
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               alternative = "equivalence",
-               mu = c(0.3, 0.7),
-               test_method = "perm")
    +## P('1'>'2') + .5*P('1'='2') +## 0.255 +
    # Permutation-based equivalence test
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               alternative = "equivalence",
+               mu = c(0.3, 0.7),
+               test_method = "perm")
    ## NOTE: Permutation-based TOST for equivalence/minimal.effect testing.
    ## 
-##  Two-sample Brunner-Munzel permutation test
+##  Two-sample Brunner-Munzel Randomization test
 ## 
 ## data:  extra by group
-## t-observed = -0.39392, df = 16.898, p-value = 0.6598
+## t-observed = -0.39392, N-permutations = 10000, p-value = 0.6552
 ## alternative hypothesis: equivalence
 ## null values:
 ## lower bound upper bound 
 ##         0.3         0.7 
 ## 90 percent confidence interval:
-##  0.0588093 0.4511907
+##  0.05645152 0.45354848
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    +## P('1'>'2') + .5*P('1'='2') +## 0.255

    Minimal Effect Testing

    You can also test whether the relative effect falls outside specified bounds (minimal effect test):

    -
    # Minimal effect test: is the relative effect outside 0.4 to 0.6?
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               alternative = "minimal.effect",
-               mu = c(0.4, 0.6))
    +
    # Minimal effect test: is the relative effect outside 0.4 to 0.6?
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               alternative = "minimal.effect",
+               mu = c(0.4, 0.6))
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
 ##  Two-sample Brunner-Munzel test
@@ -1169,21 +1175,21 @@ 
    Minimal Effect Testing
    
 ## 90 percent confidence interval:
 ##  0.0562039 0.4537961
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    +## P('1'>'2') + .5*P('1'='2') +## 0.255

    Paired Samples

    The Brunner-Munzel test can also be applied to paired samples using the paired argument. Note that for paired samples, the test is based on a hypothesis of exchangeability:

    -
    # Paired samples test
-brunner_munzel(x = sleep$extra[sleep$group == 1],
-               y = sleep$extra[sleep$group == 2],
-               paired = TRUE)
    +
    # Paired samples test
+brunner_munzel(x = sleep$extra[sleep$group == 1],
+               y = sleep$extra[sleep$group == 2],
+               paired = TRUE)
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
-##  Exact paired Brunner-Munzel test
+##  Paired Brunner-Munzel test
 ## 
 ## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
 ## t = -3.7266, df = 9, p-value = 0.004722
@@ -1193,16 +1199,16 @@ 
    Paired Samples
    
 ## sample estimates:
 ## P(X>Y) + .5*P(X=Y) 
 ##              0.255
    -
    # Paired samples with permutation test
-brunner_munzel(x = sleep$extra[sleep$group == 1],
-               y = sleep$extra[sleep$group == 2],
-               paired = TRUE,
-               test_method = "perm")
    +
    # Paired samples with permutation test
+brunner_munzel(x = sleep$extra[sleep$group == 1],
+               y = sleep$extra[sleep$group == 2],
+               paired = TRUE,
+               test_method = "perm")
    ## 
-##  Paired Brunner-Munzel permutation test
+##  Paired Brunner-Munzel Exact Permutation test
 ## 
 ## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
-## t-observed = -3.7266, df = 9, p-value = 0.003906
+## t-observed = -3.7266, N-permutations = 1024, p-value = 0.003906
 ## alternative hypothesis: true relative effect is not equal to 0.5
 ## 95 percent confidence interval:
 ##  0.1233862 0.3866138
@@ -1213,10 +1219,10 @@ 
    Paired Samples
    
 
    
 
    Testing Against a Non-Standard Null
    
 
    You can test against null values other than 0.5:
    
-
    # Test if the relative effect differs from 0.3
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               mu = 0.3)
    
+
    # Test if the relative effect differs from 0.3
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               mu = 0.3)
    
 
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    
 
    ## 
 ##  Two-sample Brunner-Munzel test
@@ -1227,8 +1233,8 @@ 
    Testing Against a Non-Standard Null
    
 ## 95 percent confidence interval:
 ##  0.01387048 0.49612952
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    
+## P('1'>'2') + .5*P('1'='2') 
+##                      0.255
    @@ -1250,8 +1256,7 @@

    Choosing the Right Test Method

    • Sample sizes are moderate to large (n ≥ 15 per group)
    • You want the fastest computation
      • -
    • The relative effect estimate is not near the boundaries (0 or -1)
      • +
    • The relative effect estimate is not near the boundaries [0, 1]

    Use test_method = "logit" when:

      @@ -1268,20 +1273,21 @@

      Choosing the Right Test Method

      Note that the permutation approach can be computationally intensive for large datasets. Additionally, with a permutation test you may observe situations where the confidence interval and the p-value would -yield different conclusions.

      +yield different conclusions though they should closely match in +most cases.

    Non-Inferiority Testing

    -

    The Brunner-Munzel test can be used for non-inferiority testing in -clinical trials with ordered categorical data (Munzel & Hauschke, -2003). By setting appropriate bounds, you can test whether a new -treatment is not relevantly inferior to a standard:

    -
    # Example: test non-inferiority with lower bound of 0.35
-# (i.e., the new treatment should not be substantially worse)
-brunner_munzel(formula = extra ~ group,
-               data = sleep,
-               alternative = "greater",
-               mu = 0.35)
    +

    The Brunner-Munzel test can be used for non-inferiority testing with +ordered categorical data (Munzel and Hauschke 2003). By setting +appropriate bounds, you can test whether a new treatment is not +relevantly inferior to a standard:

    +
    # Example: test non-inferiority with lower bound of 0.35
+# (i.e., the new treatment should not be substantially worse)
+brunner_munzel(formula = extra ~ group,
+               data = sleep,
+               alternative = "greater",
+               mu = 0.35)
    ## Sample size in at least one group is small. Permutation test (test_method = 'perm') is highly recommended.
    ## 
 ##  Two-sample Brunner-Munzel test
@@ -1292,8 +1298,271 @@ 
    Non-Inferiority Testing
    
 ## 95 percent confidence interval:
 ##  0.0562039 1.0000000
 ## sample estimates:
-## P(X>Y) + .5*P(X=Y) 
-##              0.255
    +## P('1'>'2') + .5*P('1'='2') +## 0.255 +
    + +
    +

    Hodges-Lehmann Estimator and Test

    +

    The hodges_lehmann function provides a robust location +test based on the Hodges-Lehmann estimator (Hodges and Lehmann 1963; Fried and Dehling 2011). This is a +natural companion to the WMW discussion above: while +wilcox_TOST implicitly relies on the location-shift +assumption without making it explicit, hodges_lehmann +directly estimates and tests the location shift parameter with +transparent assumptions.

    +
    +

    Why Use the Hodges-Lehmann Estimator?

    +

    The Hodges-Lehmann estimator has several appealing properties:

    +
      +
    1. Robustness to outliers The Hodges-Lehmann estimator +has bounded influence, meaning individual extreme observations cannot +arbitrarily distort the estimate. This provides substantially greater +robustness than the mean while retaining higher efficiency than the +median under normal distributions.
      2. +
    2. Efficiency: Under normality, the Hodges-Lehmann +estimator achieves about 95.5% of the efficiency of the sample mean, a +small price for substantial robustness gains.
      3. +
    3. Transparent assumptions and distinct inference: +Unlike wilcox_TOST, which uses the standard Wilcoxon +rank-sum test (and whose confidence interval is obtained by inverting +that same test), hodges_lehmann constructs its test +statistic by dividing the HL estimator by a robust scale estimate +following Fried and Dehling (2011). This means that +hodges_lehmann and wilcox_TOST can yield +different inferential conclusions despite sharing the same point +estimator, particularly in the presence of outliers or +heteroscedasticity. The Fried-Dehling approach trades the exact test-CI +duality of the WMW framework for greater robustness to +contamination.
      4. +
    +
    +
    +

    Estimators

    +

    For one-sample and paired designs, the function +computes the HL1 estimator, the median of all Walsh averages (pairwise +averages including self-pairs):

    +

    \[ +\hat{\theta}_{HL1} = \text{med}\left\{\frac{X_i + X_j}{2} : 1 \leq i +\leq j \leq n\right\} +\]

    +

    For two-sample designs, the function computes the +HL2 estimator, the median of all pairwise differences between +samples:

    +

    \[ +\hat{\Delta}_{HL2} = \text{med}\{Y_j - X_i : i = 1, \ldots, m; \; j = 1, +\ldots, n\} +\]

    +

    Both estimators are consistent with the pseudomedian and location +shift estimates returned by wilcox.test.

    +
    +
    +

    Interpreting the Estimand

    +

    It is important to understand what these estimators target, +particularly for equivalence testing where the meaning of your bounds +depends on the estimand.

    +

    Two-sample (HL2): The HL2 estimates the median of +the distribution of \(X - Y\), where +\(X\) and \(Y\) are independently drawn from their +respective populations. In practical terms, if you repeatedly drew one +observation from each group and computed the difference, the HL2 gives +the value around which half of those pairwise differences would fall +above and half below. This is not the same as the difference in +population medians (\(\text{median}(X) - +\text{median}(Y)\)), nor the difference in means. These +quantities coincide under a location shift model but diverge when +distributional shapes differ.

    +

    One-sample and paired (HL1): The HL1 estimates the +pseudo-median of the distribution, defined as the median of \((D + D') / 2\) where \(D\) and \(D'\) are independent draws from the +same distribution. This is a measure of the center of symmetry rather +than the 50th percentile. Under symmetry, the pseudo-median, median, and +mean coincide. Under skewness, they do not. For paired equivalence +testing, the question being answered is whether the pseudo-median of the +within-subject difference distribution falls within the equivalence +bounds, which is a subtly different question than whether the median or +mean change score is small.

    +

    Implications for equivalence bounds: When setting +equivalence bounds for hodges_lehmann, you are bounding the +pseudo-median of pairwise differences (two-sample) or the pseudo-median +of within-subject differences (paired). Under the location shift +assumption, these correspond directly to the difference in means or +medians, and bounds have their intuitive interpretation. Without this +assumption, a bound of \(\pm 2\) on the +pseudo-median does not guarantee that means or medians are within \(\pm 2\) of each other. If your equivalence +question is specifically about means, consider perm_t_test +or boot_t_TOST instead. If it is about stochastic +dominance, consider brunner_munzel.

    +
    +
    +

    Test Methods

    +

    The hodges_lehmann function supports three inference +approaches controlled by the R argument:

    +
      +

    • Asymptotic test (R = NULL, the +default): Uses kernel density estimation to approximate the variance of +the Hodges-Lehmann estimator. Suitable for moderate to large samples (n +\(\geq\) 30 per group). Note that this +produces confidence intervals that will differ from +wilcox.test due to the different variance estimation +method.

      • +

    • Exact permutation test (R \(\geq\) max permutations): Enumerates all +possible permutations and provides exact p-values using an unstudentized +approach.

      • +

    • Randomization test (R < max +permutations): Samples R permutations with replacement. +Uses the (b+1)/(R+1) formula by default for exact Type I error control +(Phipson and Smyth +2010) and is also a unstudentized approach.

      • +
    +
    +
    +

    Examples

    +
    +

    Basic Two-Sample Test

    +
    data('sleep')
+
+# Asymptotic Hodges-Lehmann test
+hodges_lehmann(formula = extra ~ group,
+               data = sleep)
    +
    ## 
+##  Asymptotic Hodges-Lehmann Two Sample Test
+## 
+## data:  extra by group
+## Z = -1.3179, p-value = 0.1875
+## alternative hypothesis: true location is not equal to 0
+## 95 percent confidence interval:
+##  -3.3576425  0.6576425
+## sample estimates:
+## Hodges-Lehmann estimate ('1' - '2') 
+##                               -1.35
    +
    +
    +

    Permutation-Based Test

    +

    For small samples, the permutation approach is recommended:

    +
    # Permutation test
+hodges_lehmann(formula = extra ~ group,
+               data = sleep,
+               R = 1999)
    +
    ## 
+##  Randomization Hodges-Lehmann Two Sample Test
+## 
+## data:  extra by group
+## Z = -0.72973, p-value = 0.1265
+## alternative hypothesis: true location is not equal to 0
+## 95 percent confidence interval:
+##  -3.15  0.45
+## sample estimates:
+## Hodges-Lehmann estimate ('1' - '2') 
+##                               -1.35
    +
    +
    +

    Equivalence Testing

    +

    The function directly supports equivalence testing via the +alternative argument. Equivalence bounds are specified on +the pseudomedian (or location shift) scale:

    +
    # Equivalence test: is the location shift within ±2 units?
+# Equivalence/minimal.effect alternatives use the asymptotic method only
+hodges_lehmann(formula = extra ~ group,
+               data = sleep,
+               alternative = "equivalence",
+               mu = 2)
    +
    ## 
+##  Asymptotic Hodges-Lehmann Two Sample Test
+## 
+## data:  extra by group
+## Z = 0.63456, p-value = 0.2629
+## alternative hypothesis: equivalence
+## null values:
+## location location 
+##       -2        2 
+## 90 percent confidence interval:
+##  -3.0348667  0.3348667
+## sample estimates:
+## Hodges-Lehmann estimate ('1' - '2') 
+##                               -1.35
    +

    Note on equivalence testing: Equivalence and minimal +effect tests are only available with the asymptotic method +(R = NULL). Permutation tests are not supported for these +alternatives because the scale estimators (S1, S2) from Fried and Dehling (2011) do not produce a pivotal test +statistic for the Hodges-Lehmann estimator. Without pivotality, the +permutation distribution generated under the exchangeability null is not +a valid reference distribution for testing at the equivalence bounds. +This limitation compounds with the inherent conservatism of the naive +intersection-union procedure, potentially yielding substantial power +loss. The asymptotic method uses kernel density estimation to +approximate the standard error, which provides a proper pivot and valid +boundary-null inference.

    +
    +
    +

    Paired Samples

    +
    # Paired Hodges-Lehmann test
+hodges_lehmann(x = sleep$extra[sleep$group == 1],
+               y = sleep$extra[sleep$group == 2],
+               paired = TRUE,
+               R = 1999)
    +
    ## Computing all 1024 exact permutations.
    +
    ## 
+##  Exact Permutation Hodges-Lehmann Paired Test
+## 
+## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
+## Z = -1.3, p-value < 2.2e-16
+## alternative hypothesis: true location is not equal to 0
+## 95 percent confidence interval:
+##  -1.8 -0.8
+## sample estimates:
+## Hodges-Lehmann estimate (z = x - y) 
+##                                -1.3
    +
    +
    +

    Minimal Effect Testing

    +
    # Minimal effect test: is the location shift outside ±0.5?
+# Minimal effect alternative uses the asymptotic method only
+hodges_lehmann(formula = extra ~ group,
+               data = sleep,
+               alternative = "minimal.effect",
+               mu = 0.5)
    +
    ## 
+##  Asymptotic Hodges-Lehmann Two Sample Test
+## 
+## data:  extra by group
+## Z = -0.82981, p-value = 0.2033
+## alternative hypothesis: minimal.effect
+## null values:
+## location location 
+##     -0.5      0.5 
+## 90 percent confidence interval:
+##  -3.0348667  0.3348667
+## sample estimates:
+## Hodges-Lehmann estimate ('1' - '2') 
+##                               -1.35
    +
    +
    +
    +

    Choosing the Right Approach

    +

    Use the asymptotic test (R = NULL) +when:

    +
      +
    • Sample sizes are moderate to large (n \(\geq\) 30 per group)
      • +
    • You want the fastest computation
      • +
    • Distributions are not extremely heavy-tailed or skewed
      • +
    • When the null != 0 or when the alternative is “equivalence” or +“minimal.effect”
      • +
    +

    Use the permutation test (R \(\geq\) max permutations) when:

    +
      +
    • Sample sizes are small enough for exact enumeration
      • +
    • You want exact p-values with no Monte Carlo error
      • +
    • For one-sample/paired: \(n \leq +16\) (\(2^{16}\) = 65,536 +permutations)
      • +
    +

    Use the randomization test (set R to a large +number) when:

    +
      +
    • Exact permutation is too computationally expensive
      • +
    • You want distribution-free inference without asymptotic +assumptions
      • +
    @@ -1378,10 +1647,10 @@

    When to Use Each Method

    Permutation t-test

    The perm_t_test function implements studentized -permutation tests following the approaches of Janssen (1997) and Chung -and Romano (2013). The studentized approach computes a -t-statistic for each permutation, making the test valid even under -heteroscedasticity (unequal variances).

    +permutation tests following the approaches of Janssen (1997) +and Chung and Romano (2013). The studentized approach +computes a t-statistic for each permutation, making the test valid even +under heteroscedasticity (unequal variances).

    Permutation Procedure

    For one-sample and paired tests, permutation is @@ -1432,10 +1701,8 @@

    Two-Sample Permutation Algorithm

    Welch Variant (var.equal = FALSE)

    When var.equal = FALSE (the default), the standard error is computed separately for each group as shown above. This is the -studentized permutation approach of Janssen -(1997) and Chung and Romano (2013), -which remains valid even when the two populations have different -variances.

    +studentized permutation approach of Janssen (1997) and Chung and Romano (2013), which remains valid even when +the two populations have different variances.

    Pooled Variance Variant (var.equal = TRUE)

    @@ -1487,10 +1754,10 @@

    Studentized Permutation: The perm_se Argument

    By default, perm_t_test uses the studentized permutation approach (perm_se = TRUE), which recalculates the standard error for -each permutation sample. This follows the recommendations of Janssen (1997) and Chung -and Romano (2013), who showed that studentized permutation tests -maintain valid Type I error control even under heteroscedasticity -(unequal variances).

    +each permutation sample. This follows the recommendations of Janssen (1997) +and Chung and Romano (2013), who showed that studentized +permutation tests maintain valid Type I error control even under +heteroscedasticity (unequal variances).

    How perm_se and var.equal interact:

    These two arguments control different aspects of the test:

    @@ -1559,53 +1826,50 @@

    Combining Permutation with Trimmed Means

    particularly powerful because it provides robustness against outliers (through trimming) together with exact or near-exact inference (through permutation).

    -

    Trimming is helpful when:

    -
      -
    • Data contain outliers or extreme values that would unduly influence -the mean
      • -
    • Distributions have heavy tails
      • -
    • You want robust location estimates without sacrificing the exactness -of permutation inference
      • -
    +

    Trimming is helpful when you want robust location estimates without +sacrificing the exactness of permutation inference (e.g., extreme values +that distort the mean and/or distributions have heavy tails).

    A common choice is tr = 0.1 (10% trimming) or tr = 0.2 (20% trimming), though the optimal amount depends on the suspected degree of contamination.

    Example: Basic Permutation Test

    -
    data('sleep')
-
-# Two-sample permutation t-test
-perm_result <- perm_t_test(extra ~ group, 
-                           data = sleep,
-                           R = 1999)
-perm_result
    +
    data('sleep')
+
+# Two-sample permutation t-test
+perm_result <- perm_t_test(extra ~ group, 
+                           data = sleep,
+                           R = 1999)
+perm_result
    ## 
-##  Monte Carlo Permutation Welch Two Sample t-test
+##  Randomization Permutation Welch Two Sample t-test
 ## 
 ## data:  extra by group
-## t-observed = -1.8608, df = 17.776, p-value = 0.0805
+## t-observed = -1.8608, df = 17.776, p-value = 0.0815
 ## alternative hypothesis: true difference in means is not equal to 0
 ## 95 percent confidence interval:
-##  -3.34  0.16
+##  -3.361  0.160
 ## sample estimates:
-## mean of x mean of y 
-##      0.75      2.33
    +## mean of group '1' mean of group '2' +## 0.75 2.33 +## mean difference ('1' - '2') +## -1.58

    Example: Permutation Test with Trimming

    When outliers are a concern, combining permutation with trimming provides doubly robust inference:

    -
    # Simulate data with outliers
-set.seed(42)
-x <- c(rnorm(18, mean = 0), 8, 12)  # Two outliers
-y <- rnorm(20, mean = 0)
-
-# Standard permutation test (sensitive to outliers)
-perm_t_test(x, y, R = 999)
    +
    # Simulate data with outliers
+set.seed(42)
+x <- c(rnorm(18, mean = 0), 8, 12)  # Two outliers
+y <- rnorm(20, mean = 0)
+
+# Standard permutation test (sensitive to outliers)
+perm_t_test(x, y, R = 999)
    ## Note: Number of permutations (R = 999) is less than 1000. Consider increasing R for more stable p-value estimates.
    ## 
-##  Monte Carlo Permutation Welch Two Sample t-test
+##  Randomization Permutation Welch Two Sample t-test
 ## 
 ## data:  x and y
 ## t-observed = 1.8777, df = 23.773, p-value = 0.053
@@ -1613,13 +1877,13 @@ 
    Example: Permutation Test with Trimming
    
 ## 95 percent confidence interval:
 ##  0.0004404028 2.9218589227
 ## sample estimates:
-##  mean of x  mean of y 
-##  1.2479377 -0.2081052
    -
    # Trimmed permutation test (robust to outliers)
-perm_t_test(x, y, tr = 0.1, R = 999)
    +## mean of group x mean of group y mean difference (x - y) +## 1.2479377 -0.2081052 1.4560429 +
    # Trimmed permutation test (robust to outliers)
+perm_t_test(x, y, tr = 0.1, R = 999)
    ## Note: Number of permutations (R = 999) is less than 1000. Consider increasing R for more stable p-value estimates.
    ## 
-##  Monte Carlo Permutation Welch Yuen Two Sample t-test
+##  Randomization Permutation Welch Yuen Two Sample t-test
 ## 
 ## data:  x and y
 ## t-observed = 1.8462, df = 29.997, p-value = 0.078
@@ -1627,22 +1891,26 @@ 
    Example: Permutation Test with Trimming
    
 ## 95 percent confidence interval:
 ##  -0.0636125  1.6437612
 ## sample estimates:
-## trimmed mean of x trimmed mean of y 
-##         0.5627544        -0.1972272
    +## trimmed mean of x +## 0.5627544 +## trimmed mean of y +## -0.1972272 +## trimmed mean difference (x - y, tr = 0.1) +## 0.7599816

    Example: Equivalence Testing with Permutation

    The perm_t_test function supports TOSTER’s equivalence and minimal effect alternatives:

    -
    # Equivalence test: is the effect within ±3 units?
-perm_t_test(extra ~ group, 
-            data = sleep,
-            alternative = "equivalence",
-            mu = c(-3, 3),
-            R = 999)
    +
    # Equivalence test: is the effect within ±3 units?
+perm_t_test(extra ~ group, 
+            data = sleep,
+            alternative = "equivalence",
+            mu = c(-3, 3),
+            R = 999)
    ## Note: Number of permutations (R = 999) is less than 1000. Consider increasing R for more stable p-value estimates.
    ## 
-##  Monte Carlo Permutation Welch Two Sample t-test
+##  Randomization Permutation Welch Two Sample t-test
 ## 
 ## data:  extra by group
 ## t-observed = 1.6724, df = 17.776, p-value = 0.051
@@ -1653,8 +1921,10 @@ 
    Example: Equivalence Testing with Permutation
    
 ## 90 percent confidence interval:
 ##  -3.060 -0.138
 ## sample estimates:
-## mean of x mean of y 
-##      0.75      2.33
    +## mean of group '1' mean of group '2' +## 0.75 2.33 +## mean difference ('1' - '2') +## -1.58

    Exact vs. Monte Carlo Permutations

    @@ -1664,36 +1934,35 @@

    Exact vs. Monte Carlo Permutations

    n = 10, there are \(2^{10} = 1024\) possible sign permutations, so requesting R = 1999 would trigger exact computation.

    -
    # Small paired sample - exact permutations will be computed
-before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8)
-after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2)
-
-perm_t_test(x = before, y = after,
-            paired = TRUE,
-            alternative = "less",
-            R = 999)
    +
    # Small paired sample - exact permutations will be computed
+before <- c(5.1, 4.8, 6.2, 5.7, 6.0, 5.5, 4.9, 5.8)
+after <- c(5.6, 5.2, 6.7, 6.1, 6.5, 5.8, 5.3, 6.2)
+
+perm_t_test(x = before, y = after,
+            paired = TRUE,
+            alternative = "less",
+            R = 999)
    ## Computing all 256 exact permutations.
    ## 
 ##  Exact Permutation Paired t-test
 ## 
 ## data:  before and after
-## t-observed = -17, df = 7, p-value = 0.003891
+## t-observed = -17, df = 7, p-value < 2.2e-16
 ## alternative hypothesis: true difference in means is less than 0
 ## 95 percent confidence interval:
 ##     -Inf -0.3875
 ## sample estimates:
-## mean of the differences 
-##                  -0.425
    +## mean of the differences (z = x - y) +## -0.425

    Bootstrap t-test

    The boot_t_TOST function provides bootstrap-based -inference using the percentile bootstrap approach outlined by Efron and Tibshirani (1993) (see chapter 16). -The bootstrapped p-values are derived from the studentized version of a -test of mean differences. Overall, the results should be similar to -t_TOST but with greater robustness to distributional -violations.

    +inference using the approach outlined by Efron +and Tibshirani (1993) (see chapter +16). Overall, the results should be similar to t_TOST but +with greater robustness to distributional violations.

    Advantages of Bootstrapping

    Bootstrap methods offer several advantages for equivalence @@ -1741,22 +2010,57 @@

    Bootstrap Algorithm (Two-Sample Case)

  • \(n_x\) and \(n_y\) are the sample sizes
      • -
    1. An approximate p-value can then be calculated as the number of -bootstrapped results greater than the observed t-statistic from the -sample.
      2. +
    2. Confidence intervals and p-values are then computed from the +bootstrap distribution using the method specified by the +boot_ci argument.
    -

    \[ -p_{boot} = \frac {\#t(z^{*b}) \ge t_{sample}}{B} -\]

    -

    Where: - \(\#t(z^{*b}) \ge -t_{sample}\) is the count of bootstrap t-statistics that exceed -the observed t-statistic - B is the total number of bootstrap -replications

    The same process is completed for the one sample case but with the one sample solution for the equation outlined by \(t(z^{*b})\). The paired sample case in this bootstrap procedure is equivalent to the one sample solution because the test is based on the difference scores.

    +
    +

    Bootstrap CI Methods and P-value Consistency

    +

    Four bootstrap confidence interval methods are available (set via the +boot_ci argument):

    +
      +
    • Studentized (“stud”, default): Uses the bootstrap +distribution of pivotal t-statistics, \(t^{*b} += (\bar{x}^{*b} - \bar{x}) / se^{*b}\), to construct intervals +that account for variability in the standard error. This usually +provides the most accurate coverage.
      • +
    • Percentile (“perc”): Uses quantiles of the +bootstrap estimate distribution directly.
      • +
    • Basic (“basic”): Reflects the bootstrap estimate +distribution around the observed value.
      • +
    • Bias-corrected and accelerated (“bca”): Adjusts for +both bias and skewness in the bootstrap distribution using a +jackknife-based acceleration correction. Most accurate when the +bootstrap distribution is skewed.
      • +
    +

    Critically, the bootstrap p-value is now computed using the same +method as the confidence interval. This ensures that \(p < \alpha\) if and only if the \((1 - \alpha)\) CI excludes the null value +(CI inversion principle). For example, when +boot_ci = "perc" the p-value is based on the proportion of +bootstrap estimates on each side of the null:

    +

    \[ +p_{perc} = 2 \min\left(\frac{\#(x^{*b} \le \theta_0)}{B},\ +\frac{\#(x^{*b} \ge \theta_0)}{B}\right) +\]

    +

    while boot_ci = "stud" uses the corresponding pivot:

    +

    \[ +p_{stud} = 2 \min\left(\frac{\#(t^{*b} \ge t_{obs})}{B},\ +\frac{\#(t^{*b} \le t_{obs})}{B}\right) +\]

    +

    where \(t_{obs} = (\hat\theta - \theta_0) / +\hat{se}\).

    +

    In previous versions of the package, all bootstrap CI methods used +the studentized p-value regardless of the CI method selected. This could +produce p-values that disagreed with the CI (e.g., a percentile CI +excluding the null while the studentized p-value was non-significant, or +vice versa). The current implementation eliminates this +inconsistency.

    +

    Choosing the Number of Bootstrap Replications

    When using bootstrap methods, the choice of replications (the @@ -1778,17 +2082,17 @@

    Example

    We can use the sleep data to see the bootstrapped results. Notice that the plots show how the re-sampling via bootstrapping indicates the instability of Hedges’s dz.

    -
    data('sleep')
-
-# For paired tests with bootstrap methods, use separate vectors
-test1 = boot_t_TOST(x = sleep$extra[sleep$group == 1],
-                    y = sleep$extra[sleep$group == 2],
-                      paired = TRUE,
-                      eqb = .5,
-                    R = 499)
-
-
-print(test1)
    +
    data('sleep')
+
+# For paired tests with bootstrap methods, use separate vectors
+test1 = boot_t_TOST(x = sleep$extra[sleep$group == 1],
+                    y = sleep$extra[sleep$group == 2],
+                      paired = TRUE,
+                      eqb = .5,
+                    R = 499)
+
+
+print(test1)
    ## 
 ## Bootstrapped Paired t-test
 ## 
@@ -1808,23 +2112,27 @@ 
    Example
    
 ## Raw             -1.580 0.3786 [-3.0262, -1.0343]         0.9
 ## Hedges's g(z)   -1.174 0.7657   [-1.3935, 1.252]         0.9
 ## Note: studentized bootstrap ci method utilized.
    -
    plot(test1)
    -

    +
    plot(test1)
    +

    Interpreting Bootstrap TOST Results

    When interpreting the results of boot_t_TOST:

    1. The bootstrap p-values (p1 and p2) represent the empirical probability of observing the test statistic or -more extreme values under repeated sampling
      2. -
    2. The confidence intervals are derived directly from the empirical -distribution of bootstrap samples
      3. +more extreme values under repeated sampling, computed using a method +that matches the selected boot_ci +
    3. The confidence intervals are derived from the bootstrap distribution +using the selected method (studentized, percentile, basic, or BCa)
    4. The distribution plots provide visual insight into the variability of the effect size estimate
    -

    For equivalence testing, examine whether both bootstrap p-values are -significant (< alpha) and whether the confidence interval for the -effect size falls entirely within the equivalence bounds.

    +

    Because the p-values and CIs are computed with the same bootstrap +method, they will always agree: if the \((1 - +2\alpha)\) CI for the mean difference falls entirely within the +equivalence bounds, then both one-sided bootstrap p-values will be +significant at level \(\alpha\), and +vice versa.

    @@ -1832,30 +2140,30 @@

    Interpreting Bootstrap TOST Results

    Comparing Bootstrap and Permutation Approaches

    To illustrate the similarities and differences between these methods, let’s apply both to the same dataset:

    -
    # Same equivalence test using both methods
-data('sleep')
-
-# Bootstrap approach
-boot_result <- boot_t_test(extra ~ group, 
-                           data = sleep,
-                           alternative = "equivalence",
-                           mu = c(-2, 2),
-                           R = 999)
-
-# Permutation approach  
-perm_result <- perm_t_test(extra ~ group,
-                           data = sleep,
-                           alternative = "equivalence", 
-                           mu = c(-2, 2),
-                           R = 999)
    +
    # Same equivalence test using both methods
+data('sleep')
+
+# Bootstrap approach
+boot_result <- boot_t_test(extra ~ group, 
+                           data = sleep,
+                           alternative = "equivalence",
+                           mu = c(-2, 2),
+                           R = 999)
+
+# Permutation approach  
+perm_result <- perm_t_test(extra ~ group,
+                           data = sleep,
+                           alternative = "equivalence", 
+                           mu = c(-2, 2),
+                           R = 999)
    ## Note: Number of permutations (R = 999) is less than 1000. Consider increasing R for more stable p-value estimates.
    -
    # Compare results
-boot_result
    +
    # Compare results
+boot_result
    ## 
-##  Bootstrapped Welch Two Sample t-test
+##  Bootstrapped Welch Two Sample t-test (studentized)
 ## 
 ## data:  extra by group
-## t-observed = 0.49465, df = 17.776, p-value = 0.2903
+## t-observed = 0.49465, df = 17.776, p-value = 0.3073
 ## alternative hypothesis: equivalence
 ## null values:
 ## difference in means difference in means 
@@ -1863,11 +2171,13 @@ 
    Comparing Bootstrap and Permutation Approaches
    
 ## 90 percent confidence interval:
 ##  -3.0970524 -0.1114282
 ## sample estimates:
-## mean of x mean of y 
-##      0.75      2.33
    -
    perm_result
    +## mean of group '1' mean of group '2' +## 0.75 2.33 +## mean difference ('1' - '2') +## -1.58 +
    perm_result
    ## 
-##  Monte Carlo Permutation Welch Two Sample t-test
+##  Randomization Permutation Welch Two Sample t-test
 ## 
 ## data:  extra by group
 ## t-observed = 0.49465, df = 17.776, p-value = 0.307
@@ -1878,8 +2188,10 @@ 
    Comparing Bootstrap and Permutation Approaches
    
 ## 90 percent confidence interval:
 ##  -3.120 -0.078
 ## sample estimates:
-## mean of x mean of y 
-##      0.75      2.33
    +## mean of group '1' mean of group '2' +## 0.75 2.33 +## mean difference ('1' - '2') +## -1.58

    Both methods test the same hypothesis and should yield similar conclusions. Key differences to note:

      @@ -1904,7 +2216,7 @@

      Summary: Choosing Between Methods

      Feature Permutation (perm_t_test) -Bootstrap (boot_t_TOST) +Bootstrap (boot_t_TOST/boot_t_test) @@ -1921,14 +2233,19 @@

      Summary: Choosing Between Methods

      Trimmed means support Yes (tr argument) -No +Yes (tr argument in boot_t_test) +CI methods +Percentile +Studentized, percentile, basic, BCa + + Effect size plots No Yes - + Best for Small samples, exact inference Moderate samples, visualization @@ -1938,24 +2255,26 @@

      Summary: Choosing Between Methods

      For very small samples where exact permutations are feasible, permutation testing is generally preferred because it provides exact p-values (i.e., no need to set a seed). For larger samples or when you -want the visualization capabilities of boot_t_TOST, -bootstrapping is a good choice. When outliers are a concern, using -perm_t_test with trimming combines the benefits of exact -inference with robust location estimation.

      +want the visualization capabilities of boot_t_TOST or +boot_t_test, bootstrapping is a good choice. When outliers +are a concern, using perm_t_test with trimming combines the +benefits of exact inference with robust location estimation.

    Ratio of Difference (Log Transformed)

    In many bioequivalence studies, the differences between drugs are -compared on the log scale (He et al. -2022). The log scale allows researchers to compare the ratio of -two means.

    +compared on the log scale (He et al. 2022). The log scale allows +researchers to compare the ratio of two means.

    \[ log ( \frac{y}{x} ) = log(y) - log(x) \]

    -

    Where: - y and x are the means of the two groups being compared - The -transformation converts multiplicative relationships into additive -ones

    +

    Where:

    +
      +
    • y and x are the means of the two groups being compared
      • +
    • The transformation converts multiplicative relationships into +additive ones
      • +

    Why Use The Natural Log Transformation?

    The United @@ -1976,8 +2295,7 @@

    Why Use The Natural Log Transformation?

    absolute differences
  • It often makes right-skewed distributions more symmetric
  • It stabilizes variance when variability increases with the mean
    • -
  • It provides an easy-to-interpret interpretable effect size (ratio of -means)
    • +
  • It provides an easy-to-interpret effect size (ratio of means)

    • In addition, the FDA considers two drugs as bioequivalent when the ratio between x and y is less than 1.25 and greater than 0.8 (1/1.25), @@ -2007,10 +2325,10 @@

    log_TOST

    For example, we could compare whether the cars of different transmissions are “equivalent” with regards to gas mileage. We can use the default equivalence bounds (eqb = 1.25).

    -
    log_TOST(
-  mpg ~ am,
-  data = mtcars
-)
    +
    log_TOST(
+  mpg ~ am,
+  data = mtcars
+)
    ## 
 ## Log-transformed Welch Two Sample t-test
 ## 
@@ -2058,11 +2376,11 @@ 
    Bootstrap + Log
    
 bootstrapped tests be utilized instead. Therefore, the
 boot_log_TOST function can be utilized to perform a more
 precise test.
    
-
    boot_log_TOST(
-  mpg ~ am,
-  data = mtcars,
-  R = 499
-)
    
+
    boot_log_TOST(
+  mpg ~ am,
+  data = mtcars,
+  R = 499
+)
    
 
    ## 
 ## Bootstrapped Log Welch Two Sample t-test
 ## 
@@ -2078,9 +2396,9 @@ 
    Bootstrap + Log
    
 ## TOST Upper -6.288 23.96 < 0.001
 ## 
 ## Effect Sizes 
-##                  Estimate      SE              C.I. Conf. Level
-## log(Means Ratio)  -0.3466 0.08487 [-0.532, -0.1774]         0.9
-## Means Ratio        0.7071 0.06060  [0.5874, 0.8375]         0.9
+##                  Estimate      SE             C.I. Conf. Level
+## log(Means Ratio)  -0.3466 0.08487  [-0.4994, -0.2]         0.9
+## Means Ratio        0.7071 0.06060 [0.6069, 0.8187]         0.9
 ## Note: studentized bootstrap ci method utilized.
    
 
    The bootstrapped version is particularly recommended when:
    
 
      
@@ -2088,60 +2406,341 @@ 
      Bootstrap + Log
      
 
    • Data show notable deviations from log-normality
      • 
 
    • You want to ensure robust confidence intervals
      • 
 
    
+
    Like boot_t_TOST, the boot_log_TOST
+function supports multiple bootstrap CI methods (studentized,
+percentile, basic, and BCa) via the boot_ci argument, with
+matched p-values that are guaranteed to agree with the CI. All bootstrap
+computations are performed on the log scale, then back-transformed.
    
+
    +
    +
    +

    Standardized, Rank-Based, Effect Sizes: Estimation and Testing

    +

    The ses_calc and boot_ses_calc functions +calculate rank based standardized effect sizes (rank-biserial +correlation, WMW odds, concordance probability, or log-odds) with +confidence intervals5. As of v0.9.0, ses_calc also +supports hypothesis testing directly on the effect size scale.

    +
    +

    Available Effect Sizes

    +
    +

    Rank-Biserial Correlation

    +

    The rank-biserial correlation is a fairly intuitive measure of effect +size which has a similar interpretation as the common language effect +size (Kerby +2014). However, instead of assuming normality and equal +variances, it calculates the number of favorable (positive) and +unfavorable (negative) pairs based on their respective ranks.

    +

    For the two sample case, the correlation is calculated as the +proportion of favorable pairs minus the unfavorable pairs.

    +

    \[ +r_{biserial} = f_{pairs} - u_{pairs} +\]

    +

    Where: - \(f_{pairs}\) is the +proportion of favorable pairs - \(u_{pairs}\) is the proportion of +unfavorable pairs

    +

    For the one sample or paired samples cases, the correlation is +calculated with ties (values equal to zero) not being dropped. This +provides a conservative estimate of the rank biserial +correlation.

    +

    It is calculated in the following steps wherein \(z\) represents the values or difference +between paired observations:

    +
      +
    1. Calculate signed ranks:
      2. +
    +

    \[ +r_j = -1 \cdot sign(z_j) \cdot rank(|z_j|) +\]

    +

    Where: - \(r_j\) is the signed rank +for observation \(j\) - \(sign(z_j)\) is the sign of observation +\(z_j\) (+1 or -1) - \(rank(|z_j|)\) is the rank of the absolute +value of observation \(z_j\)

    +
      +
    1. Calculate the positive and negative sums:
      2. +
    +

    \[ + R_{+} = \sum_{1\le i \le n, \space z_i > 0}r_j +\]

    +

    \[ + R_{-} = \sum_{1\le i \le n, \space z_i < 0}r_j +\]

    +

    Where: - \(R_{+}\) is the sum of +ranks for positive observations - \(R_{-}\) is the sum of ranks for negative +observations

    +
      +
    1. Determine the smaller of the two rank sums:
      2. +
    +

    \[ +T = min(R_{+}, \space R_{-}) +\]

    +

    \[ +S = \begin{cases} -4 & R_{+} \ge R_{-} \\ 4 & R_{+} < R_{-} +\end{cases} +\]

    +

    Where: - \(T\) is the smaller of the +two rank sums - \(S\) is a sign factor +based on which rank sum is smaller

    +
      +
    1. Calculate rank-biserial correlation:
      2. +
    +

    \[ +r_{biserial} = S \cdot | \frac{\frac{T - \frac{(R_{+} + +R_{-})}{2}}{n}}{n + 1} | +\]

    +

    Where: - \(n\) is the number of +observations (or pairs) - The final value ranges from -1 to 1

    +
    +

    Concordance Probability

    +

    The concordance probability (also known as the c-statistic, c-index, +or probability of superiority6) is converted from the rank-biserial +correlation:

    +

    \[ +c = \frac{(r_{biserial} + 1)}{2} +\]

    +

    The c-statistic can be interpreted as the probability that a randomly +selected observation from one group will be greater than a randomly +selected observation from another group. A value of 0.5 indicates no +difference between groups, while values approaching 1 indicate perfect +separation between groups.

    +

    Please note that the c-statistic is equivalent to the area under the +receiver operating characteristic curve (AUC) in binary classification +contexts. For independent two-sample designs, the c-statistic estimates +the same quantity as that produced by brunner_munzel: P(X +> Y), the probability that a randomly selected observation from one +group exceeds a randomly selected observation from the other. However, +for paired samples and one-sample designs, the c-statistic from the +Wilcoxon test is based on the difference scores rather than the +cross-group comparison, estimating P(Z > 0), where Z (Z = X - Y) +represents the paired differences (or deviations from the null value). +Additionally, the confidence interval and standard error methods differ +between brunner_munzel and the c-statistic reported +here.

    +
    +
    +

    WMW Odds

    +

    The Wilcoxon-Mann-Whitney odds (O’Brien and Castelloe 2006), also known +as the “Generalized Odds Ratio”7 (Agresti 1980), is calculated by +converting the c-statistic:

    +

    \[ +WMW_{odds} = e^{logit(c)} +\]

    +

    Where \(logit(c) = +\ln\frac{c}{1-c}\)

    +

    The WMW odds can be interpreted similarly to a traditional odds +ratio, representing the odds that an observation from one group is +greater than an observation from another group.

    -
    -

    Just Estimate an Effect Size

    -

    It was requested that a function be provided that only calculates a -robust effect size. Therefore, I created the ses_calc and -boot_ses_calc functions as robust effect size calculation5. The -interface is almost the same as wilcox_TOST but you don’t -set an equivalence bound.

    -
    # For paired tests, use separate vectors
-ses_calc(x = sleep$extra[sleep$group == 1],
-         y = sleep$extra[sleep$group == 2],
-         paired = TRUE,
-         ses = "r")
    -
    ##                            estimate lower.ci  upper.ci conf.level
-## Rank-Biserial Correlation 0.9818182 0.928369 0.9954785       0.95
    -
    # Setting bootstrap replications low to
-## reduce compiling time of vignette
-boot_ses_calc(x = sleep$extra[sleep$group == 1],
-              y = sleep$extra[sleep$group == 2],
-         paired = TRUE,
-         R = 199,
-         boot_ci = "perc", # recommend percentile bootstrap for paired SES
-         ses = "r")
    -
    ## Bootstrapped results contain extreme results (i.e., no overlap), caution advised interpreting confidence intervals.
    -
    ##    estimate bias         SE  lower.ci upper.ci conf.level boot_ci
-## 1 0.9818182    0 0.02926873 0.8909091        1       0.95    perc
    -
    -

    Choosing Between Different Bootstrap CI Methods

    -

    The boot_ses_calc function offers several bootstrap -confidence interval methods through the boot_ci -parameter:

    +
    +

    Guidelines for Selecting Effect Size Measures

      -
    • “perc” (Percentile): Simple and intuitive, works -well for symmetric distributions
      • -
    • “basic”: Similar to percentile but adjusts for -bias, more conservative
      • -
    • “stud” (studentized): uses the standard error of -each bootstrap sample, more accurate for skewed distributions
      • +
    • Rank-biserial correlation ("rb") is +useful when you want a correlation-like measure that’s easily +interpretable and comparable to other correlation coefficients.
      • +
    • Concordance probability ("cstat") is +beneficial when you want to express the effect in terms of probability, +making it accessible to non-statisticians.
      • +
    • WMW odds ("odds") is helpful when you +want to express the effect in terms familiar to those who work with odds +ratios in logistic regression or epidemiology, or interpreting +probabilities as odds (e.g., betting and prediction markets).
      • +
    • WMW log-odds ("logodds") the log-odds +can be helpful because you could interpret them as a percent +difference/change in the odds of stochastic superiority. E.g., if the +WMW log-odds were 0.10 then you could say “X increases the odds of +superiority by approximately 10% over Y”.
    +
    +

    Confidence Interval Methods

    +

    As of v0.9.0, the TOSTER package defaults to the score +method (se_method = "score") for computing standard errors +and confidence intervals for all SES functions (see function +documentation for more information). There is also the +Agresti method. This method uses placement-based +variance estimation and conducts inference on the log-odds scale, which +performs fairly well when the degree of seperation between groups is not +high. Results are back-transformed to the requested effect size scale +for reporting. The Fisher z-transformation method +(se_method = "fisher") remains available as a legacy +option. This was the default in earlier versions of the package and is +documented below for reference.

    +
    +

    Fisher z-Transformation (Legacy Method)

    +

    The Fisher approximation calculates confidence intervals by first +computing a standard error, then transforming to a Fisher z-scale for +interval construction.

    +

    For paired samples, or one sample, the standard error is calculated +as:

    +

    \[ +SE_r = \sqrt{ \frac {(2 \cdot nd^3 + 3 \cdot nd^2 + nd) / 6} {(nd^2 + +nd) / 2} } +\]

    +

    wherein, nd represents the total number of observations (or +pairs).

    +

    For independent samples, the standard error is:

    +

    \[ +SE_r = \sqrt{\frac {(n1 + n2 + 1)} { (3 \cdot n1 \cdot n2)}} +\]

    +

    Where:

    +
      +
    • \(n1\) and \(n2\) are the sample sizes of the two +groups
      • +
    +

    The confidence intervals are then calculated by transforming the +estimate:

    +

    \[ +r_z = atanh(r_{biserial}) +\]

    +

    Then the confidence interval can be calculated and back +transformed:

    +

    \[ +r_{CI} = tanh(r_z \pm Z_{(1 - \alpha / 2)} \cdot SE_r) +\]

    +

    Where:

    +
      +
    • \(Z_{(1 - \alpha / 2)}\) is the +critical value from the standard normal distribution
      • +
    • \(\alpha\) is the significance +level (typically 0.05)
      • +
    +
    +
    +
    +

    Effect Size Estimation

    +

    The interface is similar to wilcox_TOST, but rather than +setting equivalence bounds on the raw scale, ses_calc works +directly with the standardized effect size. By default (with +alternative = "none"), it returns an effect size estimate +and confidence interval with no hypothesis test:

    +
    # Rank-biserial correlation for paired data
+ses_calc(x = sleep$extra[sleep$group == 1],
+         y = sleep$extra[sleep$group == 2],
+         paired = TRUE,
+         ses = "rb")
    +
    ## 
+##  Paired Sample Rank-Biserial Correlation estimate with CI
+## 
+## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
+## 
+## alternative hypothesis: none
+## 95 percent confidence interval:
+##  -1.0000000 -0.2989533
+## sample estimates:
+## P(X - Y>0) - P(X - Y<0) 
+##                      -1
    +
    +
    +

    Hypothesis Testing with ses_calc

    +

    As of v0.9.0, ses_calc supports hypothesis testing +directly on the effect size scale by setting the +alternative argument. This allows you to test whether a +non-parametric effect size differs from a specified value, or whether it +falls within equivalence bounds, without needing the raw-scale +equivalence bounds required by wilcox_TOST.

    +
    # Two-sided test: does the rank-biserial differ from 0?
+ses_calc(x = sleep$extra[sleep$group == 1],
+         y = sleep$extra[sleep$group == 2],
+         paired = TRUE,
+         ses = "rb",
+         alternative = "two.sided")
    +
    ## 
+##  Paired Sample Rank-Biserial Correlation test
+## 
+## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
+## z = -2.6679, p-value = 0.007632
+## alternative hypothesis: true P(X - Y>0) - P(X - Y<0) is not equal to 0
+## 95 percent confidence interval:
+##  -1.0000000 -0.2989533
+## sample estimates:
+## P(X - Y>0) - P(X - Y<0) 
+##                      -1
    +
    +

    Equivalence Testing on the Effect Size Scale

    +

    One advantage of testing directly on the effect size scale is that +equivalence bounds have a more intuitive interpretation much like the +brunner_munzel test. In fact, you should probably use the +brunner_munzel approach for the two-sample case, but the +ses_calc functions allow for comparison of paired samples +and one-sample case in what that the Brunner-Munzel approach does not +allow. Rather than specifying bounds in raw units (which depends on the +location-shift assumption), you can specify bounds directly in terms of +the effect size:

    +
    # Equivalence test: is the rank-biserial within [-0.3, 0.3]?
+ses_calc(x = sleep$extra[sleep$group == 1],
+         y = sleep$extra[sleep$group == 2],
+         paired = TRUE,
+         ses = "rb",
+         alternative = "equivalence",
+         null.value = c(-0.3, 0.3))
    +
    ## 
+##  Paired Sample Rank-Biserial Correlation test
+## 
+## data:  sleep$extra[sleep$group == 1] and sleep$extra[sleep$group == 2]
+## z = -1.9577, p-value = 0.9749
+## alternative hypothesis: equivalence
+## null values:
+## lower bound upper bound 
+##        -0.3         0.3 
+## 90 percent confidence interval:
+##  -1.0000000 -0.4491576
+## sample estimates:
+## P(X - Y>0) - P(X - Y<0) 
+##                      -1
    +

    When using ses_calc for hypothesis testing, the +se_method argument (described in the Confidence Interval Methods +section above) also controls how test statistics are computed. The +default Agresti method conducts tests on the log-odds scale, while the +Fisher method uses z-transformation. See above for details.

    +
    # Using the Agresti method (default) with WMW odds
+ses_calc(formula = extra ~ group,
+         data = sleep,
+         ses = "odds",
+         alternative = "two.sided")
    +
    ## 
+##  Two Sample WMW Odds test
+## 
+## data:  extra by group
+## z = -1.8541, p-value = 0.06372
+## alternative hypothesis: true odds(P('1'>'2') + .5*P('1'='2')) is not equal to 1
+## 95 percent confidence interval:
+##  0.1185837 1.0570531
+## sample estimates:
+## odds(P('1'>'2') + .5*P('1'='2')) 
+##                        0.3422819
    +
    +
    +
    +

    Bootstrap Based Effect Size Testing with +boot_ses_calc

    +

    When asymptotic approximations may be unreliable, particularly with +small samples, boot_ses_calc uses bootstrapping to estimate +the sampling distribution of the effect size. Note that bootstrap +methods cannot work in situations where there is complete separation +between groups (e.g., all values in one group are higher than the +other), which can occur with small samples and large effects.

    +

    Like the other bootstrap functions in the package, +boot_ses_calc supports multiple bootstrap CI methods +(studentized, percentile, basic, and BCa) via boot_ci, with +p-values matched to the selected CI method for guaranteed CI/p-value +agreement. All bootstrap computations are performed on a working scale +then back-transformed to the requested effect size scale.

    +
    +

    Summary Comparison of Robust TOST Methods

    ----+++++ + @@ -2149,47 +2748,71 @@

    Summary Comparison of Robust TOST Methods

    - + + - - + + + - + + + + + + + + - - + + + - - - + + + + - + - + + + + + + + + +
    MethodEstimand Key Advantages Limitations Best Use Cases
    Wilcoxon TOSTWilcoxon-Mann-WhitneyPseudo-median of pairwise differences (two-sample) or Walsh averages +(paired) Simple, widely acceptedAmbiguous hypothesis; not about means or medianslegacy analysesEstimand \(\neq\) mean or median +difference without location shift assumptionOrdinal data; legacy analyses
    Brunner-Munzel\(P(X > Y) + 0.5 \cdot P(X = +Y)\) Clear interpretation, robust to heteroscedasticityComputationally intensive with permutationNot a location measure Stochastic superiority/dominance
    Hodges-LehmannSame as WMW, with Fried-Dehling inferenceRobust location, outlier resistantSame estimand caveats as WMW; inference differs from +wilcox_TOSTRobust location shift testing with outlier protection
    Permutation t-testExact p-values (small samples), supports trimmed meansComputationally intensive for large samples\(\mu_X - \mu_Y\) (or trimmed means +if tr > 0)Exact p-values, direct mean comparisonOutlier sensitive (unless trimmed) Mean differences with small samples
    Bootstrap TOSTFlexible, visualization of effect distributions
    Bootstrap t-test\(\mu_X - \mu_Y\)Flexible, visualization Results vary between runs Mean differences with moderate samples
    Log-TransformedFocuses on relative differences, stabilizes variance\(\log(\mu_Y / \mu_X)\)Ratio-based, stabilizes variance Requires positive data Bioequivalence, ratio comparisons
    **SES calc*Non-parametric effect sizes (rank-biserial, concordance, odds)Tests directly on effect size scaleRequires large samples (asymptotic) or many replicatesNon-parametric effect size testing

    Conclusion

    The robust TOST procedures provided in the TOSTER package offer -reliable alternatives to standard parametric equivalence testing when +reliable alternatives to standard t-test based equivalence testing when data violate typical assumptions. By selecting the appropriate robust method for your specific data characteristics and research question, you can ensure more valid statistical inferences about equivalence or minimal effects.

    -

    Remember that no single method is universally superior - the choice +

    Remember that no single method is universally superior — the choice depends on your data structure, sample size, and specific research question. When in doubt, running multiple approaches and comparing results can provide valuable insights into the robustness of your @@ -2202,22 +2825,43 @@

    References

    Agresti, Alan. 1980. “Generalized Odds Ratios for Ordinal Data.” Biometrics, 59–67. https://doi.org/10.2307/2530495.
    +
    +Brunner, Edgar, and Ullrich Munzel. 2000. “The Nonparametric +Behrens-Fisher Problem: Asymptotic Theory and a Small-Sample +Approximation.” Biometrical Journal 42 (1): 17–25. https://doi.org/10.1002/(sici)1521-4036(200001)42:1<17::aid-bimj17>3.0.co;2-u. +
    Chung, EunYi, and Joseph P. Romano. 2013. “Exact and Asymptotically Robust Permutation Tests.” The Annals of Statistics 41 (2). https://doi.org/10.1214/13-aos1090.
    +
    +Divine, George W, H James Norton, Anna E Barón, and Elizabeth +Juarez-Colunga. 2018. “The Wilcoxon–Mann–Whitney Procedure Fails +as a Test of Medians.” The American Statistician 72 (3): +278–86. https://doi.org/10.1080/00031305.2017.1305291. +
    Efron, Bradley, and Robert J. Tibshirani. 1993. An Introduction to the Bootstrap. Monographs on Statistics and Applied Probability 57. Boca Raton, Florida, USA: Chapman & Hall/CRC.
    +
    +Fried, Roland, and Herold Dehling. 2011. “Robust Nonparametric +Tests for the Two-Sample Location Problem.” Stat. Methods +Appt. 20 (4): 409–22. +
    He, Y, Y Deng, C You, and X H Zhou. 2022. “Equivalence Tests for Ratio of Means in Bioequivalence Studies Under Crossover Designs.” Statistical Methods in Medical Research, 09622802221093721. https://doi.org/10.1177/09622802221093721.
    +
    +Hodges, Joseph L, and Erich L Lehmann. 1963. “Estimates of +Location Based on Rank Tests.” The Annals of Mathematical +Statistics 34 (2): 598–611. https://doi.org/10.1214/aoms/1177704172. +
    Janssen, Arnold. 1997. “Studentized Permutation Tests for Non-i.i.d. Hypotheses and the Generalized Behrens-Fisher @@ -2235,31 +2879,56 @@

    References

    to Teaching Nonparametric Correlation.”     Comprehensive Psychology 3 (January): 11.IT.3.1. https://doi.org/10.2466/11.it.3.1.
    +
    +Munzel, Ullrich, and Dieter Hauschke. 2003. “A Nonparametric Test +for Proving Noninferiority in Clinical Trials with Ordered Categorical +Data.” Pharm. Stat. 2 (1): 31–37. +
    +
    +Neubert, Karin, and Edgar Brunner. 2007. “A Studentized +Permutation Test for the Non-Parametric Behrensfisher +Problem.” Computational Statistics and Data Analysis 51 +(10): 5192–5204. https://doi.org/10.1016/j.csda.2006.05.024. +
    O’Brien, Ralph G, and John Castelloe. 2006. “Exploiting the Link Between the Wilcoxon-Mann-Whitney Test and a Simple Odds Statistic,” 209–31.
    +
    +Phipson, Belinda, and Gordon K Smyth. 2010. “Permutation p-Values +Should Never Be Zero: Calculating Exact p-Values When Permutations Are +Randomly Drawn.” Statistical Applications in Genetics and +Molecular Biology 9 (1). https://doi.org/10.2202/1544-6115.1585. +
      -

    1. Directly inspired by this blog post from Professor Frank -Harrell https://hbiostat.org/blog/post/wpo/↩︎

      2. -

    2. I would like to note that I think the statistical +

    3. I would like to note that I think the statistical properties of the WMW tests are sound, and Frank Harrell has written many blogposts outlining their -sound application in biomedicine.↩︎

      4. +sound application in biomedicine.↩︎

      +

    4. In the literature you will often see it denoted as +P(X<Y) however, in R the typical convention is x - y (e.g., +t.test) so for consistency we have flipped the direction to +P(X>Y).↩︎

    5. This means the relative effect will not match -the concordance probability provided by ses_calc.↩︎

      6. +the concordance probability provided by ses_calc for paired +samples.↩︎

    6. Food and Drug Administration (2014). Bioavailability and Bioequivalence Studies Submitted in NDAs or INDs — General Considerations.Center for Drug Evaluation and Research. Docket: FDA-2014-D-0204↩︎

      7. -

    7. The results differ greatly because the bootstrap CI -method, basic bootstrap, is more conservative than the parametric +

    8. The results from ses_calc and +boot_ses_calc can differ substantially because the +bootstrap CI method is typically more conservative than the asymptotic method. This difference is more apparent with extremely small samples like that in the sleep dataset.↩︎

      9. +

    9. Directly inspired by this blog post from Professor Frank +Harrell https://hbiostat.org/blog/post/wpo/↩︎

      10. +

    10. As noted by my frequent collaborator this name is quite +weird since it is not a ratio of odds… but simply an odds!↩︎

    diff --git a/vignettes/the_ftestTOSTER.Rmd b/vignettes/the_ftestTOSTER.Rmd index be3f259..ed5c698 100644 --- a/vignettes/the_ftestTOSTER.Rmd +++ b/vignettes/the_ftestTOSTER.Rmd @@ -1,6 +1,7 @@ --- title: "Equivalence Testing for F-tests" author: "Aaron R. Caldwell" +link-citations: true date: "`r Sys.Date()`" output: rmarkdown::html_vignette: diff --git a/vignettes/the_ftestTOSTER.html b/vignettes/the_ftestTOSTER.html index e6fb7b2..9092efb 100644 --- a/vignettes/the_ftestTOSTER.html +++ b/vignettes/the_ftestTOSTER.html @@ -12,7 +12,7 @@ - + Equivalence Testing for F-tests @@ -364,7 +364,7 @@

    Equivalence Testing for F-tests

    Aaron R. Caldwell

    -

    2026-01-05

    +

    2026-02-19

    @@ -415,9 +415,9 @@

    Introduction

    or meaningfully similar.

    For an open access tutorial paper explaining how to set equivalence bounds, and how to perform and report equivalence testing for ANOVA -models, see Campbell and Lakens (2021). -These functions are designed for omnibus tests, and additional testing -may be necessary for specific comparisons between groups or conditions1.

    +models, see Campbell and Lakens (2021). These functions are designed +for omnibus tests, and additional testing may be necessary for specific +comparisons between groups or conditions1.

    The Theory Behind F-test Equivalence Testing

    @@ -635,7 +635,7 @@

    Visualizing Partial Eta-Squared

    plot_pes(Fstat = 34.70228,
          df1 = 5,
          df2 = 66)
    -

    +

    The plots show:

    1. Top plot (Confidence curve): The relationship @@ -702,7 +702,7 @@

      A Second Example: Small Effect

      # Visualize plot_pes(Fstat = 2.36, df1 = 2, df2 = 87)
    -

    +

    In this example: 1. The traditional ANOVA shows a marginally significant effect (p = 0.07) 2. The partial eta-squared (0.051) is smaller than our equivalence bound 3. The equivalence test is