├── .Rbuildignore ├── .gitattributes ├── .github ├── .gitignore ├── ISSUE_TEMPLATE │ ├── Bug_report.md │ └── Feature_request.md └── workflows │ ├── check-standard.yaml │ ├── rhub.yaml │ └── test-coverage.yaml ├── .gitignore ├── COPYING ├── DEPENDENCIES.ubuntu ├── DESCRIPTION ├── NAMESPACE ├── NEWS ├── R ├── RcppExports.R ├── are.paired.R ├── auc.R ├── bootstrap.R ├── ci.R ├── ci.auc.R ├── ci.coords.R ├── ci.se.R ├── ci.sp.R ├── ci.thresholds.R ├── coords.R ├── cov.R ├── delong.R ├── geom_polygon_auc.R ├── ggroc.R ├── groupGeneric.R ├── has.partial.auc.R ├── lines.roc.R ├── multiclass.R ├── null.roc.R ├── obuchowski.R ├── onLoad.R ├── plot.ci.R ├── plot.roc.R ├── power.roc.test.R ├── print.R ├── roc.R ├── roc.test.R ├── roc.utils.R ├── roc.utils.percent.R ├── smooth.R ├── var.R └── venkatraman.R ├── README.md ├── appveyor.yml ├── codecov.yml ├── data └── aSAH.RData ├── inst ├── CITATION └── extra │ ├── bench │ ├── fig-unnamed-chunk-13-1.png │ ├── fig-unnamed-chunk-5-1.png │ └── fig-unnamed-chunk-9-1.png │ ├── benchmark.Rmd │ ├── benchmark.md │ └── sos_clashes.R ├── man ├── aSAH.Rd ├── are.paired.Rd ├── auc.Rd ├── ci.Rd ├── ci.auc.Rd ├── ci.coords.Rd ├── ci.se.Rd ├── ci.sp.Rd ├── ci.thresholds.Rd ├── coords.Rd ├── coords_transpose.Rd ├── cov.Rd ├── geom_polygon_auc.roc.Rd ├── ggroc.Rd ├── groupGeneric.Rd ├── has.partial.auc.Rd ├── lines.roc.Rd ├── multiclass.Rd ├── pROC-package.Rd ├── plot.ci.Rd ├── plot.roc.Rd ├── power.roc.test.Rd ├── print.Rd ├── roc.Rd ├── roc.test.Rd ├── smooth.Rd └── var.Rd ├── pROC.Rproj ├── run_revdep.R ├── src ├── RcppExports.cpp ├── RcppVersion.cpp └── delong.cpp └── tests ├── testthat.R └── testthat ├── _snaps ├── geom_polygon_auc │ ├── geom-polygon-auc-partial-screenshot.svg │ ├── geom-polygon-auc-percent-legacy-screenshot.svg │ └── geom-polygon-auc-screenshot.svg ├── ggroc │ ├── ggroc-list-colour.svg │ ├── ggroc-list-extra-aes-screenshot.svg │ ├── ggroc-list-group-facet-screenshot.svg │ ├── ggroc-list-multi-aes.svg │ ├── ggroc-list-scale-colour-manual.svg │ ├── ggroc-list-screenshot.svg │ ├── ggroc-screenshot-base.svg │ ├── ggroc-screenshot-legacy.svg │ ├── ggroc-screenshot-percent-legacy.svg │ ├── ggroc-screenshot-percent.svg │ ├── ggroc-screenshot.svg │ ├── ggroc-smooth-list-screenshot.svg │ └── ggroc-smooth-screenshot.svg └── plot │ ├── advanced-screenshot-1.svg │ ├── advanced-screenshot-2.svg │ ├── advanced-screenshot-3.svg │ ├── advanced-screenshot-4.svg │ ├── advanced-screenshot-5.svg │ ├── advanced-screenshot-6.svg │ ├── basic-ndka.svg │ ├── basic-s100b.svg │ ├── basic-wfns.svg │ ├── legacy-axes.svg │ ├── plot-formula.svg │ └── plot-pr.svg ├── helper-coords-expected-smooth.R ├── helper-coords-expected.R ├── helper-deLongPlacementsCpp-expected.R ├── helper-expect_equal_roc.R ├── helper-expectations.R ├── helper-roc-expected.R ├── helper-roc.utils-expected.R ├── helper-rocs.R ├── helper-skip.R ├── helper-vdiffr.R ├── print_output ├── multiclass ├── multiclass_levels ├── multiclass_partial ├── multiclass_partial_correct ├── multiclass_partial_se ├── multiclass_percent ├── mv_multiclass ├── mv_multiclass.ndka.formula ├── mv_multiclass_levels ├── mv_multiclass_partial ├── mv_multiclass_partial_correct ├── mv_multiclass_partial_se ├── mv_multiclass_percent ├── ndka_formula ├── ndka_formula_attached ├── ndka_formula_var ├── ndka_formula_var_attached ├── r.ndka ├── r.ndka.ci.auc ├── r.ndka.ci.coords ├── r.ndka.ci.se ├── r.ndka.ci.sp ├── r.ndka.ci.thresholds ├── r.ndka.formula ├── r.ndka.formula.ci ├── r.ndka.formula.no_auc ├── r.ndka.partial1 ├── r.ndka.percent ├── r.ndka.percent.partial1 ├── r.s100b ├── r.s100b.partial1 ├── r.s100b.partial2 ├── r.s100b.percent ├── r.s100b.percent.partial1 ├── r.wfns ├── r.wfns.partial1 ├── r.wfns.percent ├── r.wfns.percent.partial1 ├── roc.test-venkatraman.paired ├── roc.test-venkatraman.unpaired ├── roc.test-venkatraman.unpaired.unstratified ├── roc.test-venkatraman.unstratified ├── smooth.ndka ├── smooth.s100b.binormal ├── smooth.s100b.density ├── smooth.s100b.fitdistr ├── smooth.s100b.formula ├── smooth.s100b.logcondens ├── smooth.s100b.logcondens.smooth └── smooth.wfns ├── test-Ops.R ├── test-are-paired.R ├── test-auc.R ├── test-ci.auc.R ├── test-ci.coords.R ├── test-ci.formula.R ├── test-ci.se.R ├── test-ci.sp.R ├── test-ci.thresholds.R ├── test-coords.R ├── test-cov.R ├── test-deLongPlacementsCpp.R ├── test-geom_polygon_auc.R ├── test-ggroc.R ├── test-large.R ├── test-multiclass.R ├── test-numeric-Inf.R ├── test-numeric-accuracy.R ├── test-onload.R ├── test-plot.R ├── test-power.roc.test.R ├── test-print.R ├── test-roc.R ├── test-roc.test-venkatraman.R ├── test-roc.test.R ├── test-roc.utils.R ├── test-roc.utils.percent.R ├── test-smooth.R └── test-var.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^appveyor\.yml$ 2 | ^.*\.Rproj$ 3 | ^\.Rproj\.user$ 4 | ^packrat/ 5 | ^\.Rprofile$ 6 | pROC-Ex.R 7 | .travis.yml 8 | codecov.yml 9 | ^\.github 10 | ^revdep 11 | ^DEPENDENCIES* 12 | ^\.github$ 13 | ^COPYING$ 14 | ^run_revdep.R$ 15 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Set default behaviour, in case users don't have core.autocrlf set. 2 | * text=auto 3 | 4 | # Denote all files that are truly binary and should not be modified. 5 | *.RData binary 6 | 7 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/Bug_report.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Bug report 3 | about: Create a report to help us improve 4 | 5 | --- 6 | 7 | **Describe the bug** 8 | A clear and concise description of what the bug is. 9 | 10 | **To Reproduce** 11 | Steps to reproduce the behavior: 12 | 1. What packages were loaded? Run `sessionInfo()` and report the output. 13 | 2. What command did you run? 14 | 3. What data did you use? Use `save(myData, file="data.RData")` or `save.image("data.RData")` 15 | 4. What error or output did you get? 16 | 17 | **Expected behavior** 18 | A clear and concise description of what you expected to happen. 19 | 20 | **Additional context** 21 | Add any other context about the problem here. 22 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE/Feature_request.md: -------------------------------------------------------------------------------- 1 | --- 2 | name: Feature request 3 | about: Suggest an idea for this project 4 | 5 | --- 6 | 7 | **Is your feature request related to a problem? Please describe.** 8 | A clear and concise description of what the problem is. Ex. I often need to [...] 9 | 10 | **Describe the solution you'd like** 11 | A clear and concise description of what you want to happen. Is there already an algorithm to do it? 12 | 13 | **Describe alternatives you've considered** 14 | A clear and concise description of any alternative solutions or features you've considered. 15 | 16 | **Additional context** 17 | Add any other context, screenshot or code about the feature request here. 18 | -------------------------------------------------------------------------------- /.github/workflows/check-standard.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: [push, pull_request] 4 | 5 | name: R-CMD-check 6 | 7 | jobs: 8 | R-CMD-check: 9 | runs-on: ${{ matrix.config.os }} 10 | 11 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 12 | 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | config: 17 | - {os: macos-latest, r: 'release'} 18 | - {os: windows-latest, r: 'release'} 19 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 20 | - {os: ubuntu-latest, r: 'release'} 21 | - {os: ubuntu-latest, r: 'oldrel-1'} 22 | 23 | env: 24 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 25 | R_KEEP_PKG_SOURCE: yes 26 | RUN_SLOW_TESTS: true 27 | 28 | steps: 29 | - uses: actions/checkout@v4 30 | 31 | - uses: r-lib/actions/setup-pandoc@v2 32 | 33 | - uses: r-lib/actions/setup-r@v2 34 | with: 35 | r-version: ${{ matrix.config.r }} 36 | http-user-agent: ${{ matrix.config.http-user-agent }} 37 | use-public-rspm: true 38 | 39 | - uses: r-lib/actions/setup-r-dependencies@v2 40 | with: 41 | extra-packages: any::rcmdcheck 42 | needs: check 43 | 44 | - uses: r-lib/actions/check-r-package@v2 45 | with: 46 | upload-snapshots: true 47 | -------------------------------------------------------------------------------- /.github/workflows/rhub.yaml: -------------------------------------------------------------------------------- 1 | # R-hub's generic GitHub Actions workflow file. It's canonical location is at 2 | # https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml 3 | # You can update this file to a newer version using the rhub2 package: 4 | # 5 | # rhub::rhub_setup() 6 | # 7 | # It is unlikely that you need to modify this file manually. 8 | 9 | name: R-hub 10 | run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}" 11 | 12 | on: 13 | workflow_dispatch: 14 | inputs: 15 | config: 16 | description: 'A comma separated list of R-hub platforms to use.' 17 | type: string 18 | default: 'linux,windows,macos' 19 | name: 20 | description: 'Run name. You can leave this empty now.' 21 | type: string 22 | id: 23 | description: 'Unique ID. You can leave this empty now.' 24 | type: string 25 | 26 | jobs: 27 | 28 | setup: 29 | runs-on: ubuntu-latest 30 | outputs: 31 | containers: ${{ steps.rhub-setup.outputs.containers }} 32 | platforms: ${{ steps.rhub-setup.outputs.platforms }} 33 | 34 | steps: 35 | # NO NEED TO CHECKOUT HERE 36 | - uses: r-hub/actions/setup@v1 37 | with: 38 | config: ${{ github.event.inputs.config }} 39 | id: rhub-setup 40 | 41 | linux-containers: 42 | needs: setup 43 | if: ${{ needs.setup.outputs.containers != '[]' }} 44 | runs-on: ubuntu-latest 45 | name: ${{ matrix.config.label }} 46 | strategy: 47 | fail-fast: false 48 | matrix: 49 | config: ${{ fromJson(needs.setup.outputs.containers) }} 50 | container: 51 | image: ${{ matrix.config.container }} 52 | 53 | steps: 54 | - uses: r-hub/actions/checkout@v1 55 | - uses: r-hub/actions/platform-info@v1 56 | with: 57 | token: ${{ secrets.RHUB_TOKEN }} 58 | job-config: ${{ matrix.config.job-config }} 59 | - uses: r-hub/actions/setup-deps@v1 60 | with: 61 | token: ${{ secrets.RHUB_TOKEN }} 62 | job-config: ${{ matrix.config.job-config }} 63 | - uses: r-hub/actions/run-check@v1 64 | with: 65 | token: ${{ secrets.RHUB_TOKEN }} 66 | job-config: ${{ matrix.config.job-config }} 67 | 68 | other-platforms: 69 | needs: setup 70 | if: ${{ needs.setup.outputs.platforms != '[]' }} 71 | runs-on: ${{ matrix.config.os }} 72 | name: ${{ matrix.config.label }} 73 | strategy: 74 | fail-fast: false 75 | matrix: 76 | config: ${{ fromJson(needs.setup.outputs.platforms) }} 77 | 78 | steps: 79 | - uses: r-hub/actions/checkout@v1 80 | - uses: r-hub/actions/setup-r@v1 81 | with: 82 | job-config: ${{ matrix.config.job-config }} 83 | token: ${{ secrets.RHUB_TOKEN }} 84 | - uses: r-hub/actions/platform-info@v1 85 | with: 86 | token: ${{ secrets.RHUB_TOKEN }} 87 | job-config: ${{ matrix.config.job-config }} 88 | - uses: r-hub/actions/setup-deps@v1 89 | with: 90 | job-config: ${{ matrix.config.job-config }} 91 | token: ${{ secrets.RHUB_TOKEN }} 92 | - uses: r-hub/actions/run-check@v1 93 | with: 94 | job-config: ${{ matrix.config.job-config }} 95 | token: ${{ secrets.RHUB_TOKEN }} 96 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/blob/v2/examples/test-coverage.yaml 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: [push, pull_request] 4 | 5 | name: test-coverage.yaml 6 | 7 | permissions: read-all 8 | 9 | jobs: 10 | test-coverage: 11 | runs-on: ubuntu-latest 12 | env: 13 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 14 | RUN_SLOW_TESTS: true 15 | CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v4 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr, any::xml2 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | cov <- covr::package_coverage( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 35 | ) 36 | print(cov) 37 | covr::to_cobertura(cov) 38 | shell: Rscript {0} 39 | 40 | - uses: codecov/codecov-action@v5 41 | with: 42 | # Fail if error if not on PR, or if on PR and token is given 43 | fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} 44 | files: ./cobertura.xml 45 | plugins: noop 46 | disable_search: true 47 | token: ${{ secrets.CODECOV_TOKEN }} 48 | slug: xrobin/pROC 49 | 50 | - name: Show testthat output 51 | if: always() 52 | run: | 53 | ## -------------------------------------------------------------------- 54 | find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true 55 | shell: bash 56 | 57 | - name: Upload test results 58 | if: failure() 59 | uses: actions/upload-artifact@v4 60 | with: 61 | name: coverage-test-failures 62 | path: ${{ runner.temp }}/package -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | *~ 6 | R.Rproj 7 | pROC-Ex.R 8 | R/emacs23.desktop 9 | src/*.o 10 | src/pROC.so 11 | src/pROC.dylib 12 | src/symbols.rds 13 | revdep/ -------------------------------------------------------------------------------- /DEPENDENCIES.ubuntu: -------------------------------------------------------------------------------- 1 | Direct build/check dependencies: 2 | r-base-dev build-essential git texlive pandoc 3 | 4 | Dependencies of pROC's dependencies on Ubuntu for R>install.packages("pROC", dependencies=TRUE): 5 | libssl-doc curl libcurl4-openssl-dev libxml2-dev libcairo2-dev 6 | 7 | Dependencies of pROC's reverse dependencies on Ubuntu for devtools::revdep_check 8 | libglu1-mesa default-jdk libgsl-dev libgtk2.0-dev libmariadbclient-dev 9 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: pROC 2 | Type: Package 3 | Title: Display and Analyze ROC Curves 4 | Version: 1.19.0.1 5 | Date: 2025-07-31 6 | Encoding: UTF-8 7 | Depends: R (>= 2.14) 8 | Imports: methods, Rcpp (>= 0.11.1) 9 | Suggests: tcltk, MASS, logcondens, 10 | testthat, vdiffr, ggplot2, rlang 11 | LinkingTo: Rcpp 12 | Authors@R: c(person("Xavier", "Robin", role = c("cre", "aut"), 13 | email = "pROC-cran@xavier.robin.name", 14 | comment = c(ORCID = "0000-0002-6813-3200")), 15 | person("Natacha", "Turck", role = "aut"), 16 | person("Alexandre", "Hainard", role = "aut"), 17 | person("Natalia", "Tiberti", role = "aut"), 18 | person("Frédérique", "Lisacek", role = "aut"), 19 | person("Jean-Charles", "Sanchez", role = "aut"), 20 | person("Markus", "Müller", role = "aut"), 21 | person("Stefan", "Siegert", role = "ctb", 22 | comment = "Fast DeLong code", 23 | email = "stefan_siegert@gmx.de"), 24 | person("Matthias", "Doering", role = "ctb", 25 | comment = "Hand & Till Multiclass"), 26 | person("Zane", "Billings", role = "ctb", 27 | comment = "DeLong paired test CI")) 28 | Description: Tools for visualizing, smoothing and comparing receiver operating characteristic (ROC curves). (Partial) area under the curve (AUC) can be compared with statistical tests based on U-statistics or bootstrap. Confidence intervals can be computed for (p)AUC or ROC curves. 29 | License: GPL (>= 3) 30 | URL: https://xrobin.github.io/pROC/ 31 | BugReports: https://github.com/xrobin/pROC/issues 32 | LazyData: yes 33 | 34 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | export(are.paired) 2 | S3method("are.paired", "auc") 3 | S3method("are.paired", "roc") 4 | S3method("are.paired", "smooth.roc") 5 | 6 | export(auc) 7 | S3method("auc", "roc") 8 | S3method("auc", "smooth.roc") 9 | S3method("auc", "formula") 10 | S3method("auc", "default") 11 | S3method("auc", "multiclass.roc") 12 | S3method("auc", "mv.multiclass.roc") 13 | 14 | export(ci) 15 | S3method("ci", "roc") 16 | S3method("ci", "smooth.roc") 17 | S3method("ci", "default") 18 | S3method("ci", "formula") 19 | S3method("ci", "auc") 20 | S3method("ci", "multiclass.roc") 21 | S3method("ci", "multiclass.auc") 22 | 23 | export(ci.coords) 24 | S3method("ci.coords", "roc") 25 | S3method("ci.coords", "smooth.roc") 26 | S3method("ci.coords", "default") 27 | S3method("ci.coords", "formula") 28 | 29 | export(ci.thresholds) 30 | S3method("ci.thresholds", "roc") 31 | S3method("ci.thresholds", "smooth.roc") 32 | S3method("ci.thresholds", "default") 33 | S3method("ci.thresholds", "formula") 34 | 35 | export(ci.sp) 36 | S3method("ci.sp", "roc") 37 | S3method("ci.sp", "smooth.roc") 38 | S3method("ci.sp", "default") 39 | S3method("ci.sp", "formula") 40 | 41 | export(ci.se) 42 | S3method("ci.se", "roc") 43 | S3method("ci.se", "smooth.roc") 44 | S3method("ci.se", "default") 45 | S3method("ci.se", "formula") 46 | 47 | export(ci.auc) 48 | S3method("ci.auc", "roc") 49 | S3method("ci.auc", "smooth.roc") 50 | S3method("ci.auc", "default") 51 | S3method("ci.auc", "formula") 52 | S3method("ci.auc", "auc") 53 | S3method("ci.auc", "multiclass.roc") 54 | S3method("ci.auc", "multiclass.auc") 55 | 56 | export(coords) 57 | S3method("coords", "auc") 58 | S3method("coords", "roc") 59 | S3method("coords", "smooth.roc") 60 | 61 | export(cov) 62 | S3method("cov", "roc") 63 | S3method("cov", "smooth.roc") 64 | S3method("cov", "default") 65 | S3method("cov", "auc") 66 | 67 | export(has.partial.auc) 68 | S3method("has.partial.auc", "roc") 69 | S3method("has.partial.auc", "smooth.roc") 70 | S3method("has.partial.auc", "auc") 71 | 72 | export(multiclass.roc) 73 | S3method("multiclass.roc", "default") 74 | S3method("multiclass.roc", "formula") 75 | 76 | export(power.roc.test) 77 | S3method("power.roc.test", "roc") 78 | S3method("power.roc.test", "numeric") 79 | S3method("power.roc.test", "list") 80 | 81 | S3method("print", "roc") 82 | S3method("print", "smooth.roc") 83 | S3method("print", "auc") 84 | S3method("print", "ci.auc") 85 | S3method("print", "ci.thresholds") 86 | S3method("print", "ci.se") 87 | S3method("print", "ci.sp") 88 | S3method("print", "ci.coords") 89 | S3method("print", "multiclass.roc") 90 | S3method("print", "multiclass.auc") 91 | S3method("print", "mv.multiclass.roc") 92 | S3method("print", "mv.multiclass.auc") 93 | 94 | export(roc) 95 | S3method("roc", "default") 96 | S3method("roc", "formula") 97 | S3method("roc", "data.frame") 98 | 99 | export(roc_) 100 | 101 | export(roc.test) 102 | S3method("roc.test", "roc") 103 | S3method("roc.test", "smooth.roc") 104 | S3method("roc.test", "default") 105 | S3method("roc.test", "formula") 106 | S3method("roc.test", "auc") 107 | 108 | export(smooth) 109 | S3method("smooth", "roc") 110 | S3method("smooth", "smooth.roc") 111 | S3method("smooth", "default") 112 | 113 | export(var) 114 | S3method("var", "roc") 115 | S3method("var", "smooth.roc") 116 | S3method("var", "default") 117 | S3method("var", "auc") 118 | 119 | S3method("Ops", "auc") 120 | S3method("Ops", "ci.se") 121 | S3method("Ops", "ci.sp") 122 | S3method("Ops", "ci.auc") 123 | 124 | S3method("Math", "auc") 125 | S3method("Math", "ci.se") 126 | S3method("Math", "ci.sp") 127 | S3method("Math", "ci.auc") 128 | 129 | S3method("lines", "roc") 130 | S3method("lines", "smooth.roc") 131 | 132 | export(lines.roc) 133 | S3method("lines.roc", "roc") 134 | S3method("lines.roc", "smooth.roc") 135 | S3method("lines.roc", "formula") 136 | S3method("lines.roc", "default") 137 | 138 | S3method("plot", "roc") 139 | S3method("plot", "smooth.roc") 140 | S3method("plot", "ci.thresholds") 141 | S3method("plot", "ci.sp") 142 | S3method("plot", "ci.se") 143 | S3method("plot", "ci.coords") 144 | 145 | export(plot.roc) 146 | S3method("plot.roc", "roc") 147 | S3method("plot.roc", "smooth.roc") 148 | S3method("plot.roc", "formula") 149 | S3method("plot.roc", "default") 150 | 151 | export(ggroc) 152 | S3method("ggroc", "roc") 153 | S3method("ggroc", "smooth.roc") 154 | S3method("ggroc", "list") 155 | 156 | export(geom_polygon_auc) 157 | S3method("geom_polygon_auc", "auc") 158 | S3method("geom_polygon_auc", "roc") 159 | S3method("geom_polygon_auc", "smooth.roc") 160 | 161 | #export(select) 162 | #export(select_) 163 | #importFrom("dplyr", "select") 164 | #importFrom("dplyr", "select_") 165 | #S3method("select", "roc") 166 | #S3method("select_", "roc") 167 | 168 | # Fix R CMD check warning false positives 169 | # "apparent S3 methods exported but not registered" 170 | # Note: these methods have an export() above 171 | S3method("roc", "test") 172 | S3method("ci", "coords") 173 | S3method("ci", "se") 174 | S3method("ci", "sp") 175 | S3method("ci", "thresholds") 176 | 177 | import(Rcpp, grDevices, graphics, stats) 178 | useDynLib(pROC, .registration = TRUE) 179 | -------------------------------------------------------------------------------- /R/RcppExports.R: -------------------------------------------------------------------------------- 1 | # Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | RcppVersion <- function() { 5 | .Call(`_pROC_RcppVersion`) 6 | } 7 | 8 | delongPlacementsCpp <- function(roc) { 9 | .Call(`_pROC_delongPlacementsCpp`, roc) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /R/are.paired.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | are.paired <- function(...) { 21 | UseMethod("are.paired") 22 | } 23 | 24 | are.paired.auc <- function(roc1, roc2, ...) { 25 | return(are.paired.roc(roc1, roc2, ...)) 26 | } 27 | 28 | are.paired.smooth.roc <- function(roc1, roc2, ...) { 29 | return(are.paired.roc(roc1, roc2, ...)) 30 | } 31 | 32 | are.paired.roc <- function(roc1, roc2, 33 | return.paired.rocs = FALSE, 34 | reuse.auc = TRUE, reuse.ci = FALSE, reuse.smooth = TRUE, 35 | ...) { 36 | # check return.paired.rocs 37 | if (!is.logical(return.paired.rocs) || length(return.paired.rocs) != 1) { 38 | stop("'return.paired.rocs' must be either TRUE or FALSE.") 39 | } 40 | # Recover base ROC curves (not auc or smoothed) 41 | if ("auc" %in% class(roc1)) { 42 | roc1 <- attr(roc1, "roc") 43 | } 44 | if ("auc" %in% class(roc2)) { 45 | roc2 <- attr(roc2, "roc") 46 | } 47 | if ("smooth.roc" %in% class(roc1)) { 48 | oroc1 <- roc1 49 | roc1 <- attr(roc1, "roc") 50 | } 51 | if ("smooth.roc" %in% class(roc2)) { 52 | oroc2 <- roc2 53 | roc2 <- attr(roc2, "roc") 54 | } 55 | # Check if the levels are the same. Otherwise it is not paired. 56 | if (!identical(roc1$levels, roc2$levels)) { 57 | return(FALSE) 58 | } 59 | # check if responses of roc 1 and 2 are identical 60 | if (identical(roc1$response, roc2$response)) { 61 | retval <- TRUE 62 | if (return.paired.rocs) { 63 | attr(retval, "roc1") <- roc1 64 | attr(retval, "roc2") <- roc2 65 | } 66 | return(retval) 67 | } else { 68 | # Make sure the difference is not only due to missing values 69 | # compare original response (with NAs and response not in levels) 70 | if (identical(roc1$original.response, roc2$original.response)) { 71 | retval <- TRUE 72 | if (!return.paired.rocs) { 73 | return(retval) 74 | } 75 | # else prepare paired ROCs 76 | idx.exclude <- is.na(roc1$original.predictor) | is.na(roc2$original.predictor) | is.na(roc1$original.response) | !roc1$original.response %in% roc1$levels 77 | roc1.paired <- roc(roc1$original.response[!idx.exclude], roc1$original.predictor[!idx.exclude], levels = roc1$levels, percent = roc1$percent, na.rm = FALSE, direction = roc1$direction, auc = FALSE) 78 | roc2.paired <- roc(roc2$original.response[!idx.exclude], roc2$original.predictor[!idx.exclude], levels = roc2$levels, percent = roc2$percent, na.rm = FALSE, direction = roc2$direction, auc = FALSE) 79 | # Re-use auc/ci/smooth for roc1 80 | if (exists("oroc1") && reuse.smooth) { 81 | args <- oroc1$smoothing.args 82 | args$roc <- roc1.paired 83 | roc1.paired <- do.call("smooth.roc", args) 84 | roc1.paired$call$roc <- as.name("roc1.paired") 85 | } 86 | if (!is.null(roc1$auc) && reuse.auc) { 87 | args <- attributes(roc1$auc) 88 | args$roc <- roc1.paired 89 | roc1.paired$auc <- do.call("auc.roc", args) 90 | } 91 | if (!is.null(roc1$ci) && reuse.ci) { 92 | args <- attributes(roc1$ci) 93 | args$roc <- NULL 94 | roc1.paired$ci <- do.call(class(roc1$ci)[1], c(roc = list(roc1.paired), args)) 95 | } 96 | # Re-use auc/ci/smooth for roc2 97 | if (exists("oroc2") && reuse.smooth) { 98 | args <- oroc2$smoothing.args 99 | args$roc <- roc2.paired 100 | roc2.paired <- do.call("smooth.roc", args) 101 | roc2.paired$call$roc <- as.name("roc2.paired") 102 | } 103 | if (!is.null(roc2$auc) && reuse.auc) { 104 | args <- attributes(roc2$auc) 105 | args$roc <- roc2.paired 106 | roc2.paired$auc <- do.call("auc.roc", args) 107 | } 108 | if (!is.null(roc2$ci) && reuse.ci) { 109 | args <- attributes(roc2$ci) 110 | args$roc <- NULL 111 | roc2.paired$ci <- do.call(class(roc2$ci)[1], c(roc = list(roc2.paired), args)) 112 | } 113 | 114 | # Attach ROCs and return value 115 | attr(retval, "roc1") <- roc1.paired 116 | attr(retval, "roc2") <- roc2.paired 117 | return(retval) 118 | } else { 119 | return(FALSE) 120 | } 121 | } 122 | } 123 | -------------------------------------------------------------------------------- /R/ci.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | ci <- function(...) { 21 | UseMethod("ci") 22 | } 23 | 24 | ci.formula <- function(formula, data, ...) { 25 | data.missing <- missing(data) 26 | roc.data <- roc_utils_extract_formula(formula, data, ..., 27 | data.missing = data.missing, 28 | call = match.call() 29 | ) 30 | if (length(roc.data$predictor.name) > 1) { 31 | stop("Only one predictor supported in 'ci'.") 32 | } 33 | response <- roc.data$response 34 | predictor <- roc.data$predictors[, 1] 35 | ci.roc(roc(response, predictor, ...), ...) 36 | } 37 | 38 | ci.default <- function(response, predictor, ...) { 39 | roc <- roc.default(response, predictor, ci = FALSE, ...) 40 | if (methods::is(roc, "smooth.roc")) { 41 | return(ci.roc(smooth.roc = roc, ...)) 42 | } else { 43 | return(ci.roc(roc = roc, ...)) 44 | } 45 | } 46 | 47 | ci.smooth.roc <- function(smooth.roc, of = c("auc", "sp", "se", "coords"), ...) { 48 | of <- match.arg(of) 49 | 50 | if (of == "auc") { 51 | ci <- ci.auc.smooth.roc(smooth.roc, ...) 52 | } else if (of == "sp") { 53 | ci <- ci.sp.smooth.roc(smooth.roc, ...) 54 | } else if (of == "se") { 55 | ci <- ci.se.smooth.roc(smooth.roc, ...) 56 | } else if (of == "coords") { 57 | ci <- ci.coords.smooth.roc(smooth.roc, ...) 58 | } else { 59 | stop(sprintf("Unknown 'of' for CI: %s", of)) 60 | } 61 | 62 | return(ci) 63 | } 64 | 65 | ci.roc <- function(roc, of = c("auc", "thresholds", "sp", "se", "coords"), ...) { 66 | of <- match.arg(of) 67 | 68 | if (of == "auc") { 69 | ci <- ci.auc.roc(roc, ...) 70 | } else if (of == "thresholds") { 71 | ci <- ci.thresholds.roc(roc, ...) 72 | } else if (of == "sp") { 73 | ci <- ci.sp.roc(roc, ...) 74 | } else if (of == "se") { 75 | ci <- ci.se.roc(roc, ...) 76 | } else if (of == "coords") { 77 | ci <- ci.coords.roc(roc, ...) 78 | } else { 79 | stop(sprintf("Unknown 'of' for CI: %s", of)) 80 | } 81 | 82 | return(ci) 83 | } 84 | 85 | ci.multiclass.roc <- function(multiclass.roc, of = "auc", ...) { 86 | stop("CI of a multiclass ROC curve not implemented") 87 | } 88 | 89 | ci.multiclass.auc <- function(multiclass.auc, of = "auc", ...) { 90 | stop("CI of a multiclass AUC not implemented") 91 | } 92 | -------------------------------------------------------------------------------- /R/ci.thresholds.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | ci.thresholds <- function(...) { 21 | UseMethod("ci.thresholds") 22 | } 23 | 24 | ci.thresholds.formula <- function(formula, data, ...) { 25 | data.missing <- missing(data) 26 | roc.data <- roc_utils_extract_formula(formula, data, ..., 27 | data.missing = data.missing, 28 | call = match.call() 29 | ) 30 | if (length(roc.data$predictor.name) > 1) { 31 | stop("Only one predictor supported in 'ci.thresholds'.") 32 | } 33 | response <- roc.data$response 34 | predictor <- roc.data$predictors[, 1] 35 | ci.thresholds(roc(response, predictor, ci = FALSE, ...), ...) 36 | } 37 | 38 | ci.thresholds.default <- function(response, predictor, ...) { 39 | if (methods::is(response, "multiclass.roc") || methods::is(response, "multiclass.auc")) { 40 | stop("'ci.thresholds' not available for multiclass ROC curves.") 41 | } 42 | ci.thresholds(roc.default(response, predictor, ci = FALSE, ...), ...) 43 | } 44 | 45 | ci.thresholds.smooth.roc <- function(smooth.roc, ...) { 46 | stop("'ci.thresholds' is not available for smoothed ROC curves.") 47 | } 48 | 49 | ci.thresholds.roc <- function(roc, 50 | conf.level = 0.95, 51 | boot.n = 2000, 52 | boot.stratified = TRUE, 53 | thresholds = "local maximas", 54 | progress = NULL, 55 | parallel = FALSE, 56 | ...) { 57 | if (conf.level > 1 | conf.level < 0) { 58 | stop("'conf.level' must be within the interval [0,1].") 59 | } 60 | 61 | if (roc_utils_is_perfect_curve(roc)) { 62 | warning("ci.thresholds() of a ROC curve with AUC == 1 is always a null interval and can be misleading.") 63 | } 64 | if (!is.null(progress)) { 65 | warning("Progress bars are deprecated in pROC 1.19. Ignoring 'progress' argument") 66 | } 67 | 68 | # Check and prepare thresholds 69 | if (is.character(thresholds)) { 70 | if (length(thresholds) != 1) { 71 | stop("'thresholds' of class character must be of length 1.") 72 | } 73 | thresholds <- match.arg(thresholds, c("all", "best", "local maximas")) 74 | thresholds.num <- coords(roc, x = thresholds, input = "threshold", ret = "threshold", ...)[, 1] 75 | attr(thresholds.num, "coords") <- thresholds 76 | } else if (is.logical(thresholds)) { 77 | thresholds.num <- roc$thresholds[thresholds] 78 | attr(thresholds.num, "logical") <- thresholds 79 | } else if (!is.numeric(thresholds)) { 80 | stop("'thresholds' is not character, logical or numeric.") 81 | } else { 82 | thresholds.num <- thresholds 83 | } 84 | 85 | perfs_shape <- matrix(NA_real_, nrow = 2L, ncol = length(thresholds.num)) 86 | bootstrap_fun <- if (boot.stratified) stratified.ci.thresholds else nonstratified.ci.thresholds 87 | perfs <- vapply(seq_len(boot.n), bootstrap_fun, FUN.VALUE = perfs_shape, roc = roc, thresholds = thresholds.num) 88 | 89 | probs <- c(0 + (1 - conf.level) / 2, .5, 1 - (1 - conf.level) / 2) 90 | # output is length(probs) x 2 x length(thresholds.num) 91 | perf_quantiles <- apply(perfs, 1:2, quantile, probs = probs) 92 | 93 | sp <- t(perf_quantiles[, 1L, ]) 94 | se <- t(perf_quantiles[, 2L, ]) 95 | 96 | rownames(se) <- rownames(sp) <- thresholds.num 97 | 98 | if (roc$percent) { 99 | se <- se * 100 100 | sp <- sp * 100 101 | } 102 | 103 | ci <- list(specificity = sp, sensitivity = se) 104 | class(ci) <- c("ci.thresholds", "ci", "list") 105 | attr(ci, "conf.level") <- conf.level 106 | attr(ci, "boot.n") <- boot.n 107 | attr(ci, "boot.stratified") <- boot.stratified 108 | attr(ci, "thresholds") <- thresholds.num 109 | attr(ci, "roc") <- roc 110 | return(ci) 111 | } 112 | -------------------------------------------------------------------------------- /R/geom_polygon_auc.R: -------------------------------------------------------------------------------- 1 | geom_polygon_auc <- function(data, ...) { 2 | UseMethod("geom_polygon_auc") 3 | } 4 | 5 | geom_polygon_auc.auc <- function(data, legacy.axes = FALSE, ...) { 6 | # Get the roc data with coords 7 | roc <- attr(data, "roc") 8 | roc$auc <- data 9 | df <- get.coords.for.ggplot(roc, ignore.partial.auc = FALSE) 10 | 11 | # Add bottom-right point 12 | partial.auc <- attr(data, "partial.auc") 13 | one.or.hundred <- ifelse(attr(data, "percent"), 100, 1) 14 | if (legacy.axes) { 15 | if (identical(partial.auc, FALSE)) { 16 | df[nrow(df) + 1, ] <- c(NA, one.or.hundred, 0, one.or.hundred) 17 | } else if (attr(data, "partial.auc.focus") == "sensitivity") { 18 | df[nrow(df) + c(1, 2), ] <- c(NA, NA, one.or.hundred, one.or.hundred, partial.auc, one.or.hundred, one.or.hundred) 19 | } else { # partial.auc.focus == "specificity" 20 | df[nrow(df) + c(1, 2), ] <- c(NA, NA, rev(partial.auc), 0, 0, one.or.hundred - rev(partial.auc)) 21 | } 22 | } else { 23 | if (identical(partial.auc, FALSE)) { 24 | df[nrow(df) + 1, ] <- c(NA, 0, 0, 0) 25 | } else if (attr(data, "partial.auc.focus") == "sensitivity") { 26 | df[nrow(df) + c(1, 2), ] <- c(NA, NA, 0, 0, partial.auc, 0, 0) 27 | } else { # partial.auc.focus == "specificity" 28 | df[nrow(df) + c(1, 2), ] <- c(NA, NA, rev(partial.auc), 0, 0, one.or.hundred - rev(partial.auc)) 29 | } 30 | } 31 | 32 | # Prepare the aesthetics 33 | aes <- get.aes.for.ggplot(attr(data, "roc"), legacy.axes) 34 | 35 | # Do the plotting 36 | ggplot2::geom_polygon(aes$aes, data = df, ...) 37 | } 38 | 39 | geom_polygon_auc.roc <- function(data, ...) { 40 | geom_polygon_auc(data$auc, ...) 41 | } 42 | 43 | geom_polygon_auc.smooth.roc <- geom_polygon_auc.roc 44 | -------------------------------------------------------------------------------- /R/ggroc.R: -------------------------------------------------------------------------------- 1 | # Returns the coords as a data.frame in the right ordering for ggplot2 2 | get.coords.for.ggplot <- function(roc, ignore.partial.auc) { 3 | df <- coords(roc, "all", transpose = FALSE, ignore.partial.auc = ignore.partial.auc) 4 | df[["1-specificity"]] <- ifelse(roc$percent, 100, 1) - df[["specificity"]] 5 | return(df[rev(seq(nrow(df))), ]) 6 | } 7 | 8 | get.aes.for.ggplot <- function(roc, legacy.axes, extra_aes = c(), group = FALSE) { 9 | # Prepare the aesthetics 10 | if (roc$percent) { 11 | if (legacy.axes) { 12 | aes_list <- list( 13 | x = "1-specificity", 14 | y = "sensitivity" 15 | ) 16 | xlims <- ggplot2::scale_x_continuous(lim = c(0, 100)) 17 | } else { 18 | aes_list <- list( 19 | x = "specificity", 20 | y = "sensitivity" 21 | ) 22 | xlims <- ggplot2::scale_x_reverse(lim = c(100, 0)) 23 | } 24 | } else { 25 | if (legacy.axes) { 26 | aes_list <- list( 27 | x = "1-specificity", 28 | y = "sensitivity" 29 | ) 30 | xlims <- ggplot2::scale_x_continuous(lim = c(0, 1)) 31 | } else { 32 | aes_list <- list( 33 | x = "specificity", 34 | y = "sensitivity" 35 | ) 36 | xlims <- ggplot2::scale_x_reverse(lim = c(1, 0)) 37 | } 38 | } 39 | # Add extra aes 40 | for (ae in extra_aes) { 41 | aes_list[[ae]] <- "name" 42 | } 43 | # Add group 44 | if (group) { 45 | aes_list[["group"]] <- "name" 46 | } 47 | .data <- rlang::.data 48 | quoted_aes_list <- lapply(aes_list, function(x) ggplot2::expr(.data[[x]])) 49 | aes <- do.call(ggplot2::aes, quoted_aes_list) 50 | 51 | return(list(aes = aes, xlims = xlims)) 52 | } 53 | 54 | load.ggplot2 <- function() { 55 | if (!isNamespaceLoaded("ggplot2")) { 56 | message("You may need to call library(ggplot2) if you want to add layers, etc.") 57 | } 58 | load.suggested.package("ggplot2") 59 | } 60 | 61 | ggroc <- function(data, ...) { 62 | UseMethod("ggroc") 63 | } 64 | 65 | ggroc.roc <- function(data, legacy.axes = FALSE, ...) { 66 | load.ggplot2() 67 | # Get the roc data with coords 68 | df <- get.coords.for.ggplot(data, ignore.partial.auc = TRUE) 69 | 70 | # Prepare the aesthetics 71 | aes <- get.aes.for.ggplot(data, legacy.axes) 72 | 73 | # Do the plotting 74 | ggplot2::ggplot(df) + 75 | ggplot2::geom_line(aes$aes, ...) + 76 | aes$xlims 77 | } 78 | 79 | ggroc.smooth.roc <- ggroc.roc 80 | 81 | ggroc.list <- function(data, aes = c("colour", "alpha", "linetype", "linewidth", "size", "group"), legacy.axes = FALSE, ...) { 82 | load.ggplot2() 83 | if (missing(aes)) { 84 | aes <- "colour" 85 | } 86 | aes <- sub("color", "colour", aes) 87 | aes <- match.arg(aes, several.ok = TRUE) 88 | 89 | # Make sure data is a list and every element is a roc object 90 | if (!all(sapply(data, methods::is, "roc") | sapply(data, methods::is, "smooth.roc"))) { 91 | stop("All elements in 'data' must be 'roc' objects.") 92 | } 93 | 94 | # Make sure percent is consistent 95 | percents <- sapply(data, `[[`, "percent") 96 | if (!(all(percents) || all(!percents))) { 97 | stop("ROC curves use percent inconsistently and cannot be plotted together") 98 | } 99 | 100 | # Make sure the data is a named list 101 | if (is.null(names(data))) { 102 | names(data) <- seq(data) 103 | } 104 | # Make sure names are unique: 105 | if (any(duplicated(names(data)))) { 106 | stop("Names of 'data' must be unique") 107 | } 108 | 109 | # Get the coords 110 | coord.dfs <- sapply(data, get.coords.for.ggplot, simplify = FALSE, ignore.partial.auc = TRUE) 111 | 112 | # Add a "name" colummn 113 | for (i in seq_along(coord.dfs)) { 114 | coord.dfs[[i]]$name <- names(coord.dfs)[i] 115 | } 116 | 117 | # Make a big data.frame 118 | coord.dfs <- do.call(rbind, coord.dfs) 119 | coord.dfs$name <- factor(coord.dfs$name, as.vector(names(data))) 120 | 121 | # Prepare the aesthetics 122 | aes.ggplot <- get.aes.for.ggplot(data[[1]], legacy.axes, aes, group = TRUE) 123 | 124 | # Do the plotting 125 | ggplot2::ggplot(coord.dfs, aes.ggplot$aes) + 126 | ggplot2::geom_line(...) + 127 | aes.ggplot$xlims 128 | } 129 | -------------------------------------------------------------------------------- /R/groupGeneric.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2014 Xavier Robin 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU General Public License as published by 7 | # the Free Software Foundation, either version 3 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU General Public License 16 | # along with this program. If not, see . 17 | 18 | Ops.auc <- function(e1, e2) { 19 | if (methods::is(e1, "auc")) { 20 | attributes(e1) <- NULL 21 | } 22 | if (methods::is(e2, "auc")) { 23 | attributes(e2) <- NULL 24 | } 25 | NextMethod() 26 | } 27 | 28 | Math.auc <- function(x, ...) { 29 | attributes(x) <- NULL 30 | NextMethod() 31 | } 32 | 33 | Ops.ci.se <- Ops.ci.sp <- Ops.ci.auc <- function(e1, e2) { 34 | e1 <- remove.ci.attributes(e1) 35 | e2 <- remove.ci.attributes(e2) 36 | NextMethod() 37 | } 38 | 39 | 40 | Math.ci.se <- Math.ci.sp <- Math.ci.auc <- function(x, ...) { 41 | x <- remove.ci.attributes(x) 42 | NextMethod() 43 | } 44 | 45 | remove.ci.attributes <- function(ci) { 46 | attr(ci, "conf.level") <- NULL 47 | attr(ci, "boot.n") <- NULL 48 | attr(ci, "boot.stratified") <- NULL 49 | attr(ci, "specificities") <- NULL 50 | attr(ci, "sensitivities") <- NULL 51 | attr(ci, "roc") <- NULL 52 | attr(ci, "method") <- NULL 53 | attr(ci, "auc") <- NULL 54 | class(ci) <- class(ci)[-(1:2)] 55 | return(ci) 56 | } 57 | -------------------------------------------------------------------------------- /R/has.partial.auc.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2011-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | has.partial.auc <- function(roc) { 21 | UseMethod("has.partial.auc") 22 | } 23 | 24 | has.partial.auc.auc <- function(roc) { 25 | if (is.null(roc)) { 26 | return(NULL) 27 | } 28 | 29 | is.numeric(attr(roc, "partial.auc")) && length(attr(roc, "partial.auc") == 2) 30 | } 31 | 32 | has.partial.auc.smooth.roc <- function(roc) { 33 | return(has.partial.auc.roc(roc)) 34 | } 35 | 36 | has.partial.auc.roc <- function(roc) { 37 | return(has.partial.auc.auc(roc$auc)) 38 | } 39 | -------------------------------------------------------------------------------- /R/lines.roc.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | lines.roc <- function(x, ...) { 21 | UseMethod("lines.roc") 22 | } 23 | 24 | lines.roc.formula <- function(x, data, subset, na.action, ...) { 25 | data.missing <- missing(data) 26 | call <- match.call() 27 | names(call)[2] <- "formula" # forced to be x by definition of lines 28 | roc.data <- roc_utils_extract_formula( 29 | formula = x, data, subset, na.action, ..., 30 | data.missing = data.missing, 31 | call = call 32 | ) 33 | if (length(roc.data$predictor.name) > 1) { 34 | stop("Only one predictor supported in 'lines.roc'.") 35 | } 36 | response <- roc.data$response 37 | predictor <- roc.data$predictors[, 1] 38 | roc <- roc(response, predictor, ...) 39 | lines.roc.roc(roc, ...) 40 | roc$call <- match.call() 41 | invisible(roc) 42 | } 43 | 44 | lines.roc.default <- function(x, predictor, ...) { 45 | roc <- roc(x, predictor, ...) 46 | lines.roc.roc(roc, ...) 47 | roc$call <- match.call() 48 | invisible(roc) 49 | } 50 | 51 | lines.roc.smooth.roc <- lines.smooth.roc <- function(x, ...) { 52 | lines.roc.roc(x, ...) # force usage of lines.roc.roc 53 | } 54 | 55 | lines.roc.roc <- function(x, lwd = 2, ...) { 56 | suppressWarnings(lines(x$specificities, x$sensitivities, lwd = lwd, ...)) 57 | invisible(x) 58 | } 59 | -------------------------------------------------------------------------------- /R/null.roc.R: -------------------------------------------------------------------------------- 1 | # null.roc <- structure(list(percent = FALSE, sensitivities = c(1, 0), specificities = c(0, 1), auc = NULL, class = "auc"), class = "roc") 2 | -------------------------------------------------------------------------------- /R/onLoad.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | .onAttach <- function(lib, pkg) { 21 | # Remove deprecated pROCProgress option 22 | if (!is.null(getOption("pROCProgress")) && getOption("pROCProgress")$name != "none") { 23 | packageStartupMessage("Progress bars are deprecated in pROC 1.19. Removing pROCProgress option.") 24 | } 25 | options("pROCProgress" = NULL) 26 | } 27 | 28 | .parseRcppVersion <- function(rcpp.version) { 29 | # Parses Rcpp version integer into a string. 30 | # Eg "65538" -> "1.0.2" 31 | rcpp.version <- as.integer(rcpp.version) 32 | major <- rcpp.version %/% 65536 33 | rcpp.version <- rcpp.version - major * 65536 34 | minor <- rcpp.version %/% 256 35 | rcpp.version <- rcpp.version - minor * 256 36 | rev <- rcpp.version 37 | return(sprintf("%s.%s.%s", major, minor, rev)) 38 | } 39 | 40 | .checkRcppVersion <- function() { 41 | # Check runtime version of Rcpp is the same than we had at compile time 42 | runtime_version <- package_version(utils::packageVersion("Rcpp")) 43 | build_version <- package_version(.parseRcppVersion(RcppVersion())) 44 | if (runtime_version != build_version) { 45 | warning(sprintf( 46 | "It seems pROC was compiled with Rcpp version %s, but %s is available now. Please re-install pROC to avoid problems: install.packages(\"pROC\").", 47 | build_version, runtime_version 48 | )) 49 | } 50 | } 51 | 52 | .onAttach <- function(lib, pkg) { 53 | packageStartupMessage("Type 'citation(\"pROC\")' for a citation.") 54 | } 55 | -------------------------------------------------------------------------------- /R/plot.ci.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | plot.ci.thresholds <- function(x, length = .01 * ifelse(attr(x, "roc")$percent, 100, 1), col = par("fg"), ...) { 21 | bounds <- cbind(x$sp, x$se) 22 | apply(bounds, 1, function(x, ...) { 23 | suppressWarnings(segments(x[2], x[4], x[2], x[6], col = col, ...)) 24 | suppressWarnings(segments(x[2] - length, x[4], x[2] + length, x[4], col = col, ...)) 25 | suppressWarnings(segments(x[2] - length, x[6], x[2] + length, x[6], col = col, ...)) 26 | suppressWarnings(segments(x[1], x[5], x[3], x[5], col = col, ...)) 27 | suppressWarnings(segments(x[1], x[5] + length, x[1], x[5] - length, col = col, ...)) 28 | suppressWarnings(segments(x[3], x[5] + length, x[3], x[5] - length, col = col, ...)) 29 | }, ...) 30 | invisible(x) 31 | } 32 | 33 | plot.ci.sp <- function(x, type = c("bars", "shape"), length = .01 * ifelse(attr(x, "roc")$percent, 100, 1), col = ifelse(type == "bars", par("fg"), "gainsboro"), no.roc = FALSE, ...) { 34 | type <- match.arg(type) 35 | if (type == "bars") { 36 | sapply(1:dim(x)[1], function(n, ...) { 37 | se <- attr(x, "sensitivities")[n] 38 | suppressWarnings(segments(x[n, 1], se, x[n, 3], se, col = col, ...)) 39 | suppressWarnings(segments(x[n, 1], se - length, x[n, 1], se + length, col = col, ...)) 40 | suppressWarnings(segments(x[n, 3], se - length, x[n, 3], se + length, col = col, ...)) 41 | }, ...) 42 | } else { 43 | if (length(x[, 1]) < 15) { 44 | warning("Low definition shape.") 45 | } 46 | suppressWarnings(polygon(c(1 * ifelse(attr(x, "roc")$percent, 100, 1), x[, 1], 0, rev(x[, 3]), 1 * ifelse(attr(x, "roc")$percent, 100, 1)), c(0, attr(x, "sensitivities"), 1 * ifelse(attr(x, "roc")$percent, 100, 1), rev(attr(x, "sensitivities")), 0), col = col, ...)) 47 | if (!no.roc) { 48 | plot(attr(x, "roc"), add = TRUE) 49 | } 50 | } 51 | invisible(x) 52 | } 53 | 54 | 55 | plot.ci.se <- function(x, type = c("bars", "shape"), length = .01 * ifelse(attr(x, "roc")$percent, 100, 1), col = ifelse(type == "bars", par("fg"), "gainsboro"), no.roc = FALSE, ...) { 56 | type <- match.arg(type) 57 | if (type == "bars") { 58 | sapply(1:dim(x)[1], function(n, ...) { 59 | sp <- attr(x, "specificities")[n] 60 | suppressWarnings(segments(sp, x[n, 1], sp, x[n, 3], col = col, ...)) 61 | suppressWarnings(segments(sp - length, x[n, 1], sp + length, x[n, 1], col = col, ...)) 62 | suppressWarnings(segments(sp - length, x[n, 3], sp + length, x[n, 3], col = col, ...)) 63 | }, ...) 64 | } else { 65 | if (length(x[, 1]) < 15) { 66 | warning("Low definition shape.") 67 | } 68 | suppressWarnings(polygon(c(0, attr(x, "specificities"), 1 * ifelse(attr(x, "roc")$percent, 100, 1), rev(attr(x, "specificities")), 0), c(1 * ifelse(attr(x, "roc")$percent, 100, 1), x[, 1], 0, rev(x[, 3]), 1 * ifelse(attr(x, "roc")$percent, 100, 1)), col = col, ...)) 69 | if (!no.roc) { 70 | plot(attr(x, "roc"), add = TRUE) 71 | } 72 | } 73 | invisible(x) 74 | } 75 | 76 | plot.ci.coords <- function(x, type = c("bars", "shape"), length = NULL, col = ifelse(type == "bars", par("fg"), "gainsboro"), ...) { 77 | type <- match.arg(type) 78 | if (length(x) > 1) { 79 | warning(sprintf("'ci.coords' object contains multiple coordinates, only %s will be plotted", names(x)[1])) 80 | } 81 | if (is.null(length)) { 82 | x_range <- range(attr(x, "x")) 83 | length <- (x_range[2] - x_range[1]) / length(attr(x, "x")) / 5 84 | } 85 | if (type == "bars") { 86 | x_val <- attr(x, "x") 87 | suppressWarnings(segments(x_val, x[[1]][, 1], x_val, x[[1]][, 3], col = col, ...)) 88 | suppressWarnings(segments(x_val - length, x[[1]][, 1], x_val + length, x[[1]][, 1], col = col, ...)) 89 | suppressWarnings(segments(x_val - length, x[[1]][, 3], x_val + length, x[[1]][, 3], col = col, ...)) 90 | } else { 91 | if (length(x[[1]][, 1]) < 15) { 92 | warning("Low definition shape.") 93 | } 94 | suppressWarnings(polygon(c(attr(x, "x"), rev(attr(x, "x"))), c(x[[1]][, 1], rev(x[[1]][, 3])), col = col, ...)) 95 | } 96 | invisible(x) 97 | } 98 | -------------------------------------------------------------------------------- /R/roc.utils.percent.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | # Helper functions to safely convert ROC objects from percent=TRUE to percent=FALSE 21 | # and inversely. These are internal and experimental. They shouldn't be exposed 22 | # to the end user. 23 | 24 | # Returns a ROC curve with percent=FALSE 25 | roc_utils_unpercent <- function(x) { 26 | UseMethod("roc_utils_unpercent") 27 | } 28 | 29 | roc_utils_unpercent.roc <- function(x) { 30 | if (x$percent) { 31 | if (!is.null(x$auc)) { 32 | x$auc <- roc_utils_unpercent(x$auc) 33 | } 34 | x$sensitivities <- x$sensitivities / 100 35 | x$specificities <- x$specificities / 100 36 | x$percent <- FALSE 37 | if (!is.null(x$call)) { 38 | x$call$percent <- FALSE 39 | } 40 | if (!is.null(x$ci)) { 41 | x$ci <- roc_utils_unpercent(x$ci) 42 | } 43 | } 44 | 45 | return(x) 46 | } 47 | 48 | roc_utils_unpercent.auc <- function(x) { 49 | if (attr(x, "percent")) { 50 | newx <- x / 100 51 | attributes(newx) <- attributes(x) 52 | x <- newx 53 | attr(x, "percent") <- FALSE 54 | if (is.numeric(attr(x, "partial.auc"))) { 55 | attr(x, "partial.auc") <- attr(x, "partial.auc") / 100 56 | } 57 | if (!is.null(attr(x, "roc"))) { 58 | attr(x, "roc") <- roc_utils_unpercent(attr(x, "roc")) 59 | } 60 | } 61 | return(x) 62 | } 63 | 64 | roc_utils_unpercent.ci.auc <- function(x) { 65 | if (attr(attr(x, "auc"), "percent")) { 66 | x[] <- x / 100 67 | attr(x, "auc") <- roc_utils_unpercent(attr(x, "auc")) 68 | } 69 | return(x) 70 | } 71 | 72 | roc_utils_unpercent.ci.thresholds <- function(x) { 73 | if (attr(x, "roc")$percent) { 74 | x$sensitivity[] <- x$sensitivity / 100 75 | x$specificity[] <- x$specificity / 100 76 | attr(x, "roc") <- roc_utils_unpercent(attr(x, "roc")) 77 | } 78 | return(x) 79 | } 80 | 81 | roc_utils_unpercent.ci.sp <- function(x) { 82 | if (attr(x, "roc")$percent) { 83 | x[] <- x / 100 84 | attr(x, "sensitivities") <- attr(x, "sensitivities") / 100 85 | rownames(x) <- attr(x, "sensitivities") 86 | attr(x, "roc") <- roc_utils_unpercent(attr(x, "roc")) 87 | } 88 | return(x) 89 | } 90 | 91 | roc_utils_unpercent.ci.se <- function(x) { 92 | if (attr(x, "roc")$percent) { 93 | x[] <- x / 100 94 | attr(x, "specificities") <- attr(x, "specificities") / 100 95 | rownames(x) <- attr(x, "specificities") 96 | attr(x, "roc") <- roc_utils_unpercent(attr(x, "roc")) 97 | } 98 | return(x) 99 | } 100 | 101 | roc_utils_unpercent.ci.coords <- function(x) { 102 | stop("Cannot convert ci.coords object to percent = FALSE") 103 | } 104 | 105 | # Returns a ROC curve with percent=TRUE 106 | roc_utils_topercent <- function(x) { 107 | UseMethod("roc_utils_topercent") 108 | } 109 | 110 | roc_utils_topercent.roc <- function(x) { 111 | if (!x$percent) { 112 | if (!is.null(x$auc)) { 113 | x$auc <- roc_utils_topercent(x$auc) 114 | } 115 | x$sensitivities <- x$sensitivities * 100 116 | x$specificities <- x$specificities * 100 117 | x$percent <- TRUE 118 | if (!is.null(x$call)) { 119 | x$call$percent <- TRUE 120 | } 121 | if (!is.null(x$ci)) { 122 | x$ci <- roc_utils_topercent(x$ci) 123 | } 124 | } 125 | 126 | return(x) 127 | } 128 | 129 | roc_utils_topercent.auc <- function(x) { 130 | if (!attr(x, "percent")) { 131 | newx <- x * 100 132 | attributes(newx) <- attributes(x) 133 | x <- newx 134 | attr(x, "percent") <- TRUE 135 | if (is.numeric(attr(x, "partial.auc"))) { 136 | attr(x, "partial.auc") <- attr(x, "partial.auc") * 100 137 | } 138 | if (!is.null(attr(x, "roc"))) { 139 | attr(x, "roc") <- roc_utils_topercent(attr(x, "roc")) 140 | } 141 | } 142 | return(x) 143 | } 144 | 145 | roc_utils_topercent.ci.auc <- function(x) { 146 | if (!attr(attr(x, "auc"), "percent")) { 147 | x[] <- x * 100 148 | attr(x, "auc") <- roc_utils_topercent(attr(x, "auc")) 149 | } 150 | return(x) 151 | } 152 | 153 | roc_utils_topercent.ci.thresholds <- function(x) { 154 | if (!attr(x, "roc")$percent) { 155 | x$sensitivity[] <- x$sensitivity * 100 156 | x$specificity[] <- x$specificity * 100 157 | attr(x, "roc") <- roc_utils_topercent(attr(x, "roc")) 158 | } 159 | return(x) 160 | } 161 | 162 | roc_utils_topercent.ci.sp <- function(x) { 163 | if (!attr(x, "roc")$percent) { 164 | x[] <- x * 100 165 | attr(x, "sensitivities") <- attr(x, "sensitivities") * 100 166 | rownames(x) <- paste(attr(x, "sensitivities"), "%", sep = "") 167 | attr(x, "roc") <- roc_utils_topercent(attr(x, "roc")) 168 | } 169 | return(x) 170 | } 171 | 172 | roc_utils_topercent.ci.se <- function(x) { 173 | if (!attr(x, "roc")$percent) { 174 | x[] <- x * 100 175 | attr(x, "specificities") <- attr(x, "specificities") * 100 176 | rownames(x) <- paste(attr(x, "specificities"), "%", sep = "") 177 | attr(x, "roc") <- roc_utils_topercent(attr(x, "roc")) 178 | } 179 | return(x) 180 | } 181 | 182 | roc_utils_topercent.ci.coords <- function(x) { 183 | stop("Cannot convert ci.coords object to percent = TRUE") 184 | } 185 | -------------------------------------------------------------------------------- /R/var.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | var <- function(...) { 21 | UseMethod("var") 22 | } 23 | 24 | var.default <- function(...) { 25 | stats::var(...) 26 | } 27 | 28 | var.auc <- function(auc, ...) { 29 | # Change roc from an auc to a roc object but keep the auc specifications 30 | roc <- auc 31 | attr(auc, "roc") <- NULL 32 | roc <- attr(roc, "roc") 33 | roc$auc <- auc 34 | # Pass to var.roc 35 | var.roc(roc, ...) 36 | } 37 | 38 | var.smooth.roc <- function(smooth.roc, ...) { 39 | var.roc(smooth.roc, ...) # just pass to var.roc that will do the job 40 | } 41 | 42 | var.roc <- function(roc, 43 | method = c("delong", "bootstrap", "obuchowski"), 44 | boot.n = 2000, 45 | boot.stratified = TRUE, 46 | reuse.auc = TRUE, 47 | progress = NULL, 48 | parallel = FALSE, 49 | ...) { 50 | # We need an auc 51 | if (is.null(roc$auc) | !reuse.auc) { 52 | roc$auc <- auc(roc, ...) 53 | } 54 | 55 | if (roc_utils_is_perfect_curve(roc)) { 56 | warning("var() of a ROC curve with AUC == 1 is always 0 and can be misleading.") 57 | } 58 | if (!is.null(progress)) { 59 | warning("Progress bars are deprecated in pROC 1.19. Ignoring 'progress' argument") 60 | } 61 | 62 | # do all the computations in fraction, re-transform in percent later 63 | percent <- roc$percent 64 | if (percent) { 65 | roc <- roc_utils_unpercent(roc) 66 | } 67 | 68 | # Check the method 69 | if (missing(method) | is.null(method)) { 70 | # determine method if missing 71 | if (has.partial.auc(roc)) { 72 | # partial auc: go for bootstrap 73 | method <- "bootstrap" 74 | } else if (inherits(roc, "smooth.roc")) { 75 | # smoothing: bootstrap 76 | method <- "bootstrap" 77 | } else { 78 | method <- "delong" 79 | } 80 | } else { 81 | method <- match.arg(method) 82 | # delong NA to pAUC: warn + change 83 | if (method == "delong") { 84 | if (has.partial.auc(roc)) { 85 | stop("DeLong method is not supported for partial AUC. Use method=\"bootstrap\" instead.") 86 | } else if ("smooth.roc" %in% class(roc)) { 87 | stop("DeLong method is not supported for smoothed ROCs. Use method=\"bootstrap\" instead.") 88 | } 89 | } else if (method == "obuchowski") { 90 | if ("smooth.roc" %in% class(roc)) { 91 | stop("Using Obuchowski for smoothed ROCs is not supported. Using bootstrap instead.") 92 | } 93 | if (has.partial.auc(roc) && attr(roc$auc, "partial.auc.focus") == "sensitivity") { 94 | stop("Using Obuchowski for partial AUC on sensitivity region is not supported. Using bootstrap instead.") 95 | } 96 | } 97 | } 98 | 99 | if (method == "delong") { 100 | n <- length(roc$controls) 101 | m <- length(roc$cases) 102 | V <- delongPlacements(roc) 103 | var <- var(V$Y) / n + var(V$X) / m 104 | } else if (method == "obuchowski") { 105 | var <- var_roc_obuchowski(roc) / length(roc$cases) 106 | } else { 107 | var <- var_roc_bootstrap(roc, boot.n, boot.stratified, parallel, ...) 108 | } 109 | 110 | if (percent) { 111 | var <- var * (100^2) 112 | } 113 | return(var) 114 | } 115 | 116 | var_roc_bootstrap <- function(roc, boot.n, boot.stratified, parallel, ...) { 117 | ## Smoothed ROC curve variance 118 | if (inherits(roc, "smooth.roc")) { 119 | smoothing.args <- roc$smoothing.args 120 | smoothing.args$smooth <- TRUE 121 | non.smoothed.roc <- attr(roc, "roc") 122 | non.smoothed.roc$percent <- FALSE # as we did earlier for the smoothed.roc 123 | smooth.roc.call <- as.call(c(utils::getS3method("smooth", "roc"), roc$smoothing.args)) 124 | auc.args <- attributes(roc$auc)[grep("partial.auc", names(attributes(roc$auc)))] 125 | auc.args$allow.invalid.partial.auc.correct <- TRUE 126 | auc.call <- as.call(c(utils::getS3method("auc", "smooth.roc"), auc.args)) 127 | 128 | if (boot.stratified) { 129 | aucs <- unlist(lapply(seq_len(boot.n), stratified.ci.smooth.auc, roc = non.smoothed.roc, smooth.roc.call = smooth.roc.call, auc.call = auc.call)) 130 | } else { 131 | aucs <- unlist(lapply(seq_len(boot.n), nonstratified.ci.smooth.auc, roc = non.smoothed.roc, smooth.roc.call = smooth.roc.call, auc.call = auc.call)) 132 | } 133 | } 134 | ## Non smoothed ROC curves variance 135 | else { 136 | if (boot.stratified) { 137 | aucs <- unlist(lapply(seq_len(boot.n), stratified.ci.auc, roc = roc)) # ci.auc: returns aucs just as we need for var, so re-use it! 138 | } else { 139 | aucs <- unlist(lapply(seq_len(boot.n), nonstratified.ci.auc, roc = roc)) 140 | } 141 | } 142 | 143 | if ((num.NAs <- sum(is.na(aucs))) > 0) { 144 | warning(sprintf("%i NA value(s) produced during bootstrap were ignored.", num.NAs)) 145 | aucs <- aucs[!is.na(aucs)] 146 | } 147 | return(var(aucs)) 148 | } 149 | -------------------------------------------------------------------------------- /R/venkatraman.R: -------------------------------------------------------------------------------- 1 | # pROC: Tools Receiver operating characteristic (ROC curves) with 2 | # (partial) area under the curve, confidence intervals and comparison. 3 | # Copyright (C) 2010-2014 Xavier Robin, Alexandre Hainard, Natacha Turck, 4 | # Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez 5 | # and Markus Müller 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU General Public License 18 | # along with this program. If not, see . 19 | 20 | venkatraman.paired.test <- function(roc1, roc2, boot.n, ties.method = "first") { 21 | X <- roc1$predictor 22 | Y <- roc2$predictor 23 | R <- rank(X, ties.method = ties.method) 24 | S <- rank(Y, ties.method = ties.method) 25 | D <- roc1$response # because roc1&roc2 are paired 26 | 27 | E <- venkatraman.paired.stat(R, S, D, roc1$levels) 28 | EP <- vapply(seq_len(boot.n), venkatraman.paired.permutation, FUN.VALUE = double(1L), R = R, S = S, D = D, levels = roc1$levels, ties.method = ties.method) 29 | return(list(E, EP)) 30 | } 31 | 32 | venkatraman.unpaired.test <- function(roc1, roc2, boot.n, ties.method = "first") { 33 | X <- roc1$predictor 34 | Y <- roc2$predictor 35 | R <- rank(X, ties.method = ties.method) 36 | S <- rank(Y, ties.method = ties.method) 37 | D1 <- roc1$response 38 | D2 <- roc2$response 39 | mp <- (sum(D1 == roc1$levels[2]) + sum(D2 == roc2$levels[2])) / (length(D1) + length(D1)) # mixing proportion, kappa 40 | 41 | E <- venkatraman.unpaired.stat(R, S, D1, D2, roc1$levels, roc2$levels, mp) 42 | EP <- vapply(seq_len(boot.n), venkatraman.unpaired.permutation, FUN.VALUE = double(1L), R = R, S = S, D1 = D1, D2 = D2, levels1 = roc1$levels, levels2 = roc2$levels, mp = mp, ties.method = ties.method) 43 | return(list(E, EP)) 44 | } 45 | 46 | venkatraman.paired.permutation <- function(n, R, S, D, levels, ties.method) { 47 | # Break ties 48 | R2 <- R + runif(length(D)) - 0.5 # Add small amount of random but keep same mean 49 | S2 <- S + runif(length(D)) - 0.5 50 | 51 | # Permutation 52 | q <- 1 - round(runif(length(D))) 53 | R3 <- R2 * q + (1 - q) * S 54 | S3 <- S2 * q + (1 - q) * R 55 | 56 | return(venkatraman.paired.stat(rank(R3, ties.method = ties.method), rank(S3, ties.method = ties.method), D, levels)) 57 | } 58 | 59 | venkatraman.unpaired.permutation <- function(n, R, S, D1, D2, levels1, levels2, mp, ties.method) { 60 | # Break ties 61 | R <- R + runif(length(D1)) - 0.5 # Add small amount of random but keep same mean 62 | S <- S + runif(length(D2)) - 0.5 63 | 64 | R.controls <- R[D1 == levels1[1]] 65 | R.cases <- R[D1 == levels1[2]] 66 | S.controls <- S[D2 == levels2[1]] 67 | S.cases <- S[D2 == levels2[2]] 68 | 69 | # Permutation 70 | controls <- sample(c(R.controls, S.controls)) 71 | cases <- sample(c(R.cases, S.cases)) 72 | R[D1 == levels1[1]] <- controls[1:length(R.controls)] 73 | S[D2 == levels2[1]] <- controls[(length(R.controls) + 1):length(controls)] 74 | R[D1 == levels1[2]] <- cases[1:length(R.cases)] 75 | S[D2 == levels2[2]] <- cases[(length(R.cases) + 1):length(cases)] 76 | 77 | return(venkatraman.unpaired.stat(rank(R, ties.method = ties.method), rank(S, ties.method = ties.method), D1, D2, levels1, levels2, mp)) 78 | } 79 | 80 | venkatraman.paired.stat <- function(R, S, D, levels) { 81 | R.controls <- R[D == levels[1]] 82 | R.cases <- R[D == levels[2]] 83 | S.controls <- S[D == levels[1]] 84 | S.cases <- S[D == levels[2]] 85 | n <- length(D) 86 | 87 | R.fn <- sapply(1:n, function(x) sum(R.cases <= x)) 88 | R.fp <- sapply(1:n, function(x) sum(R.controls > x)) 89 | S.fn <- sapply(1:n, function(x) sum(S.cases <= x)) 90 | S.fp <- sapply(1:n, function(x) sum(S.controls > x)) 91 | 92 | return(sum(abs((S.fn + S.fp) - (R.fn + R.fp)))) 93 | } 94 | 95 | venkatraman.unpaired.stat <- function(R, S, D1, D2, levels1, levels2, mp) { 96 | R.controls <- R[D1 == levels1[1]] 97 | R.cases <- R[D1 == levels1[2]] 98 | S.controls <- S[D2 == levels2[1]] 99 | S.cases <- S[D2 == levels2[2]] 100 | n <- length(D1) 101 | m <- length(D2) 102 | 103 | R.fx <- sapply(1:n, function(x) sum(R.cases <= x)) / length(R.cases) 104 | R.gx <- sapply(1:n, function(x) sum(R.controls <= x)) / length(R.controls) 105 | S.fx <- sapply(1:m, function(x) sum(S.cases <= x)) / length(S.cases) 106 | S.gx <- sapply(1:m, function(x) sum(S.controls <= x)) / length(S.controls) 107 | R.p <- mp * R.fx + (1 - mp) * R.gx 108 | S.p <- mp * S.fx + (1 - mp) * S.gx 109 | R.exp <- mp * R.fx + (1 - mp) * (1 - R.gx) 110 | S.exp <- mp * S.fx + (1 - mp) * (1 - S.gx) 111 | 112 | # Do the integration 113 | x <- sort(c(R.p, S.p)) 114 | R.f <- approxfun(R.p, R.exp) 115 | S.f <- approxfun(S.p, S.exp) 116 | f <- function(x) abs(R.f(x) - S.f(x)) 117 | y <- f(x) 118 | # trapezoid integration: 119 | idx <- 2:length(x) 120 | integral <- sum(((y[idx] + y[idx - 1]) * (x[idx] - x[idx - 1])) / 2, na.rm = TRUE) # remove NA that can appear in the borders 121 | return(integral) 122 | } 123 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # DO NOT CHANGE the "init" and "install" sections below 2 | 3 | # Download script file from GitHub 4 | init: 5 | ps: | 6 | $ErrorActionPreference = "Stop" 7 | Invoke-WebRequest http://raw.github.com/krlmlr/r-appveyor/master/scripts/appveyor-tool.ps1 -OutFile "..\appveyor-tool.ps1" 8 | Import-Module '..\appveyor-tool.ps1' 9 | 10 | install: 11 | ps: Bootstrap 12 | 13 | cache: 14 | - C:\RLibrary 15 | 16 | # Adapt as necessary starting from here 17 | 18 | environment: 19 | global: 20 | WARNINGS_ARE_ERRORS: 1 21 | RUN_SLOW_TESTS: true 22 | 23 | matrix: 24 | - R_VERSION: release 25 | R_ARCH: x64 26 | 27 | - R_VERSION: stable 28 | 29 | - R_VERSION: patched 30 | 31 | # devel version failing because of utf8 package 32 | - R_VERSION: devel 33 | GCC_PATH: mingw_32 34 | 35 | - R_VERSION: devel 36 | R_ARCH: x64 37 | GCC_PATH: mingw_64 38 | 39 | matrix: 40 | fast_finish: false 41 | 42 | build_script: 43 | - travis-tool.sh install_deps 44 | 45 | test_script: 46 | - travis-tool.sh run_tests 47 | 48 | on_failure: 49 | - 7z a failure.zip *.Rcheck\* 50 | - appveyor PushArtifact failure.zip 51 | 52 | #on_success: 53 | # - Rscript -e "install.packages('covr'); library(covr); codecov()" 54 | 55 | artifacts: 56 | - path: '*.Rcheck\**\*.log' 57 | name: Logs 58 | 59 | - path: '*.Rcheck\**\*.out' 60 | name: Logs 61 | 62 | - path: '*.Rcheck\**\*.fail' 63 | name: Logs 64 | 65 | - path: '*.Rcheck\**\*.Rout' 66 | name: Logs 67 | 68 | - path: '\*_*.tar.gz' 69 | name: Bits 70 | 71 | - path: '\*_*.zip' 72 | name: Bits 73 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | coverage: 2 | round: nearest 3 | range: "0...100" 4 | status: 5 | patch: # Coverage/Hits of the patch itself 6 | default: 7 | enabled: true 8 | informational: true # Show it, but don't fail the check 9 | project: 10 | default: 11 | target: 80% 12 | threshold: 1% 13 | -------------------------------------------------------------------------------- /data/aSAH.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xrobin/pROC/ee2877e858bcd2757c05ce797ea64ade2c05885b/data/aSAH.RData -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("If you use pROC in published research, please cite the following paper:") 2 | 3 | bibentry(bibtype="Article", 4 | title = "pROC: an open-source package for R and S+ to analyze and compare ROC curves", 5 | author = c(as.person("Xavier Robin"), as.person("Natacha Turck") , as.person("Alexandre Hainard") , as.person("Natalia Tiberti") , as.person("Frédérique Lisacek") , as.person("Jean-Charles Sanchez"), as.person("Markus Müller")), 6 | year = 2011, 7 | journal = "BMC Bioinformatics", 8 | volume = 12, 9 | pages = 77, 10 | #doi = "10.1186/1471-2105-12-77", # removed: takes too much space 11 | #url = "http://www.biomedcentral.com/1471-2105/12/77/", 12 | textVersion = "Xavier Robin, Natacha Turck, Alexandre Hainard, Natalia Tiberti, Frédérique Lisacek, Jean-Charles Sanchez and Markus Müller (2011). pROC: an open-source package for R and S+ to analyze and compare ROC curves. BMC Bioinformatics, 12, p. 77.\n DOI: 10.1186/1471-2105-12-77 " 13 | ) 14 | -------------------------------------------------------------------------------- /inst/extra/bench/fig-unnamed-chunk-13-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xrobin/pROC/ee2877e858bcd2757c05ce797ea64ade2c05885b/inst/extra/bench/fig-unnamed-chunk-13-1.png -------------------------------------------------------------------------------- /inst/extra/bench/fig-unnamed-chunk-5-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xrobin/pROC/ee2877e858bcd2757c05ce797ea64ade2c05885b/inst/extra/bench/fig-unnamed-chunk-5-1.png -------------------------------------------------------------------------------- /inst/extra/bench/fig-unnamed-chunk-9-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xrobin/pROC/ee2877e858bcd2757c05ce797ea64ade2c05885b/inst/extra/bench/fig-unnamed-chunk-9-1.png -------------------------------------------------------------------------------- /inst/extra/benchmark.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # Benchmarks 5 | 6 | These benchmarks compare pROC with competing ROC analysis packages in R. 7 | They can serve as a way to detect performance bottleneck that must be 8 | fixed, and possible regressions in performance. 9 | 10 | The benchmarking are carried out with the **microbenchmark** package and 11 | randomly generated data. The values of the `x` predictor variable are 12 | drawn from a normal distribution, resulting in every value being 13 | essentially unique. Predictor values for positive examples are increased 14 | to have a mean of 1, resulting in ROC curves with an AUC of 0.76. 15 | 16 | 17 | 18 | The benchmark code is adapted from the [cutpointr vignette by Christian 19 | Thiele](https://github.com/Thie1e/cutpointr/blob/master/vignettes/cutpointr.Rmd), 20 | released under a GPL-3 license. 21 | 22 | ## Building the ROC curve 23 | 24 | This first benchmark looks at the time needed to building the ROC curve 25 | only, and getting sensitivities, specificities and thresholds. Only 26 | packages allowing turn off the calculation of the AUC, or not computing 27 | it by default, were tested. 28 | 29 | ![](bench/fig-unnamed-chunk-5-1.png) 30 | 31 | | n | pROC | ROCR | 32 | | -------: | -----------: | ----------: | 33 | | 1e+03 | 0.6579095 | 2.059954 | 34 | | 1e+04 | 3.6905450 | 5.727894 | 35 | | 1e+05 | 41.4205780 | 49.021695 | 36 | | 1e+06 | 600.3593600 | 643.874491 | 37 | | 1e+07 | 8220.1797555 | 9012.922116 | 38 | | \#\# AUC | | | 39 | 40 | This benchmark tests how long it takes to calculate the ROC curve and 41 | the area under the ROC curve (AUC). 42 | 43 | ![](bench/fig-unnamed-chunk-9-1.png) 44 | 45 | | n | Epi | pROC | PRROC | ROCR | 46 | | ----: | ----------: | ----------: | ---------: | ----------: | 47 | | 1e+03 | 5.635899 | 0.683097 | 0.33761 | 2.184626 | 48 | | 1e+04 | 66.644144 | 5.037177 | 2.21852 | 7.965816 | 49 | | 1e+05 | 579.622447 | 35.752837 | 15.31815 | 44.327074 | 50 | | 1e+06 | 8352.085559 | 583.754913 | 181.14614 | 757.437651 | 51 | | 1e+07 | NA | 8276.516090 | 2899.50254 | 9149.835111 | 52 | 53 | ## Best threshold 54 | 55 | Benchmarks packages that extract the “best” threshold. At the moment 56 | they all use the Youden index. This includes building the ROC curve 57 | first. 58 | 59 | #> Multiple optimal cutpoints found 60 | #> Multiple optimal cutpoints found 61 | #> Multiple optimal cutpoints found 62 | #> Multiple optimal cutpoints found 63 | #> Multiple optimal cutpoints found 64 | #> Multiple optimal cutpoints found 65 | #> Multiple optimal cutpoints found 66 | #> Multiple optimal cutpoints found 67 | #> Multiple optimal cutpoints found 68 | #> Multiple optimal cutpoints found 69 | #> Multiple optimal cutpoints found 70 | #> Multiple optimal cutpoints found 71 | #> Multiple optimal cutpoints found 72 | #> Multiple optimal cutpoints found 73 | #> Multiple optimal cutpoints found 74 | #> Multiple optimal cutpoints found 75 | #> Multiple optimal cutpoints found 76 | #> Multiple optimal cutpoints found 77 | #> Multiple optimal cutpoints found 78 | #> Multiple optimal cutpoints found 79 | 80 | ![](bench/fig-unnamed-chunk-13-1.png) 81 | 82 | | n | cutpointr | OptimalCutpoints | pROC | ThresholdROC | 83 | | ----: | ----------: | ---------------: | ----------: | -----------: | 84 | | 1e+02 | 4.779029 | 1.959683 | 0.569432 | 1.032499 | 85 | | 1e+03 | 5.395060 | 30.739701 | 1.034866 | 22.389875 | 86 | | 1e+04 | 7.195595 | 2902.387499 | 4.311928 | 2018.123223 | 87 | | 1e+05 | 26.105981 | NA | 39.171103 | NA | 88 | | 1e+06 | 276.263793 | NA | 579.522941 | NA | 89 | | 1e+07 | 4258.031252 | NA | 8329.708682 | NA | 90 | -------------------------------------------------------------------------------- /inst/extra/sos_clashes.R: -------------------------------------------------------------------------------- 1 | # Need to export R_MAX_NUM_DLLS=1000 before sourcing this script. 2 | 3 | library(sos) 4 | library(htmlTable) 5 | library(stringr) 6 | library(dplyr) 7 | 8 | # Get auc functions 9 | auc.search <- findFn("auc") 10 | auc.functions <- auc.search %>% 11 | filter(Function == "auc", Package != "pROC") %>% 12 | select(Package, Function, Description, Link) 13 | rownames(auc.functions) <- auc.functions$Package 14 | 15 | ci.search <- findFn("ci") 16 | ci.functions <- ci.search %>% 17 | filter(Function == "ci", Package != "pROC") %>% 18 | select(Package, Function, Description, Link) 19 | rownames(ci.functions) <- ci.functions$Package 20 | 21 | # Get roc functions 22 | roc.search <- findFn("roc") 23 | roc.functions <- roc.search %>% 24 | filter(Function == "roc", Package != "pROC") %>% 25 | select(Package, Function, Description, Link) 26 | rownames(roc.functions) <- roc.functions$Package 27 | 28 | 29 | # Install missing packages 30 | missing.packages <- auc.functions$Package[ ! auc.functions$Package %in% installed.packages()[,"Package"]] 31 | if (length(missing.packages) > 0) 32 | install.packages(missing.packages) 33 | missing.packages <- roc.functions$Package[ ! roc.functions$Package %in% installed.packages()[,"Package"]] 34 | if (length(missing.packages) > 0) 35 | install.packages(missing.packages) 36 | 37 | missing.packages <- ci.functions$Package[ ! ci.functions$Package %in% installed.packages()[,"Package"]] 38 | if (length(missing.packages) > 0) 39 | install.packages(missing.packages) 40 | 41 | # Filter packages that are still missing 42 | available.packages.with.auc <- auc.functions[auc.functions$Package %in% installed.packages()[,"Package"],] 43 | available.packages.with.roc <- roc.functions[roc.functions$Package %in% installed.packages()[,"Package"],] 44 | available.packages.with.ci <- ci.functions[ci.functions$Package %in% installed.packages()[,"Package"],] 45 | 46 | #' Check if a function within a package is a generic function 47 | #' @param pkg package name as a character string 48 | #' @param fun function name as a character string 49 | #' @return \code{TRUE} if the function is generic, \code{FALSE} otherwise. 50 | #' If the package doesn't contain a function named `fun`, \code{NA} is returned. 51 | is.function.in.package.generic <- function(pkg, fun) { 52 | old.search.pos <- search()[2] 53 | on.exit({ 54 | while (attr(parent.env(.GlobalEnv), "name") != old.search.pos) { 55 | detach(unload = TRUE) 56 | } 57 | }) 58 | suppressPackageStartupMessages(library(pkg, character.only = TRUE)) 59 | # Does the package actually have a roc function 60 | t <- try(get(fun), silent=TRUE) 61 | if (methods::is(t, "try-error")) { 62 | warning(sprintf("Package %s doesn't seem to contain function %s", pkg, fun)) 63 | return(NA) 64 | } 65 | if (utils::isS3stdGeneric(fun)) { 66 | return(TRUE) 67 | } 68 | if (methods::isGeneric(fun)) { 69 | return(TRUE) 70 | } 71 | return(FALSE) 72 | } 73 | 74 | # Test which packages have generic functions 75 | generics.auc <- sapply(available.packages.with.auc$Package, is.function.in.package.generic, fun="auc") 76 | generics.roc <- sapply(available.packages.with.roc$Package, is.function.in.package.generic, fun="roc") 77 | generics.ci <- sapply(available.packages.with.ci$Package, is.function.in.package.generic, fun="ci") 78 | 79 | # Prepare table 80 | available.packages.with.auc$Generic <- c("TRUE"="Generic", "FALSE"="Not Generic")[as.character(generics.auc)] 81 | available.packages.with.auc$auc <- sprintf('%s', available.packages.with.auc$Link, available.packages.with.auc$Generic) 82 | 83 | available.packages.with.roc$Generic <- c("TRUE"="Generic", "FALSE"="Not Generic")[as.character(generics.roc)] 84 | available.packages.with.roc$roc <- sprintf('%s', available.packages.with.roc$Link, available.packages.with.roc$Generic) 85 | 86 | available.packages.with.ci$Generic <- c("TRUE"="Generic", "FALSE"="Not Generic")[as.character(generics.ci)] 87 | available.packages.with.ci$ci <- sprintf('%s', available.packages.with.ci$Link, available.packages.with.ci$Generic) 88 | 89 | # Final table 90 | table <- data.frame( 91 | Package = union(union(available.packages.with.roc$Package, 92 | available.packages.with.auc$Package), 93 | available.packages.with.ci$Package)) 94 | rownames(table) <- table$Package 95 | table[available.packages.with.roc$Package, "roc"] <- available.packages.with.roc$roc 96 | table[available.packages.with.auc$Package, "auc"] <- available.packages.with.auc$auc 97 | table[available.packages.with.ci$Package, "ci"] <- available.packages.with.ci$ci 98 | 99 | # Format as HTML table 100 | htmlTable(table[order(table$Package), c("Package", "roc", "auc", "ci")], escape.html = FALSE, rnames=FALSE) 101 | -------------------------------------------------------------------------------- /man/aSAH.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{aSAH} 3 | \docType{data} 4 | \alias{aSAH} 5 | \title{ 6 | Subarachnoid hemorrhage data 7 | } 8 | \description{ 9 | This dataset summarizes several clinical and one laboratory variable 10 | of 113 patients with an aneurysmal subarachnoid hemorrhage. 11 | } 12 | \usage{aSAH} 13 | 14 | \format{A data.frame containing 113 observations of 7 variables.} 15 | 16 | \source{ 17 | Natacha Turck, Laszlo Vutskits, Paola Sanchez-Pena, Xavier 18 | Robin, Alexandre Hainard, Marianne Gex-Fabry, Catherine Fouda, Hadiji 19 | Bassem, Markus Mueller, Frédérique Lisacek, Louis Puybasset and 20 | Jean-Charles Sanchez (2010) ``A multiparameter panel method for outcome 21 | prediction following aneurysmal subarachnoid hemorrhage''. 22 | \emph{Intensive Care Medicine} \bold{36}(1), 107--115. DOI: 23 | \doi{10.1007/s00134-009-1641-y}. 24 | } 25 | 26 | \seealso{ 27 | Other examples can be found in all the documentation pages of this 28 | package: 29 | \code{\link{roc}}, \code{\link{auc}}, \code{\link{ci}}, 30 | \code{\link{ci.auc}}, \code{\link{ci.se}}, \code{\link{ci.sp}}, 31 | \code{\link{ci.thresholds}}, \code{\link{coords}}, 32 | \code{\link{plot.ci}}, \code{\link{plot.roc}}, 33 | \code{\link{print.roc}}, \code{\link{roc.test}} and 34 | \code{\link{smooth}}. 35 | 36 | An example analysis with pROC is shown in: 37 | 38 | Xavier Robin, Natacha Turck, Alexandre Hainard, \emph{et al.} 39 | (2011) ``pROC: an open-source package for R and S+ to analyze and 40 | compare ROC curves''. \emph{BMC Bioinformatics}, \bold{7}, 77. 41 | DOI: \doi{10.1186/1471-2105-12-77} 42 | } 43 | 44 | \examples{ 45 | # load the dataset 46 | data(aSAH) 47 | 48 | # Gender, outcome and set 49 | with(aSAH, table(gender, outcome)) 50 | 51 | # Age 52 | with(aSAH, by(age, outcome, mean)) 53 | with(aSAH, by(age, outcome, 54 | function(x) sprintf("mean: \%.1f (+/- \%.1f), median: \%.1f (\%i-\%i)", 55 | mean(x), sd(x), median(x), min(x), max(x)))) 56 | 57 | # WFNS score 58 | with(aSAH, table(wfns=ifelse(wfns<=2, "1-2", "3-4-5"), outcome)) 59 | 60 | } 61 | 62 | \keyword{datasets} 63 | -------------------------------------------------------------------------------- /man/are.paired.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{are.paired} 3 | \alias{are.paired} 4 | \alias{are.paired.smooth.roc} 5 | \alias{are.paired.auc} 6 | \alias{are.paired.roc} 7 | 8 | \title{ 9 | Are two ROC curves paired? 10 | } 11 | \description{ 12 | This function determines if two ROC curves can be paired. 13 | } 14 | \usage{ 15 | are.paired(...) 16 | \S3method{are.paired}{auc}(roc1, roc2, ...) 17 | \S3method{are.paired}{smooth.roc}(roc1, roc2, ...) 18 | \S3method{are.paired}{roc}(roc1, roc2, return.paired.rocs=FALSE, 19 | reuse.auc = TRUE, reuse.ci = FALSE, reuse.smooth=TRUE, ...) 20 | } 21 | 22 | \arguments{ 23 | \item{roc1, roc2}{the two ROC curves to compare. Either 24 | \dQuote{\link{roc}}, \dQuote{\link{auc}} or 25 | \dQuote{\link{smooth.roc}} objects (types can be mixed). 26 | } 27 | \item{return.paired.rocs}{if \code{TRUE} and the ROC curves can be 28 | paired, the two paired ROC curves with \code{NA}s removed will be 29 | returned. 30 | } 31 | \item{reuse.auc, reuse.ci, reuse.smooth}{ 32 | if \code{return.paired.rocs=TRUE}, determines if \code{\link{auc}}, 33 | \code{\link{ci}} and \code{\link[=smooth.roc]{smooth}} should be re-computed 34 | (with the same parameters than the original ROC curves) 35 | } 36 | \item{\dots}{additionnal arguments for \code{are.paired.roc}. Ignored 37 | in \code{are.paired.roc} 38 | } 39 | } 40 | 41 | \details{ 42 | Two ROC curves are paired if they are built on two variables observed 43 | on the same sample. 44 | 45 | In practice, the paired status is granted if the \code{response} and \code{levels} vector 46 | of both ROC curves are \link{identical}. If the \code{response}s are different, this can be 47 | due to missing values differing between the curves. In this case, the 48 | function will strip all \code{NA}s in both curves and check for 49 | identity again. 50 | 51 | It can raise false positives if the responses are identical but correspond 52 | to different patients. 53 | } 54 | 55 | \value{ 56 | \code{TRUE} if \code{roc1} and \code{roc2} are paired, \code{FALSE} 57 | otherwise. 58 | 59 | In addition, if \code{TRUE} and \code{return.paired.rocs=TRUE}, the 60 | following atributes are defined: 61 | \item{roc1, roc2}{the two ROC curve with all \code{NA}s values removed 62 | in both curves. 63 | } 64 | } 65 | 66 | \seealso{ 67 | \code{\link{roc}}, \code{\link{roc.test}} 68 | } 69 | 70 | \examples{ 71 | data(aSAH) 72 | aSAH.copy <- aSAH 73 | 74 | # artificially insert NAs for demonstration purposes 75 | aSAH.copy$outcome[42] <- NA 76 | aSAH.copy$s100b[24] <- NA 77 | aSAH.copy$ndka[1:10] <- NA 78 | 79 | # Call roc() on the whole data 80 | roc1 <- roc(aSAH.copy$outcome, aSAH.copy$s100b) 81 | roc2 <- roc(aSAH.copy$outcome, aSAH.copy$ndka) 82 | # are.paired can still find that the curves were paired 83 | are.paired(roc1, roc2) # TRUE 84 | 85 | # Removing the NAs manually before passing to roc() un-pairs the ROC curves 86 | nas <- is.na(aSAH.copy$outcome) | is.na(aSAH.copy$ndka) 87 | roc2b <- roc(aSAH.copy$outcome[!nas], aSAH.copy$ndka[!nas]) 88 | are.paired(roc1, roc2b) # FALSE 89 | 90 | # Getting the two paired ROC curves with additional smoothing and ci options 91 | roc2$ci <- ci(roc2) 92 | paired <- are.paired(smooth(roc1), roc2, return.paired.rocs=TRUE, reuse.ci=TRUE) 93 | paired.roc1 <- attr(paired, "roc1") 94 | paired.roc2 <- attr(paired, "roc2") 95 | 96 | } 97 | 98 | \keyword{programming} 99 | \keyword{logic} 100 | \keyword{roc} 101 | -------------------------------------------------------------------------------- /man/ci.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{ci} 3 | \alias{ci} 4 | \alias{ci.default} 5 | \alias{ci.formula} 6 | \alias{ci.roc} 7 | \alias{ci.smooth.roc} 8 | \alias{ci.multiclass.roc} 9 | \alias{ci.multiclass.auc} 10 | 11 | \title{ 12 | Compute the confidence interval of a ROC curve 13 | } 14 | \description{ 15 | This function computes the confidence interval (CI) of a ROC curve. The 16 | \code{of} argument controls the type of CI that will be computed. 17 | } 18 | \usage{ 19 | ci(...) 20 | \S3method{ci}{roc}(roc, of = c("auc", "thresholds", "sp", "se", "coords"), ...) 21 | \S3method{ci}{smooth.roc}(smooth.roc, of = c("auc", "sp", "se", "coords"), ...) 22 | \S3method{ci}{multiclass.roc}(multiclass.roc, of = "auc", ...) 23 | \S3method{ci}{multiclass.auc}(multiclass.auc, of = "auc", ...) 24 | \S3method{ci}{formula}(formula, data, ...) 25 | \S3method{ci}{default}(response, predictor, ...) 26 | } 27 | 28 | \arguments{ 29 | \item{roc, smooth.roc}{a \dQuote{roc} object from the 30 | \code{\link{roc}} function, or a \dQuote{smooth.roc} object from the 31 | \code{\link[=smooth.roc]{smooth}} function. 32 | } 33 | \item{multiclass.roc, multiclass.auc}{not implemented.} 34 | \item{response, predictor}{arguments for the \code{\link{roc}} function.} 35 | \item{formula, data}{a formula (and possibly a data object) of type 36 | response~predictor for the \code{\link{roc}} function. 37 | } 38 | \item{of}{The type of confidence interval. One of \dQuote{auc}, 39 | \dQuote{thresholds}, \dQuote{sp}, \dQuote{se} or \dQuote{coords}. Note that 40 | confidence interval on \dQuote{thresholds} are not available for 41 | smoothed ROC curves. 42 | } 43 | \item{\dots}{further arguments passed to or from other methods, 44 | especially \code{\link{auc}}, \code{\link{roc}}, and the specific 45 | \code{ci} functions \code{\link{ci.auc}}, \code{\link{ci.se}}, 46 | \code{\link{ci.sp}} and \code{\link{ci.thresholds}}. 47 | } 48 | } 49 | 50 | \details{ 51 | \code{ci.formula} and \code{ci.default} are convenience methods 52 | that build the ROC curve (with the \code{\link{roc}} function) before 53 | calling \code{ci.roc}. You can pass them arguments for both 54 | \code{\link{roc}} and \code{ci.roc}. Simply use \code{ci} 55 | that will dispatch to the correct method. 56 | 57 | This function is typically called from \code{\link{roc}} when \code{ci=TRUE} (not by 58 | default). Depending on the \code{of} argument, the specific 59 | \code{ci} functions \code{\link{ci.auc}}, \code{\link{ci.thresholds}}, 60 | \code{\link{ci.sp}}, \code{\link{ci.se}} or \code{\link{ci.coords}} are called. 61 | 62 | When the ROC curve has an \code{\link{auc}} of 1 (or 100\%), the confidence interval will always be null 63 | (there is no interval). This is true for both \dQuote{delong} and \dQuote{bootstrap} methods that can 64 | not properly assess the variance in this case. This result is misleading, as the variance is of course not null. 65 | A \code{\link{warning}} will be displayed to inform of this condition, and of the misleading output. 66 | 67 | CI of multiclass ROC curves and AUC is not implemented yet. Attempting to call these 68 | methods returns an error. 69 | } 70 | 71 | \value{ 72 | The return value of the specific \code{ci} functions 73 | \code{\link{ci.auc}}, \code{\link{ci.thresholds}}, \code{\link{ci.sp}}, \code{\link{ci.se}} or \code{\link{ci.coords}}, depending on the 74 | \code{of} argument. 75 | } 76 | 77 | \references{ 78 | Xavier Robin, Natacha Turck, Alexandre Hainard, \emph{et al.} 79 | (2011) ``pROC: an open-source package for R and S+ to analyze and 80 | compare ROC curves''. \emph{BMC Bioinformatics}, \bold{7}, 77. 81 | DOI: \doi{10.1186/1471-2105-12-77}. 82 | } 83 | 84 | \seealso{ 85 | \code{\link{roc}}, \code{\link{auc}}, \code{\link{ci.auc}}, 86 | \code{\link{ci.thresholds}}, \code{\link{ci.sp}}, \code{\link{ci.se}}, \code{\link{ci.coords}} 87 | } 88 | 89 | \examples{ 90 | 91 | # Create a ROC curve: 92 | data(aSAH) 93 | roc1 <- roc(aSAH$outcome, aSAH$s100b) 94 | 95 | 96 | ## AUC ## 97 | ci(roc1) 98 | # this is equivalent to: 99 | ci(roc1, of = "auc") 100 | # or: 101 | ci.auc(roc1) 102 | 103 | 104 | ## Coordinates ## 105 | \dontrun{ 106 | # Thresholds 107 | ci(roc1, of = "thresholds") 108 | ci(roc1, of = "thresholds", thresholds = "all") 109 | ci(roc1, of = "thresholds", thresholds = 0.51) 110 | # equivalent to: 111 | ci.thresholds(roc1, thresholds = 0.51) 112 | 113 | # SE/SP 114 | ci(roc1, of = "sp", sensitivities = c(.95, .9, .85)) 115 | ci.sp(roc1) 116 | ci(roc1, of = "se") 117 | ci.se(roc1) 118 | 119 | # Arbitrary coordinates 120 | ci(roc1, of = "coords", "best") 121 | ci.coords(roc1, 0.51, "threshold")} 122 | 123 | } 124 | 125 | \keyword{univar} 126 | \keyword{nonparametric} 127 | \keyword{utilities} 128 | \keyword{roc} 129 | -------------------------------------------------------------------------------- /man/coords_transpose.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{coords_transpose} 3 | \alias{coords_transpose} 4 | 5 | \title{Transposing the output of \code{coords}} 6 | 7 | \description{This help page desribes recent and upcoming changes in the 8 | return values of the \code{\link{coords}} function.} 9 | 10 | \section{Background information}{ 11 | 12 | Until the release of pROC 1.16, the \code{coords} function was returning 13 | a matrix with thresholds in columns, and the coordinate variables in rows. 14 | 15 | \preformatted{ 16 | data(aSAH) 17 | rocobj <- roc(aSAH$outcome, aSAH$s100b) 18 | coords(rocobj, c(0.05, 0.2, 0.5)) 19 | # 0.05 0.2 0.5 20 | # threshold 0.05000000 0.2000000 0.5000000 21 | # specificity 0.06944444 0.8055556 0.9722222 22 | # sensitivity 0.97560976 0.6341463 0.2926829 23 | 24 | } 25 | 26 | This format didn't conform to the grammar of the 27 | \href{https://www.tidyverse.org/}{tidyverse} which has become prevalent in modern 28 | R language. 29 | 30 | In addition, the dropping of dimensions by default makes it difficult to guess 31 | what type of data \code{coords} is going to return. 32 | 33 | \preformatted{ 34 | coords(rocobj, "best") 35 | # threshold specificity sensitivity 36 | # 0.2050000 0.8055556 0.6341463 37 | # A numeric vector 38 | 39 | } 40 | 41 | Although it is possible to pass \code{drop = FALSE}, the fact that it is not the 42 | default makes the behaviour unintuitive. 43 | 44 | In pROC version 1.16, this was changed and \code{coords} now returns 45 | a \code{\link{data.frame}} with the thresholds in rows and measurement in colums by default. 46 | 47 | \preformatted{ 48 | coords(rocobj, c(0.05, 0.2, 0.5), transpose = FALSE) 49 | # threshold specificity sensitivity 50 | # 0.05 0.05 0.06944444 0.9756098 51 | # 0.2 0.20 0.80555556 0.6341463 52 | # 0.5 0.50 0.97222222 0.2926829 53 | } 54 | } 55 | 56 | \section{Changes in 1.15}{ 57 | \enumerate{ 58 | \item{Addition of the \code{transpose} argument.} 59 | \item{Display a warning if \code{transpose} is missing. Pass \code{transpose} explicitly to silence the warning.} 60 | \item{Deprecation of \code{as.list}.} 61 | } 62 | } 63 | 64 | \section{Changes in 1.16}{ 65 | \itemize{ 66 | \item{Change of the default \code{transpose} to \code{TRUE}.} 67 | } 68 | THIS CHANGE IS BACKWARDS INCOMPATIBLE AND IS EXPECTED TO BREAK LEGACY CODE. 69 | } 70 | 71 | \section{Changes in 1.17}{ 72 | \itemize{ 73 | \item{Dropped the warning if \code{transpose} is missing.} 74 | } 75 | } 76 | 77 | \section{Changes in 1.19}{ 78 | \enumerate{ 79 | \item{Setting \code{transpose=TRUE} is deprecated and triggers a warning.} 80 | \item{The \code{as.list}, \code{as.matrix} and \code{drop} are deprecated. 81 | Setting them to any value triggers a waring.} 82 | \item{\code{transpose=FALSE} continues to work normally.} 83 | } 84 | } 85 | 86 | \section{Changes in future versions}{ 87 | \enumerate{ 88 | \item{Setting \code{transpose} to \code{TRUE} will stop working and result 89 | in an error.} 90 | \item{The \code{drop}, \code{as.list} and \code{as.matrix} arguments will 91 | be removed.} 92 | \item{\code{transpose=FALSE} will keep working indefinitely.} 93 | } 94 | } 95 | 96 | \section{Related changes in ci.coords}{ 97 | In version 1.16, the format of the \code{\link{ci.coords}} return value was changed from a matrix-like object with mixed \code{x} and \code{ret} in rows and 3 columns, into a list-like object which should be easier to use programatically. 98 | } 99 | 100 | \section{See also}{ 101 | \href{https://github.com/xrobin/pROC/issues/54}{The GitHub issue tracking the changes described in this manual page}. 102 | } 103 | 104 | -------------------------------------------------------------------------------- /man/geom_polygon_auc.roc.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{geom_polygon_auc} 3 | \alias{geom_polygon_auc.auc} 4 | \alias{geom_polygon_auc.roc} 5 | \alias{geom_polygon_auc.smooth.roc} 6 | \alias{geom_polygon_auc} 7 | 8 | \title{ 9 | Add an AUC polygon to a ggroc plot 10 | } 11 | \description{ 12 | EXPERIMENTAL - Add an AUC polygon to a ggroc plot. 13 | } 14 | \usage{ 15 | \S3method{geom_polygon_auc}{auc}(data, legacy.axes = FALSE, ...) 16 | \S3method{geom_polygon_auc}{roc}(data, ...) 17 | \S3method{geom_polygon_auc}{smooth.roc}(data, ...) 18 | } 19 | 20 | \arguments{ 21 | \item{data}{a roc object from the \link{roc} function, same as the one 22 | used to build the ggroc initially. 23 | } 24 | \item{legacy.axes}{must match the value given to \code{ggroc}. 25 | } 26 | \item{...}{additional aesthetics for \code{\link[ggplot2:geom_polygon]{geom_polygon}} 27 | to set: \code{alpha}, \code{colour}, \code{linetype} and \code{linewidth}. 28 | } 29 | } 30 | 31 | \details{ 32 | This is highly experimental and may change in the future. 33 | } 34 | 35 | 36 | \seealso{ 37 | \code{\link{ggroc}} 38 | } 39 | \examples{ 40 | 41 | # Create a ROC curve: 42 | data(aSAH) 43 | roc.s100b <- roc(aSAH$outcome, aSAH$s100b) 44 | roc.s100b.percent <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE) 45 | 46 | ggroc(roc.s100b) + geom_polygon_auc(roc.s100b$auc) 47 | 48 | # legacy.axes must be repeated 49 | ggroc(roc.s100b.percent, legacy.axes=TRUE) + geom_polygon_auc(roc.s100b.percent, legacy.axes=TRUE) 50 | 51 | # Partial AUCs 52 | auc.s100b.partial.sp <- auc(roc.s100b, partial.auc = c(0.9, 1)) 53 | auc.s100b.partial.se <- auc(roc.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus="se") 54 | 55 | ggroc(roc.s100b) + geom_polygon_auc(auc.s100b.partial.sp) 56 | ggroc(roc.s100b) + geom_polygon_auc(auc.s100b.partial.se) 57 | 58 | } 59 | -------------------------------------------------------------------------------- /man/ggroc.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{ggroc.roc} 3 | \alias{ggroc.roc} 4 | \alias{ggroc.smooth.roc} 5 | \alias{ggroc.list} 6 | \alias{ggroc} 7 | 8 | \title{ 9 | Plot a ROC curve with ggplot2 10 | } 11 | \description{ 12 | This function plots a ROC curve with ggplot2. 13 | } 14 | \usage{ 15 | \S3method{ggroc}{roc}(data, legacy.axes = FALSE, ...) 16 | \S3method{ggroc}{smooth.roc}(data, legacy.axes = FALSE, ...) 17 | \S3method{ggroc}{list}(data, aes = c("colour", "alpha", "linetype", "linewidth", "size", "group"), 18 | legacy.axes = FALSE, ...) 19 | } 20 | 21 | \arguments{ 22 | \item{data}{a roc object from the \link{roc} function, or a list of roc objects. 23 | } 24 | \item{aes}{the name(s) of the aesthetics for \code{\link[ggplot2:geom_path]{geom_line}} 25 | to map to the different ROC curves supplied. 26 | } 27 | \item{legacy.axes}{a logical indicating if the specificity axis (x 28 | axis) must be plotted as as decreasing \dQuote{specificity} 29 | (\code{FALSE}, the default) or increasing \dQuote{1 - specificity} 30 | (\code{TRUE}) as in most legacy software. 31 | } 32 | \item{...}{additional aesthetics for \code{\link[ggplot2:geom_path]{geom_line}} 33 | to set: \code{alpha}, \code{colour}, \code{linetype}, \code{linewidth} 34 | (new in ggplot2 3.4.0), and \code{size} (before ggplot2 3.4.0). 35 | The \code{group} aesthetic is always active since version 1.18.5 and is 36 | kept for backwards compatibility. 37 | } 38 | } 39 | 40 | \details{ 41 | This function initializes a ggplot object from a ROC curve (or multiple if a list is passed). It returns the ggplot with a line layer on it. You can print it directly or add your own layers and theme elements. 42 | } 43 | 44 | 45 | \seealso{ 46 | \code{\link{roc}}, \code{\link{plot.roc}}, \pkg{\link[ggplot2:ggplot2-package]{ggplot2}} 47 | } 48 | \examples{ 49 | # Create a basic roc object 50 | data(aSAH) 51 | rocobj <- roc(aSAH$outcome, aSAH$s100b) 52 | rocobj2 <- roc(aSAH$outcome, aSAH$wfns) 53 | 54 | if (require(ggplot2)) { 55 | g <- ggroc(rocobj) 56 | g 57 | # with additional aesthetics: 58 | ggroc(rocobj, alpha = 0.5, colour = "red", linetype = 2, size = 2) 59 | 60 | # You can then your own theme, etc. 61 | g + theme_minimal() + ggtitle("My ROC curve") + 62 | geom_segment(aes(x = 1, xend = 0, y = 0, yend = 1), color="grey", linetype="dashed") 63 | 64 | # And change axis labels to FPR/FPR 65 | gl <- ggroc(rocobj, legacy.axes = TRUE) 66 | gl 67 | gl + xlab("FPR") + ylab("TPR") + 68 | geom_segment(aes(x = 0, xend = 1, y = 0, yend = 1), color="darkgrey", linetype="dashed") 69 | 70 | # Multiple curves: 71 | g2 <- ggroc(list(s100b=rocobj, wfns=rocobj2, ndka=roc(aSAH$outcome, aSAH$ndka))) 72 | g2 73 | 74 | # This is equivalent to using roc.formula: 75 | roc.list <- roc(outcome ~ s100b + ndka + wfns, data = aSAH) 76 | g.list <- ggroc(roc.list) 77 | g.list 78 | 79 | # You can change the aesthetics as you normally would with ggplot2: 80 | g.list + scale_colour_brewer(palette="RdGy") 81 | g.list + scale_colour_manual(values = c("red", "blue", "black")) 82 | 83 | # with additional aesthetics: 84 | g3 <- ggroc(roc.list, linetype=2) 85 | g3 86 | g4 <- ggroc(roc.list, aes="linetype", color="red") 87 | g4 88 | # changing multiple aesthetics: 89 | g5 <- ggroc(roc.list, aes=c("linetype", "color")) 90 | g5 91 | 92 | # OR faceting 93 | g.list + facet_grid(.~name) + theme(legend.position="none") 94 | } 95 | } 96 | -------------------------------------------------------------------------------- /man/groupGeneric.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{groupGeneric} 3 | \alias{groupGeneric} 4 | \alias{groupGeneric.pROC} 5 | \alias{groupGeneric.auc} 6 | \alias{groupGeneric.ci.coords} 7 | \alias{groupGeneric.ci.se} 8 | \alias{groupGeneric.ci.sp} 9 | \alias{Ops} 10 | \alias{Math} 11 | \alias{Ops.auc} 12 | \alias{Math.auc} 13 | \alias{Ops.ci.coords} 14 | \alias{Math.ci.coords} 15 | \alias{Ops.ci.se} 16 | \alias{Math.ci.se} 17 | \alias{Ops.ci.sp} 18 | \alias{Math.ci.sp} 19 | \alias{Ops.ci.auc} 20 | \alias{Math.ci.auc} 21 | \alias{Ops.ci} 22 | \alias{Math.ci} 23 | 24 | 25 | \title{ 26 | pROC Group Generic Functions 27 | } 28 | \description{ 29 | Redefine \pkg{base} groupGeneric functions to handle \code{\link{auc}} and \code{\link{ci}} objects properly on operations and mathematical operations. 30 | Attributes are dropped so that the AUC/CI behaves as a numeric value/matrix, respectively. 31 | In the case of AUC, all attributes are dropped, while in CI only the CI-specific attributes are, keeping those necessary for the matrices. 32 | } 33 | \usage{ 34 | \special{Math(x, \dots)} 35 | \special{Ops(e1, e2)} 36 | } 37 | 38 | \arguments{ 39 | \item{x, e1, e2}{\code{\link{auc}} objects, or mixed numerics and \code{auc} objects. 40 | } 41 | \item{\dots}{further arguments passed to other Math methods. 42 | } 43 | } 44 | 45 | 46 | \seealso{ 47 | \code{\link{groupGeneric}}, \code{\link{auc}} 48 | } 49 | \examples{ 50 | data(aSAH) 51 | 52 | # Create a roc object: 53 | aucobj1 <- auc(roc(aSAH$outcome, aSAH$s100b)) 54 | aucobj2 <- auc(roc(aSAH$outcome, aSAH$wfns)) 55 | 56 | # Math 57 | sqrt(aucobj1) 58 | round(aucobj2, digits=1) 59 | 60 | # Ops 61 | aucobj1 * 2 62 | 2 * aucobj2 63 | aucobj1 + aucobj2 64 | 65 | # With CI 66 | ciaucobj <- ci(aucobj1) 67 | ciaucobj * 2 68 | sqrt(ciaucobj) 69 | 70 | } 71 | 72 | \keyword{methods} 73 | -------------------------------------------------------------------------------- /man/has.partial.auc.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{has.partial.auc} 3 | \alias{has.partial.auc} 4 | \alias{has.partial.auc.smooth.roc} 5 | \alias{has.partial.auc.auc} 6 | \alias{has.partial.auc.roc} 7 | 8 | \title{ 9 | Does the ROC curve have a partial AUC? 10 | } 11 | \description{ 12 | This function determines if the ROC curve has a partial AUC. 13 | } 14 | \usage{ 15 | has.partial.auc(roc) 16 | \S3method{has.partial.auc}{auc}(roc) 17 | \S3method{has.partial.auc}{smooth.roc}(roc) 18 | \S3method{has.partial.auc}{roc}(roc) 19 | } 20 | 21 | \arguments{ 22 | \item{roc}{the ROC curve to check.} 23 | } 24 | 25 | \value{ 26 | \code{TRUE} if the AUC is a partial AUC, \code{FALSE} otherwise. 27 | 28 | If the AUC is not defined (i. e. if roc was called with \code{AUC=FALSE}), returns \code{NULL}. 29 | } 30 | 31 | \seealso{ 32 | \code{\link{auc}} 33 | } 34 | 35 | \examples{ 36 | data(aSAH) 37 | 38 | # Full AUC 39 | roc1 <- roc(aSAH$outcome, aSAH$s100b) 40 | has.partial.auc(roc1) 41 | has.partial.auc(auc(roc1)) 42 | has.partial.auc(smooth(roc1)) 43 | 44 | # Partial AUC 45 | roc2 <- roc(aSAH$outcome, aSAH$s100b, partial.auc = c(1, 0.9)) 46 | has.partial.auc(roc2) 47 | has.partial.auc(smooth(roc2)) 48 | 49 | # No AUC 50 | roc3 <- roc(aSAH$outcome, aSAH$s100b, auc = FALSE) 51 | has.partial.auc(roc3) 52 | } 53 | 54 | \keyword{programming} 55 | \keyword{logic} 56 | \keyword{roc} 57 | -------------------------------------------------------------------------------- /man/lines.roc.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{lines.roc} 3 | \alias{lines.roc} 4 | \alias{lines.roc.roc} 5 | \alias{lines.smooth.roc} 6 | \alias{lines.roc.smooth.roc} 7 | \alias{lines.roc.default} 8 | \alias{lines.roc.formula} 9 | 10 | \title{ 11 | Add a ROC line to a ROC plot 12 | } 13 | \description{ 14 | This convenience function adds a ROC line to a ROC curve. 15 | } 16 | \usage{ 17 | \S3method{lines}{roc}(x, ...) 18 | \S3method{lines}{smooth.roc}(x, ...) 19 | \S3method{lines.roc}{roc}(x, lwd=2, ...) 20 | \S3method{lines.roc}{formula}(x, data, subset, na.action, ...) 21 | \S3method{lines.roc}{default}(x, predictor, ...) 22 | \S3method{lines.roc}{smooth.roc}(x, ...) 23 | 24 | } 25 | 26 | \arguments{ 27 | \item{x}{a roc object from the \link{roc} function (for plot.roc.roc), 28 | a formula (for plot.roc.formula) or a response vector (for 29 | plot.roc.default). 30 | } 31 | \item{predictor, data}{arguments for the \link{roc} function.} 32 | \item{subset,na.action}{arguments for \code{\link{model.frame}}} 33 | \item{lwd}{line width (see \code{\link{par}}).} 34 | \item{\dots}{graphical parameters for \code{\link{lines}}, and 35 | especially \code{type} (see \code{\link{plot.default}}) and 36 | arguments for \code{\link{par}} such as \code{col} (color), 37 | \code{lty} (line type) or line characteristics \code{lend}, 38 | \code{ljoin} and \code{lmitre}. 39 | } 40 | } 41 | 42 | \value{ 43 | This function returns a list of class \dQuote{roc} invisibly. See \code{\link{roc}} for more details. 44 | } 45 | 46 | \seealso{ 47 | \code{\link{roc}}, \code{\link{plot.roc}} 48 | } 49 | \examples{ 50 | 51 | # Create a few ROC curves: 52 | data(aSAH) 53 | roc.s100b <- roc(aSAH$outcome, aSAH$s100b) 54 | roc.wfns <- roc(aSAH$outcome, aSAH$wfns) 55 | 56 | # We need a plot to be ready 57 | plot(roc.s100b, type = "n") # but don't actually plot the curve 58 | 59 | # Add the line 60 | lines(roc.s100b, type="b", pch=21, col="blue", bg="grey") 61 | 62 | # Add the line of an other ROC curve 63 | lines(roc.wfns, type="o", pch=19, col="red") 64 | 65 | 66 | # Without using 'lines': 67 | rocobj <- plot.roc(aSAH$outcome, aSAH$s100b, type="b", pch=21, col="blue", bg="grey") 68 | 69 | } 70 | 71 | \keyword{univar} 72 | \keyword{nonparametric} 73 | \keyword{utilities} 74 | \keyword{aplot} 75 | \keyword{hplot} 76 | \keyword{roc} 77 | 78 | -------------------------------------------------------------------------------- /man/plot.ci.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{plot.ci} 3 | \alias{plot.ci} 4 | \alias{plot.ci.thresholds} 5 | \alias{plot.ci.se} 6 | \alias{plot.ci.sp} 7 | \alias{plot.ci.coords} 8 | 9 | \title{ 10 | Plot confidence intervals 11 | } 12 | \description{ 13 | This function adds confidence intervals to a ROC curve plot, either as 14 | bars or as a confidence shape. 15 | } 16 | \usage{ 17 | \S3method{plot}{ci.thresholds}(x, length=.01*ifelse(attr(x, 18 | "roc")$percent, 100, 1), col=par("fg"), ...) 19 | \S3method{plot}{ci.sp}(x, type=c("bars", "shape"), length=.01*ifelse(attr(x, 20 | "roc")$percent, 100, 1), col=ifelse(type=="bars", par("fg"), 21 | "gainsboro"), no.roc=FALSE, ...) 22 | \S3method{plot}{ci.se}(x, type=c("bars", "shape"), length=.01*ifelse(attr(x, 23 | "roc")$percent, 100, 1), col=ifelse(type=="bars", par("fg"), 24 | "gainsboro"), no.roc=FALSE, ...) 25 | \S3method{plot}{ci.coords}(x, type=c("bars", "shape"), length=NULL, 26 | col=ifelse(type=="bars", par("fg"), "gainsboro"), ...) 27 | } 28 | 29 | \arguments{ 30 | \item{x}{a confidence interval object from the functions 31 | \code{\link{ci.thresholds}}, \code{\link{ci.se}}, \code{\link{ci.sp}} or 32 | \code{\link{ci.coords}}. 33 | } 34 | \item{type}{type of plot, \dQuote{bars} or \dQuote{shape}. Can be 35 | shortened to \dQuote{b} or \dQuote{s}. \dQuote{shape} is only available for 36 | \code{ci.se} and \code{ci.sp}, not for \code{ci.thresholds}. 37 | } 38 | \item{length}{the length (as plot coordinates) of the bar ticks. Only 39 | if \code{type="bars"}. 40 | } 41 | \item{no.roc}{ 42 | if \code{FALSE}, the ROC line is re-added over the 43 | shape. Otherwise if \code{TRUE}, only the shape is plotted. Ignored 44 | if \code{type="bars"} 45 | } 46 | \item{col}{color of the bars or shape.} 47 | \item{\dots}{further arguments for \code{\link{segments}} (if 48 | \code{type="bars"}) or \code{\link{polygon}} (if 49 | \code{type="shape"}). 50 | } 51 | } 52 | 53 | \details{ 54 | This function adds confidence intervals to a ROC curve plot, either as 55 | bars or as a confidence shape, depending on the state of the 56 | \code{type} argument. The shape is plotted over the ROC curve, so that 57 | the curve is re-plotted unless \code{no.roc=TRUE}. 58 | 59 | Graphical functions are called with \link{suppressWarnings}. 60 | } 61 | 62 | \section{Warnings}{ 63 | With \code{type="shape"}, the warning \dQuote{Low definition shape} is 64 | issued when the shape is defined by less than 15 confidence 65 | intervals. In such a case, the shape is not well defined and the ROC 66 | curve could pass outside the shape. To get a better shape, increase 67 | the number of intervals, for example with: 68 | \preformatted{plot(ci.sp(rocobj, sensitivities=seq(0, 1, .01)), type="shape")} 69 | } 70 | 71 | \value{ 72 | This function returns the confidence interval object invisibly. 73 | } 74 | 75 | \references{ 76 | Xavier Robin, Natacha Turck, Alexandre Hainard, \emph{et al.} 77 | (2011) ``pROC: an open-source package for R and S+ to analyze and 78 | compare ROC curves''. \emph{BMC Bioinformatics}, \bold{7}, 77. 79 | DOI: \doi{10.1186/1471-2105-12-77}. 80 | } 81 | 82 | \seealso{ 83 | \code{\link{plot.roc}}, \code{\link{ci.thresholds}}, \code{\link{ci.sp}}, \code{\link{ci.se}} 84 | } 85 | \examples{ 86 | data(aSAH) 87 | \dontrun{ 88 | # Start a ROC plot 89 | rocobj <- plot.roc(aSAH$outcome, aSAH$s100b) 90 | plot(rocobj) 91 | # Thresholds 92 | ci.thresolds.obj <- ci.thresholds(rocobj) 93 | plot(ci.thresolds.obj) 94 | # Specificities 95 | plot(rocobj) # restart a new plot 96 | ci.sp.obj <- ci.sp(rocobj, boot.n=500) 97 | plot(ci.sp.obj) 98 | # Sensitivities 99 | plot(rocobj) # restart a new plot 100 | ci.se.obj <- ci(rocobj, of="se", boot.n=500) 101 | plot(ci.se.obj) 102 | 103 | # Plotting a shape. We need more 104 | ci.sp.obj <- ci.sp(rocobj, sensitivities=seq(0, 1, .01), boot.n=100) 105 | plot(rocobj) # restart a new plot 106 | plot(ci.sp.obj, type="shape", col="blue") 107 | 108 | # Direct syntax (response, predictor): 109 | plot.roc(aSAH$outcome, aSAH$s100b, 110 | ci=TRUE, of="thresholds") 111 | 112 | # CI of a PR curve 113 | co <- coords(rocobj, x = "all", input="recall", ret=c("recall", "precision")) 114 | ci <- ci.coords(rocobj, x = seq(0, 1, .1), input="recall", ret="precision") 115 | plot(co, type="l", ylim = c(0, 1)) 116 | plot(ci, type="shape") 117 | plot(ci, type="bars") 118 | lines(co) 119 | } 120 | } 121 | 122 | \keyword{univar} 123 | \keyword{nonparametric} 124 | \keyword{utilities} 125 | \keyword{aplot} 126 | \keyword{hplot} 127 | \keyword{roc} 128 | 129 | -------------------------------------------------------------------------------- /man/print.Rd: -------------------------------------------------------------------------------- 1 | \encoding{UTF-8} 2 | \name{print} 3 | \alias{print.roc} 4 | \alias{print.smooth.roc} 5 | \alias{print.multiclass.roc} 6 | \alias{print.mv.multiclass.roc} 7 | \alias{print.ci.auc} 8 | \alias{print.ci.thresholds} 9 | \alias{print.ci.coords} 10 | \alias{print.ci.se} 11 | \alias{print.ci.sp} 12 | \alias{print.auc} 13 | \alias{print.multiclass.auc} 14 | 15 | \title{ 16 | Print a ROC curve object 17 | } 18 | \description{ 19 | This function prints a ROC curve, AUC or CI object and return it invisibly. 20 | } 21 | \usage{ 22 | \S3method{print}{roc}(x, digits=max(3, getOption("digits") - 3), call=TRUE, ...) 23 | \S3method{print}{multiclass.roc}(x, digits=max(3, getOption("digits") - 24 | 3), call=TRUE, ...) 25 | \S3method{print}{mv.multiclass.roc}(x, digits=max(3, getOption("digits") - 26 | 3), call=TRUE, ...) 27 | \S3method{print}{smooth.roc}(x, digits=max(3, getOption("digits") - 3), 28 | call=TRUE, ...) 29 | \S3method{print}{auc}(x, digits=max(3, getOption("digits") - 3), ...) 30 | \S3method{print}{multiclass.auc}(x, digits=max(3, getOption("digits") - 3), ...) 31 | \S3method{print}{ci.auc}(x, digits=max(3, getOption("digits") - 3), ...) 32 | \S3method{print}{ci.thresholds}(x, digits=max(3, getOption("digits") - 3), ...) 33 | \S3method{print}{ci.se}(x, digits=max(3, getOption("digits") - 3), ...) 34 | \S3method{print}{ci.sp}(x, digits=max(3, getOption("digits") - 3), ...) 35 | \S3method{print}{ci.coords}(x, digits=max(3, getOption("digits") - 3), ...) 36 | } 37 | 38 | 39 | \arguments{ 40 | \item{x}{a roc, auc or ci object, from the \link{roc}, \link{auc} or 41 | \link{ci} functions respectively. 42 | } 43 | \item{call}{if the call is printed.} 44 | \item{digits}{the number of significant figures to print. See 45 | \link{signif} for more details. 46 | } 47 | \item{\dots}{further arguments passed to or from other methods. In 48 | particular, \code{print.roc} calls \code{print.auc} and the 49 | \code{print.ci} variants internally, and a \code{digits} argument is 50 | propagated. Not used in print.auc and print.ci variants. 51 | } 52 | } 53 | 54 | \value{ 55 | These functions return the object they were passed invisibly. 56 | } 57 | 58 | \seealso{ 59 | \code{\link{roc}}, \code{\link{auc}}, \code{\link{ci}}, \code{\link{coords}} 60 | } 61 | \examples{ 62 | data(aSAH) 63 | 64 | # Print a roc object: 65 | rocobj <- roc(aSAH$outcome, aSAH$s100b) 66 | print(rocobj) 67 | 68 | # Print a smoothed roc object 69 | print(smooth(rocobj)) 70 | 71 | # implicit printing 72 | roc(aSAH$outcome, aSAH$s100b) 73 | 74 | # Print an auc and a ci object, from the ROC object or calling 75 | # the dedicated function: 76 | print(rocobj$auc) 77 | print(ci(rocobj)) 78 | } 79 | 80 | \keyword{univar} 81 | \keyword{nonparametric} 82 | \keyword{utilities} 83 | \keyword{print} 84 | \keyword{roc} 85 | -------------------------------------------------------------------------------- /pROC.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | ProjectId: 2c92863e-8f5b-4c4a-b1a7-d8e3ccd3388c 3 | 4 | RestoreWorkspace: Default 5 | SaveWorkspace: Default 6 | AlwaysSaveHistory: Default 7 | 8 | EnableCodeIndexing: Yes 9 | UseSpacesForTab: Yes 10 | NumSpacesForTab: 2 11 | Encoding: UTF-8 12 | 13 | RnwWeave: Sweave 14 | LaTeX: pdfLaTeX 15 | 16 | BuildType: Package 17 | PackageCleanBeforeInstall: No 18 | PackageInstallArgs: --no-multiarch --with-keep.source 19 | PackageCheckArgs: --as-cran 20 | -------------------------------------------------------------------------------- /run_revdep.R: -------------------------------------------------------------------------------- 1 | .libPaths("/home/xavier/R/library-pROC_revdeps") 2 | .libPaths("/home/xavier/R/library") 3 | 4 | pak::pkg_install("r-lib/revdepcheck") 5 | library(revdepcheck) 6 | 7 | # Don't make in parallel. Avoids running out of memory on some build tasks 8 | Sys.setenv("MAKEFLAGS"="") 9 | revdep_reset() 10 | revdepcheck::revdep_check(num_workers=2, timeout = as.difftime(60, units = "mins")) 11 | 12 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | 6 | using namespace Rcpp; 7 | 8 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 9 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 10 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 11 | #endif 12 | 13 | // RcppVersion 14 | String RcppVersion(); 15 | RcppExport SEXP _pROC_RcppVersion() { 16 | BEGIN_RCPP 17 | Rcpp::RObject rcpp_result_gen; 18 | Rcpp::RNGScope rcpp_rngScope_gen; 19 | rcpp_result_gen = Rcpp::wrap(RcppVersion()); 20 | return rcpp_result_gen; 21 | END_RCPP 22 | } 23 | // delongPlacementsCpp 24 | List delongPlacementsCpp(List roc); 25 | RcppExport SEXP _pROC_delongPlacementsCpp(SEXP rocSEXP) { 26 | BEGIN_RCPP 27 | Rcpp::RObject rcpp_result_gen; 28 | Rcpp::RNGScope rcpp_rngScope_gen; 29 | Rcpp::traits::input_parameter< List >::type roc(rocSEXP); 30 | rcpp_result_gen = Rcpp::wrap(delongPlacementsCpp(roc)); 31 | return rcpp_result_gen; 32 | END_RCPP 33 | } 34 | 35 | static const R_CallMethodDef CallEntries[] = { 36 | {"_pROC_RcppVersion", (DL_FUNC) &_pROC_RcppVersion, 0}, 37 | {"_pROC_delongPlacementsCpp", (DL_FUNC) &_pROC_delongPlacementsCpp, 1}, 38 | {NULL, NULL, 0} 39 | }; 40 | 41 | RcppExport void R_init_pROC(DllInfo *dll) { 42 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 43 | R_useDynamicSymbols(dll, FALSE); 44 | } 45 | -------------------------------------------------------------------------------- /src/RcppVersion.cpp: -------------------------------------------------------------------------------- 1 | /* pROC: Tools Receiver operating characteristic (ROC curves) with 2 | (partial) area under the curve, confidence intervals and comparison. 3 | Copyright (C) 2016 Xavier Robin, Stefan Siegert 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . 17 | */ 18 | 19 | #include 20 | using namespace Rcpp; 21 | 22 | // [[Rcpp::export]] 23 | String RcppVersion() { 24 | return RCPP_VERSION; 25 | } -------------------------------------------------------------------------------- /src/delong.cpp: -------------------------------------------------------------------------------- 1 | /* pROC: Tools Receiver operating characteristic (ROC curves) with 2 | (partial) area under the curve, confidence intervals and comparison. 3 | Copyright (C) 2016 Xavier Robin, Stefan Siegert 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . 17 | */ 18 | 19 | #include 20 | using namespace Rcpp; 21 | 22 | bool _cmp(std::pair l, std::pair r) { 23 | return l.second < r.second; 24 | } 25 | 26 | // [[Rcpp::export]] 27 | List delongPlacementsCpp(List roc) { 28 | 29 | int i, j, k, m, n, mdupl, ndupl, L; 30 | 31 | std::vector cases = roc["cases"]; 32 | std::vector controls = roc["controls"]; 33 | std::string direction = roc["direction"]; 34 | m = cases.size(); 35 | n = controls.size(); 36 | L = m + n; 37 | 38 | // For direction ">" we must reverse the data 39 | if (direction == ">") { 40 | for (i = 0; i < m; i++) { 41 | cases[i] = -cases[i]; 42 | } 43 | for (i = 0; i < n; i++) { 44 | controls[i] = -controls[i]; 45 | } 46 | } 47 | 48 | // concatenate cases and controls into a vector of L pairs of the form 49 | // (index, value), also save class labels (1 for cases, 0 for controls) 50 | std::vector< std::pair > Z; 51 | std::vector< bool > labels; 52 | for (i = 0; i < m; i++) { 53 | Z.push_back(std::pair(i, cases.at(i))); 54 | labels.push_back(true); 55 | } 56 | Rcpp::checkUserInterrupt(); 57 | for (j = 0; j < n; j++) { 58 | Z.push_back(std::pair(m+j, controls.at(j))); 59 | labels.push_back(false); 60 | } 61 | Rcpp::checkUserInterrupt(); 62 | 63 | // sort Z from smallest to largest value, so Z holds the order indices and 64 | // order statistics of all classifiers 65 | std::sort(Z.begin(), Z.end(), _cmp); 66 | Rcpp::checkUserInterrupt(); 67 | 68 | // the following calculates the "Delong-placements" X and Y in a single pass 69 | // over the vector Z, instead of having to double loop over all pairs of 70 | // (X_i, Y_j) 71 | std::vector< double > XY(L, 0.0); // vector to hold the unnormalised X and Y values 72 | std::vector< int > X_inds, Y_inds; // temporary vectors to save indices of duplicates 73 | m = n = i = 0; // initialisation 74 | while (i < L) { 75 | X_inds.clear(); 76 | Y_inds.clear(); 77 | mdupl = ndupl = 0; 78 | if (i % 10000 == 0) Rcpp::checkUserInterrupt(); 79 | while(1) { 80 | j = Z.at(i).first; 81 | if (labels.at(j)) { 82 | mdupl++; 83 | X_inds.push_back(j); 84 | } else { 85 | ndupl++; 86 | Y_inds.push_back(j); 87 | } 88 | if (i == L-1) { 89 | break; 90 | } 91 | if (Z.at(i).second != Z.at(i+1).second) { 92 | break; 93 | } 94 | i++; 95 | } 96 | for (k = 0; k < mdupl; k++) { 97 | XY.at(X_inds.at(k)) = n + ndupl/2.0; 98 | } 99 | for (k = 0; k < ndupl; k++) { 100 | XY.at(Y_inds.at(k)) = m + mdupl/2.0; 101 | } 102 | n += ndupl; 103 | m += mdupl; 104 | i++; 105 | } 106 | 107 | double sum = 0.0; 108 | std::vector X, Y; 109 | Rcpp::checkUserInterrupt(); 110 | 111 | for (i = 0; i < L; i++) { 112 | if (labels.at(i)) { 113 | sum += XY.at(i); 114 | X.push_back(XY.at(i) / n); 115 | } else { 116 | Y.push_back(1.0 - XY.at(i) / m); 117 | } 118 | } 119 | 120 | List ret; 121 | ret["theta"] = sum / m / n; 122 | ret["X"] = X; 123 | ret["Y"] = Y; 124 | return(ret); 125 | } 126 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(pROC) 3 | data(aSAH) 4 | 5 | test_check("pROC") 6 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/plot/basic-s100b.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | Specificity 22 | Sensitivity 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 1.0 32 | 0.8 33 | 0.6 34 | 0.4 35 | 0.2 36 | 0.0 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 0.0 45 | 0.2 46 | 0.4 47 | 0.6 48 | 0.8 49 | 1.0 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/plot/basic-wfns.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | Specificity 22 | Sensitivity 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 1.0 32 | 0.8 33 | 0.6 34 | 0.4 35 | 0.2 36 | 0.0 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 0.0 45 | 0.2 46 | 0.4 47 | 0.6 48 | 0.8 49 | 1.0 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/plot/legacy-axes.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 1 - Specificity 22 | Sensitivity 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 0.0 32 | 0.2 33 | 0.4 34 | 0.6 35 | 0.8 36 | 1.0 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 0.0 45 | 0.2 46 | 0.4 47 | 0.6 48 | 0.8 49 | 1.0 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /tests/testthat/helper-expect_equal_roc.R: -------------------------------------------------------------------------------- 1 | remove.calls.recursive <- function(x) { 2 | if (is.null(x)) { 3 | return(NULL) 4 | } 5 | attr(x, "roc") <- remove.calls.recursive(attr(x, "roc")) 6 | attr(x, "auc") <- remove.calls.recursive(attr(x, "auc")) 7 | attr(x, "ci") <- remove.calls.recursive(attr(x, "ci")) 8 | if (!is.list(x)) { 9 | return(x) 10 | } 11 | x$roc <- remove.calls.recursive(x$roc) 12 | x$auc <- remove.calls.recursive(x$auc) 13 | x$ci <- remove.calls.recursive(x$ci) 14 | x$call <- NULL 15 | return(x) 16 | } 17 | 18 | remove.fun.sesp.recursive <- function(x) { 19 | if (is.null(x)) { 20 | return(NULL) 21 | } 22 | attr(x, "roc") <- remove.fun.sesp.recursive(attr(x, "roc")) 23 | attr(x, "auc") <- remove.fun.sesp.recursive(attr(x, "auc")) 24 | attr(x, "ci") <- remove.fun.sesp.recursive(attr(x, "ci")) 25 | if (!is.list(x)) { 26 | return(x) 27 | } 28 | x$roc <- remove.fun.sesp.recursive(x$roc) 29 | x$auc <- remove.fun.sesp.recursive(x$auc) 30 | x$ci <- remove.fun.sesp.recursive(x$ci) 31 | x$fun.sesp <- NULL 32 | return(x) 33 | } 34 | 35 | remove.response.names.recursive <- function(x) { 36 | if (is.null(x)) { 37 | return(NULL) 38 | } 39 | attr(x, "roc") <- remove.response.names.recursive(attr(x, "roc")) 40 | attr(x, "auc") <- remove.response.names.recursive(attr(x, "auc")) 41 | attr(x, "ci") <- remove.response.names.recursive(attr(x, "ci")) 42 | if (!is.list(x)) { 43 | return(x) 44 | } 45 | x$roc <- remove.response.names.recursive(x$roc) 46 | x$auc <- remove.response.names.recursive(x$auc) 47 | x$ci <- remove.response.names.recursive(x$ci) 48 | x$fun.sesp <- remove.response.names.recursive(x$fun.sesp) 49 | names(x$response) <- NULL 50 | names(x$original.response) <- NULL 51 | x$response.name <- NULL 52 | x$predictor.name <- NULL 53 | return(x) 54 | } 55 | 56 | 57 | expect_equal_ignore_call <- function(x, y, ...) { 58 | x <- remove.calls.recursive(x) 59 | y <- remove.calls.recursive(y) 60 | x <- remove.fun.sesp.recursive(x) 61 | y <- remove.fun.sesp.recursive(y) 62 | expect_equal(x, y, ...) 63 | } 64 | 65 | expect_equal_roc_formula <- function(x, y, ...) { 66 | # roc.formula adds names to response and original.response 67 | # this expectation ignores them, as well as the call 68 | x <- remove.calls.recursive(x) 69 | x <- remove.response.names.recursive(x) 70 | y <- remove.calls.recursive(y) 71 | y <- remove.response.names.recursive(y) 72 | expect_equal(x, y, ...) 73 | } 74 | -------------------------------------------------------------------------------- /tests/testthat/helper-expectations.R: -------------------------------------------------------------------------------- 1 | # Make sure the value looks like a p value. 2 | expect_p_value <- function(p.value) { 3 | expect_is(p.value, "numeric") 4 | expect_lte(p.value, 1) 5 | expect_gte(p.value, 0) 6 | } 7 | 8 | # Make sure we got a htest 9 | expect_htest <- function(ht) { 10 | expect_is(ht, "htest") 11 | expect_p_value(ht$p.value) 12 | } 13 | 14 | # Make sure we got a venkatraman test 15 | expect_venkatraman_htest <- function(ht) { 16 | expect_htest(ht) 17 | expect_equal(unname(ht$null.value), 0) 18 | expect_named(ht$null.value, "difference in at least one ROC operating point") 19 | expect_is(ht$statistic, c("numeric", "integer")) # Can be either? 20 | expect_named(ht$statistic, "E") 21 | expect_is(ht$parameter, "numeric") 22 | expect_named(ht$parameter, "boot.n") 23 | } 24 | 25 | # Make sure we got a boostrap test 26 | expect_bootstrap_htest <- function(ht) { 27 | expect_htest(ht) 28 | expect_equal(unname(ht$null.value), 0) 29 | expect_named(ht$null.value) # multiple values are possible 30 | expect_is(ht$statistic, c("numeric", "integer")) # Can be either? 31 | expect_named(ht$statistic, "D") 32 | expect_is(ht$parameter, "numeric") 33 | expect_named(ht$parameter, c("boot.n", "boot.stratified")) 34 | } 35 | -------------------------------------------------------------------------------- /tests/testthat/helper-roc.utils-expected.R: -------------------------------------------------------------------------------- 1 | expected_roc_utils_calc_coords <- 2 | structure(c( 3 | -1, -2, -3, -4, 1, 0.5, 0.10000000000000001, 0, 0, 4 | 0.5, 0.90000000000000002, 1, 0.36283185840707965, 0.5, 0.60973451327433625, 5 | 0.63716814159292035, 0, 36, 64.799999999999997, 72, 41, 20.5, 6 | 4.1000000000000005, 0, 0, 20.5, 36.899999999999999, 41, 72, 36, 7 | 7.2000000000000028, 0, NaN, 0.63716814159292035, 0.63716814159292035, 8 | 0.63716814159292035, 0.36283185840707965, 0.36283185840707965, 9 | 0.36283185840707954, NaN, 1, 0.5, 0.10000000000000001, 0, 0, 10 | 0.5, 0.90000000000000002, 1, 1, 0.5, 0.099999999999999978, 0, 11 | 0, 0.5, 0.89999999999999991, 1, 0.63716814159292035, 0.63716814159292035, 12 | 0.63716814159292035, NaN, 1, 0.5, 0.099999999999999978, 0, 0, 13 | 0.5, 0.90000000000000002, 1, 0.63716814159292035, 0.5, 0.39026548672566375, 14 | 0.36283185840707965, NaN, 0.36283185840707965, 0.36283185840707965, 15 | 0.36283185840707965, 0.63716814159292035, 0.63716814159292035, 16 | 0.63716814159292046, NaN, 0.36283185840707965, 0.36283185840707965, 17 | 0.36283185840707954, NaN, 1, 0.5, 0.10000000000000001, 0, 1, 18 | 1, 1.0000000000000002, NaN, NaN, 1, 1, 1, 1, 0.50462962962962965, 19 | 0.10833333333333334, 0.009259259259259257, 0.009259259259259257, 20 | 0.25231481481481483, 0.8100925925925927, 1 21 | ), .Dim = c(4L, 26L), .Dimnames = list(NULL, c( 22 | "threshold", "sensitivity", "specificity", 23 | "accuracy", "tn", "tp", "fn", "fp", "npv", "ppv", "tpr", "tnr", 24 | "fpr", "fnr", "fdr", "1-specificity", "1-sensitivity", "1-accuracy", 25 | "1-npv", "1-ppv", "precision", "recall", "lr_pos", "lr_neg", 26 | "youden", "closest.topleft" 27 | ))) 28 | 29 | expected_roc_utils_calc_coords.percent <- 30 | structure(c( 31 | -1, -2, -3, -4, 100, 50, 10, 0, 0, 50, 90, 100, 36.283185840707965, 32 | 50, 60.973451327433622, 63.716814159292035, 0, 36, 64.799999999999997, 33 | 72, 41, 20.5, 4.0999999999999996, 0, 0, 20.5, 36.899999999999999, 34 | 41, 72, 36, 7.2000000000000028, 0, NaN, 63.716814159292035, 63.716814159292042, 35 | 63.716814159292035, 36.283185840707965, 36.283185840707965, 36.283185840707951, 36 | NaN, 100, 50, 10, 0, 0, 50, 90, 100, 100, 50, 10, 0, 0, 50, 90, 37 | 100, 63.716814159292035, 63.716814159292035, 63.716814159292042, 38 | NaN, 100, 50, 10, 0, 0, 50, 90, 100, 63.716814159292035, 50, 39 | 39.026548672566378, 36.283185840707965, NaN, 36.283185840707965, 40 | 36.283185840707958, 36.283185840707965, 63.716814159292035, 63.716814159292035, 41 | 63.716814159292049, NaN, 36.283185840707965, 36.283185840707965, 42 | 36.283185840707951, NaN, 100, 50, 10, 0, 1, 1, 1.0000000000000002, 43 | NaN, NaN, 1, 1, 1, 100, 50.462962962962962, 10.833333333333334, 44 | 0.92592592592592571, 0.92592592592592571, 25.231481481481481, 45 | 81.009259259259267, 100 46 | ), .Dim = c(4L, 26L), .Dimnames = list( 47 | NULL, c( 48 | "threshold", "sensitivity", "specificity", "accuracy", 49 | "tn", "tp", "fn", "fp", "npv", "ppv", "tpr", "tnr", "fpr", 50 | "fnr", "fdr", "1-specificity", "1-sensitivity", "1-accuracy", 51 | "1-npv", "1-ppv", "precision", "recall", "lr_pos", "lr_neg", 52 | "youden", "closest.topleft" 53 | ) 54 | )) 55 | -------------------------------------------------------------------------------- /tests/testthat/helper-rocs.R: -------------------------------------------------------------------------------- 1 | data(aSAH) 2 | 3 | r.wfns <- roc(aSAH$outcome, aSAH$wfns, quiet = TRUE) 4 | r.ndka <- roc(aSAH$outcome, aSAH$ndka, quiet = TRUE) 5 | r.s100b <- roc(aSAH$outcome, aSAH$s100b, quiet = TRUE) 6 | 7 | r.wfns.percent <- roc(aSAH$outcome, aSAH$wfns, percent = TRUE, quiet = TRUE) 8 | r.ndka.percent <- roc(aSAH$outcome, aSAH$ndka, percent = TRUE, quiet = TRUE) 9 | r.s100b.percent <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE, quiet = TRUE) 10 | 11 | r.wfns.partial <- roc(aSAH$outcome, aSAH$wfns, quiet = TRUE, partial.auc = c(1, 0.9)) 12 | r.ndka.partial <- roc(aSAH$outcome, aSAH$ndka, quiet = TRUE, partial.auc = c(1, 0.9)) 13 | r.s100b.partial <- roc(aSAH$outcome, aSAH$s100b, quiet = TRUE, partial.auc = c(1, 0.9)) 14 | 15 | r.wfns.partial1 <- roc(aSAH$outcome, aSAH$wfns, quiet = TRUE, partial.auc = c(0.9, 0.99)) 16 | r.ndka.partial1 <- roc(aSAH$outcome, aSAH$ndka, quiet = TRUE, partial.auc = c(0.9, 0.99)) 17 | r.s100b.partial1 <- roc(aSAH$outcome, aSAH$s100b, quiet = TRUE, partial.auc = c(0.9, 0.99)) 18 | 19 | r.wfns.percent.partial1 <- roc(aSAH$outcome, aSAH$wfns, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 20 | r.ndka.percent.partial1 <- roc(aSAH$outcome, aSAH$ndka, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 21 | r.s100b.percent.partial1 <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 22 | 23 | r.s100b.partial2 <- roc(aSAH$outcome, aSAH$s100b, quiet = TRUE, partial.auc = c(.9, .99), partial.auc.focus = "se") 24 | r.s100b.percent.partial2 <- roc(aSAH$outcome, aSAH$s100b, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99), partial.auc.focus = "se") 25 | -------------------------------------------------------------------------------- /tests/testthat/helper-skip.R: -------------------------------------------------------------------------------- 1 | # Skip slow tests 2 | skip_slow <- function(message = "Slow test skipped") { 3 | if (exists("run_slow_tests", envir = .GlobalEnv)) { 4 | if (!get("run_slow_tests", envir = .GlobalEnv)) { 5 | skip(message) 6 | } 7 | } else if (!identical(Sys.getenv("RUN_SLOW_TESTS"), "true")) { 8 | skip(message) 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /tests/testthat/helper-vdiffr.R: -------------------------------------------------------------------------------- 1 | # Skip expect_doppelganger if vdiffr is not installed 2 | expect_doppelganger <- function(title, fig, ...) { 3 | testthat::skip_if_not_installed("vdiffr") 4 | vdiffr::expect_doppelganger(title, fig, ...) 5 | } 6 | 7 | # expect_doppelganger for ggroc 8 | expect_ggroc_doppelganger <- function(title, fig, ...) { 9 | testthat::skip_if_not_installed("ggplot2") 10 | expect_doppelganger(title, fig, ...) 11 | } 12 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$ndka) 4 | 5 | Data: aSAH$ndka with 4 levels of aSAH$gos6: 1, 3, 4, 5. 6 | Multi-class area under the curve: 0.6087 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass_levels: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$ndka, levels = c(3, 4, 5)) 4 | 5 | Data: aSAH$ndka with 3 levels of aSAH$gos6: 3, 4, 5. 6 | Multi-class area under the curve: 0.6182 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass_partial: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$ndka, partial.auc = c(1, 0.9)) 4 | 5 | Data: aSAH$ndka with 4 levels of aSAH$gos6: 1, 3, 4, 5. 6 | Multi-class partial area under the curve (specificity 1-0.9): 0.009568 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass_partial_correct: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$wfns, partial.auc = c(1, 0.9), partial.auc.correct = TRUE) 4 | 5 | Data: aSAH$wfns with 4 levels of aSAH$gos6: 1, 3, 4, 5. 6 | Multi-class corrected partial area under the curve (specificity 1-0.9): 0.6013 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass_partial_se: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$ndka, partial.auc = c(1, 0.9), partial.auc.focus = "se") 4 | 5 | Data: aSAH$ndka with 4 levels of aSAH$gos6: 1, 3, 4, 5. 6 | Multi-class partial area under the curve (sensitivity 1-0.9): 0.02205 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/multiclass_percent: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = aSAH$gos6, predictor = aSAH$ndka, percent = TRUE) 4 | 5 | Data: aSAH$ndka with 4 levels of aSAH$gos6: 1, 3, 4, 5. 6 | Multi-class area under the curve: 60.87% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor) 4 | 5 | Data: multivariate predictor predictor with 3 levels of responses: X1, X2, X3. 6 | Multi-class area under the curve: 0.6668 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass.ndka.formula: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.formula(formula = gos6 ~ ndka, data = aSAH) 4 | 5 | Data: ndka with 4 levels of gos6: 1, 3, 4, 5. 6 | Multi-class area under the curve: 0.6087 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass_levels: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor, levels = c("X2", "X3")) 4 | 5 | Data: multivariate predictor predictor with 2 levels of responses: X2, X3. 6 | Multi-class area under the curve: 0.5003 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass_partial: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor, partial.auc = c(1, 0.9)) 4 | 5 | Data: multivariate predictor predictor with 3 levels of responses: X1, X2, X3. 6 | Multi-class partial area under the curve (specificity 1-0.9): 0.05313 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass_partial_correct: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor, partial.auc = c(1, 0.9), partial.auc.correct = TRUE) 4 | 5 | Data: multivariate predictor predictor with 3 levels of responses: X1, X2, X3. 6 | Multi-class corrected partial area under the curve (specificity 1-0.9): 0.7533 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass_partial_se: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor, partial.auc = c(1, 0.9), partial.auc.focus = "se") 4 | 5 | Data: multivariate predictor predictor with 3 levels of responses: X1, X2, X3. 6 | Multi-class partial area under the curve (sensitivity 1-0.9): 0.01667 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/mv_multiclass_percent: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | multiclass.roc.default(response = responses, predictor = predictor, percent = TRUE) 4 | 5 | Data: multivariate predictor predictor with 3 levels of responses: X1, X2, X3. 6 | Multi-class area under the curve: 66.68% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/ndka_formula: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = outcome ~ ndka, data = aSAH) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/ndka_formula_attached: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = outcome ~ ndka) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/ndka_formula_var: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = x, data = aSAH) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/ndka_formula_var_attached: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = x) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$ndka, quiet = TRUE) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.ci.auc: -------------------------------------------------------------------------------- 1 | 95% CI: 0.5039-0.6362 (3 stratified bootstrap replicates) 2 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.ci.coords: -------------------------------------------------------------------------------- 1 | 95% CI (3 stratified bootstrap replicates): 2 | threshold threshold.low threshold.median threshold.high specificity.low 3 | 0.5 0.5 0.5 0.5 0.5 0 4 | 0.2 0.2 0.2 0.2 0.2 0 5 | specificity.median specificity.high sensitivity.low sensitivity.median 6 | 0.5 0 0 1 1 7 | 0.2 0 0 1 1 8 | sensitivity.high 9 | 0.5 1 10 | 0.2 1 11 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.ci.se: -------------------------------------------------------------------------------- 1 | 95% CI (3 stratified bootstrap replicates): 2 | sp se.low se.median se.high 3 | 0.0 1.00000 1.00000 1.00000 4 | 0.1 0.83170 0.87800 0.92440 5 | 0.2 0.80730 0.85370 0.90000 6 | 0.3 0.65070 0.78050 0.89630 7 | 0.4 0.59390 0.75610 0.82560 8 | 0.5 0.54510 0.70730 0.75370 9 | 0.6 0.44510 0.56100 0.58410 10 | 0.7 0.31830 0.34150 0.55000 11 | 0.8 0.27200 0.34150 0.38780 12 | 0.9 0.19630 0.21950 0.21950 13 | 1.0 0.00122 0.02439 0.04756 14 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.ci.sp: -------------------------------------------------------------------------------- 1 | 95% CI (3 stratified bootstrap replicates): 2 | se sp.low sp.median sp.high 3 | 0.0 1.0000000 1.00000 1.00000 4 | 0.1 0.9042000 0.93060 0.95690 5 | 0.2 0.8764000 0.90280 0.91600 6 | 0.3 0.7608000 0.86110 0.87430 7 | 0.4 0.6417000 0.69440 0.78680 8 | 0.5 0.5750000 0.68060 0.74650 9 | 0.6 0.3840000 0.55560 0.55560 10 | 0.7 0.2785000 0.55560 0.55560 11 | 0.8 0.2125000 0.29170 0.43680 12 | 0.9 0.0013890 0.02778 0.29170 13 | 1.0 0.0006944 0.01389 0.01389 14 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.ci.thresholds: -------------------------------------------------------------------------------- 1 | 95% CI (3 stratified bootstrap replicates): 2 | thresholds sp.low sp.median sp.high se.low se.median se.high 3 | 0.5 0 0 0 1 1 1 4 | 0.2 0 0 0 1 1 1 5 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.formula: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = outcome ~ ndka, data = aSAH) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.formula.ci: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = outcome ~ ndka, data = aSAH, ci = TRUE) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve: 0.612 7 | 95% CI: 0.5012-0.7227 (DeLong) 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.formula.no_auc: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.formula(formula = outcome ~ ndka, data = aSAH, auc = FALSE) 4 | 5 | Data: ndka in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Area under the curve not computed. 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$ndka, quiet = TRUE, partial.auc = c(0.9, 0.99)) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 0.99-0.9): 0.01046 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.percent: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$ndka, percent = TRUE, quiet = TRUE) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 61.2% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.ndka.percent.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$ndka, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 99%-90%): 1.046% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.s100b: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$s100b, quiet = TRUE) 4 | 5 | Data: aSAH$s100b in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 0.7314 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.s100b.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$s100b, quiet = TRUE, partial.auc = c(0.9, 0.99)) 4 | 5 | Data: aSAH$s100b in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 0.99-0.9): 0.02983 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.s100b.partial2: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$s100b, quiet = TRUE, partial.auc = c(0.9, 0.99), partial.auc.focus = "se") 4 | 5 | Data: aSAH$s100b in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (sensitivity 0.99-0.9): 0.01376 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.s100b.percent: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$s100b, percent = TRUE, quiet = TRUE) 4 | 5 | Data: aSAH$s100b in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 73.14% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.s100b.percent.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$s100b, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 4 | 5 | Data: aSAH$s100b in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 99%-90%): 2.983% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.wfns: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$wfns, quiet = TRUE) 4 | 5 | Data: aSAH$wfns in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 0.8237 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.wfns.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$wfns, quiet = TRUE, partial.auc = c(0.9, 0.99)) 4 | 5 | Data: aSAH$wfns in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 0.99-0.9): 0.03305 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.wfns.percent: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$wfns, percent = TRUE, quiet = TRUE) 4 | 5 | Data: aSAH$wfns in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Area under the curve: 82.37% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/r.wfns.percent.partial1: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | roc.default(response = aSAH$outcome, predictor = aSAH$wfns, percent = TRUE, quiet = TRUE, partial.auc = c(90, 99)) 4 | 5 | Data: aSAH$wfns in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Partial area under the curve (specificity 99%-90%): 3.305% 7 | -------------------------------------------------------------------------------- /tests/testthat/print_output/roc.test-venkatraman.paired: -------------------------------------------------------------------------------- 1 | 2 | Venkatraman's test for two paired ROC curves 3 | 4 | data: r.s100b and r.wfns 5 | E = 42, boot.n = 12, p-value < 2.2e-16 6 | alternative hypothesis: true difference in at least one ROC operating point is not equal to 0 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/roc.test-venkatraman.unpaired: -------------------------------------------------------------------------------- 1 | 2 | Venkatraman's test for two unpaired ROC curves 3 | 4 | data: r.s100b and r.wfns 5 | E = 41, boot.n = 12, p-value = 0.5483 6 | alternative hypothesis: true difference in at least one ROC operating point is not equal to 0 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/roc.test-venkatraman.unpaired.unstratified: -------------------------------------------------------------------------------- 1 | 2 | Venkatraman's test for two unpaired ROC curves 3 | 4 | data: r.s100b and r.wfns 5 | E = 43, boot.n = 12, p-value = 0.05 6 | alternative hypothesis: true difference in at least one ROC operating point is not equal to 0 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/roc.test-venkatraman.unstratified: -------------------------------------------------------------------------------- 1 | 2 | Venkatraman's test for two paired ROC curves 3 | 4 | data: r.s100b and r.wfns 5 | E = 43, boot.n = 12, p-value = 0.05 6 | alternative hypothesis: true difference in at least one ROC operating point is not equal to 0 7 | 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.ndka: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(aSAH$outcome, aSAH$ndka)) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Smoothing: binormal 7 | Area under the curve: 0.6006 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.binormal: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(aSAH$outcome, aSAH$ndka), method = "binormal") 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Smoothing: binormal 7 | Area under the curve: 0.6006 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.density: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(outcome ~ s100b, aSAH), method = "density") 4 | 5 | Data: s100b in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Smoothing: density (bandwidth: nrd0; adjust: 1) 7 | Area under the curve: 0.7244 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.fitdistr: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(outcome ~ s100b, aSAH), method = "fitdistr") 4 | 5 | Data: s100b in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Smoothing: fitdistr 7 | Area under the curve: 0.8311 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.formula: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(outcome ~ s100b, aSAH)) 4 | 5 | Data: s100b in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Smoothing: binormal 7 | Area under the curve: 0.74 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.logcondens: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(outcome ~ s100b, aSAH), method = "logcondens") 4 | 5 | Data: s100b in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Smoothing: logcondens 7 | Area under the curve: 0.7542 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.s100b.logcondens.smooth: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(outcome ~ s100b, aSAH), method = "logcondens.smooth") 4 | 5 | Data: s100b in 72 controls (outcome Good) < 41 cases (outcome Poor). 6 | Smoothing: logcondens.smooth 7 | Area under the curve: 0.7149 8 | -------------------------------------------------------------------------------- /tests/testthat/print_output/smooth.wfns: -------------------------------------------------------------------------------- 1 | 2 | Call: 3 | smooth.roc(roc = roc(aSAH$outcome, aSAH$ndka)) 4 | 5 | Data: aSAH$ndka in 72 controls (aSAH$outcome Good) < 41 cases (aSAH$outcome Poor). 6 | Smoothing: binormal 7 | Area under the curve: 0.6006 8 | -------------------------------------------------------------------------------- /tests/testthat/test-Ops.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | a.ndka <- auc(aSAH$outcome, aSAH$ndka) 5 | 6 | test_that("can convert auc to numeric", { 7 | expect_is(a.ndka, "auc") # a.ndka is not a numeric to start with 8 | expect_equal(as.numeric(a.ndka), 0.611957994579946) 9 | }) 10 | 11 | test_that("can do math on an AUC", { 12 | expect_equal(sqrt(a.ndka), 0.782277440924859) 13 | expect_equal(a.ndka * 2, 1.22391598915989) 14 | expect_equal(a.ndka / 0.5, 1.22391598915989) 15 | expect_equal(a.ndka + 5, 5.611957994579946) 16 | expect_equal(a.ndka - 1, -0.388042005420054) 17 | expect_equal(round(a.ndka, digits = 1), 0.6) 18 | }) 19 | -------------------------------------------------------------------------------- /tests/testthat/test-are-paired.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("are.paired") 5 | 6 | test_that("are.paired works", { 7 | # most basic example 8 | expect_true(are.paired(r.wfns, r.ndka)) 9 | 10 | # Missing values shouldn't screw up 11 | aSAH.missing <- aSAH 12 | aSAH.missing$wfns[1:20] <- NA 13 | expect_true(are.paired(roc(aSAH.missing$outcome, aSAH.missing$wfns), roc(aSAH.missing$outcome, aSAH.missing$ndka))) 14 | # Also with different data.frames 15 | expect_true(are.paired(roc(aSAH.missing$outcome, aSAH.missing$wfns), r.ndka)) 16 | 17 | # The following should fail though 18 | expect_false(are.paired(roc(aSAH$outcome[21:113], aSAH$wfns[21:113]), roc(aSAH$outcome, aSAH$ndka))) 19 | 20 | # Opposite levels should probably fail 21 | expect_false(are.paired(roc(aSAH$outcome, aSAH$wfns, levels = c("Good", "Poor")), roc(aSAH$outcome, aSAH$ndka, levels = c("Poor", "Good")))) 22 | }) 23 | 24 | test_that("are.paired works with formula", { 25 | r.wfns.f <- roc(outcome ~ wfns, aSAH) 26 | r.ndka.f <- roc(outcome ~ ndka, aSAH) 27 | # most basic example 28 | expect_true(are.paired(r.wfns.f, r.ndka.f)) 29 | 30 | # Missing values shouldn't screw up 31 | aSAH.missing <- aSAH 32 | aSAH.missing$wfns[1:20] <- NA 33 | expect_true(are.paired(roc(outcome ~ wfns, aSAH.missing), roc(outcome ~ ndka, aSAH.missing))) 34 | # Also with different data.frames 35 | expect_true(are.paired(roc(outcome ~ wfns, aSAH.missing), r.ndka.f)) 36 | 37 | # The following should fail though 38 | expect_false(are.paired(roc(outcome ~ wfns, aSAH.missing[21:113, ]), r.ndka)) 39 | 40 | # Opposite levels should probably fail 41 | expect_false(are.paired(roc(outcome ~ wfns, aSAH, levels = c("Good", "Poor")), roc(outcome ~ ndka, aSAH, levels = c("Poor", "Good")))) 42 | }) 43 | 44 | 45 | test_that("are.paired works with auc and mixed roc", { 46 | expect_true(are.paired(auc(aSAH$outcome, aSAH$wfns), auc(aSAH$outcome, aSAH$ndka))) 47 | expect_true(are.paired(roc(aSAH$outcome, aSAH$wfns), auc(aSAH$outcome, aSAH$ndka))) 48 | expect_true(are.paired(auc(aSAH$outcome, aSAH$wfns), roc(aSAH$outcome, aSAH$ndka))) 49 | }) 50 | 51 | test_that("are.paired return.paired.rocs works", { 52 | pair <- are.paired(r.wfns, r.ndka, return.paired.rocs = TRUE) 53 | expect_true(pair) 54 | expect_identical(attr(pair, "roc1"), r.wfns) 55 | expect_identical(attr(pair, "roc2"), r.ndka) 56 | }) 57 | 58 | test_that("are.paired return.paired.rocs works with missing values", { 59 | aSAH.missing <- aSAH 60 | aSAH.missing$ndka[1:20] <- NA 61 | r1 <- roc(aSAH.missing$outcome, aSAH.missing$ndka) 62 | pair <- are.paired(r1, r.wfns, return.paired.rocs = TRUE) 63 | expect_true(pair) 64 | expect_identical(attr(pair, "roc1")$thresholds, roc(aSAH$outcome[21:113], aSAH$ndka[21:113])$thresholds) 65 | expect_identical(attr(pair, "roc2")$thresholds, roc(aSAH$outcome[21:113], aSAH$wfns[21:113])$thresholds) 66 | }) 67 | 68 | test_that("are.paired return.paired.rocs doesn't return when unpaired", { 69 | pair <- are.paired(roc(aSAH$outcome[21:113], aSAH$wfns[21:113]), r.ndka, return.paired.rocs = TRUE) 70 | expect_null(attributes(pair)) 71 | }) 72 | 73 | test_that("are.paired works with smooth.roc curves", { 74 | expect_true(are.paired(smooth(r.wfns), smooth(r.ndka))) 75 | 76 | # Missing values shouldn't screw up 77 | aSAH.missing <- aSAH 78 | aSAH.missing$wfns[1:20] <- NA 79 | expect_true(are.paired(smooth(roc(aSAH.missing$outcome, aSAH.missing$wfns)), smooth(roc(aSAH.missing$outcome, aSAH.missing$ndka)))) 80 | # Also with different data.frames 81 | expect_true(are.paired(smooth(roc(aSAH.missing$outcome, aSAH.missing$wfns)), smooth(r.ndka))) 82 | 83 | # The following should fail though 84 | expect_false(are.paired(smooth(roc(aSAH$outcome[21:113], aSAH$wfns[21:113])), smooth(roc(aSAH$outcome, aSAH$ndka)))) 85 | 86 | # Opposite levels should probably fail 87 | expect_false(are.paired(smooth(roc(aSAH$outcome, aSAH$wfns, levels = c("Good", "Poor"))), smooth(roc(aSAH$outcome, aSAH$ndka, levels = c("Poor", "Good"))))) 88 | }) 89 | 90 | test_that("are.paired works with auc and mixed roc and smooth", { 91 | expect_true(are.paired(auc(aSAH$outcome, aSAH$wfns), smooth(roc(aSAH$outcome, aSAH$ndka)))) 92 | expect_true(are.paired(smooth(roc(aSAH$outcome, aSAH$wfns)), auc(aSAH$outcome, aSAH$ndka))) 93 | expect_true(are.paired(roc(aSAH$outcome, aSAH$wfns), smooth(roc(aSAH$outcome, aSAH$ndka)))) 94 | expect_true(are.paired(smooth(roc(aSAH$outcome, aSAH$wfns)), roc(aSAH$outcome, aSAH$ndka))) 95 | }) 96 | 97 | test_that("are.paired return.paired.rocs returns smooth curves", { 98 | aSAH.missing <- aSAH 99 | aSAH.missing$ndka[1:20] <- NA 100 | r1 <- roc(aSAH.missing$outcome, aSAH.missing$ndka, smooth = TRUE) 101 | pair <- are.paired(r1, smooth(r.wfns), return.paired.rocs = TRUE) 102 | expect_true(pair) 103 | expect_is(attr(pair, "roc1"), "smooth.roc") 104 | expect_is(attr(pair, "roc2"), "smooth.roc") 105 | }) 106 | 107 | test_that("are.paired return.paired.rocs smoothes curves with the right method", { 108 | skip_slow() 109 | aSAH.missing <- aSAH 110 | aSAH.missing$ndka[1:20] <- NA 111 | smooth.methods <- c("binormal", "density", "fitdistr", "logcondens", "logcondens.smooth") 112 | 113 | for (smooth.method in smooth.methods) { 114 | r1 <- smooth(roc(aSAH.missing$outcome, aSAH.missing$ndka), method = smooth.method) 115 | pair <- are.paired(r1, smooth(r.s100b, method = smooth.method), return.paired.rocs = TRUE) 116 | expect_true(pair) 117 | expect_identical(attr(pair, "roc1")$smoothing.args$method, smooth.method) 118 | expect_identical(attr(pair, "roc2")$smoothing.args$method, smooth.method) 119 | } 120 | }) 121 | 122 | test_that("are.paired return.paired.rocs doesn't return when unpaired and smooth", { 123 | pair <- are.paired(smooth(roc(aSAH$outcome[21:113], aSAH$wfns[21:113])), r.ndka, return.paired.rocs = TRUE) 124 | expect_null(attributes(pair)) 125 | pair <- are.paired(roc(aSAH$outcome[21:113], aSAH$wfns[21:113]), smooth(r.ndka), return.paired.rocs = TRUE) 126 | expect_null(attributes(pair)) 127 | pair <- are.paired(smooth(roc(aSAH$outcome[21:113], aSAH$wfns[21:113])), smooth(r.ndka), return.paired.rocs = TRUE) 128 | expect_null(attributes(pair)) 129 | }) 130 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.auc.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.auc") 5 | 6 | expected.ci.auc <- c(0.501244999271703, 0.611957994579946, 0.722670989888189) 7 | 8 | test_that("ci.auc with delong works", { 9 | test.ci <- ci.auc(r.ndka) 10 | expect_is(test.ci, "ci.auc") 11 | expect_equal(as.numeric(test.ci), expected.ci.auc) 12 | }) 13 | 14 | 15 | test_that("ci.auc with delong and percent works", { 16 | expect_equal(as.numeric(ci.auc(r.ndka.percent)), expected.ci.auc * 100) 17 | }) 18 | 19 | 20 | test_that("ci.auc works with an auc", { 21 | expect_equal(as.numeric(ci.auc(auc(r.ndka))), expected.ci.auc) 22 | }) 23 | 24 | 25 | test_that("ci.auc works with a formula", { 26 | expect_equal(as.numeric(ci.auc(outcome ~ ndka, data = aSAH)), expected.ci.auc) 27 | expect_equal( 28 | as.numeric(ci.auc(outcome ~ ndka, data = aSAH, subset = (gender == "Female"))), 29 | c(0.5261398281, 0.6671428571, 0.8081458862) 30 | ) 31 | }) 32 | 33 | 34 | test_that("ci.auc works with a response, predictor", { 35 | expect_equal(as.numeric(ci.auc(aSAH$outcome, aSAH$ndka)), expected.ci.auc) 36 | }) 37 | 38 | 39 | test_that("ci.auc works with a direction = >", { 40 | expect_equal(as.numeric(ci.auc(aSAH$outcome, -aSAH$ndka)), expected.ci.auc) 41 | }) 42 | 43 | 44 | test_that("ci.auc works with a direction = > and percent", { 45 | expect_equal(as.numeric(ci.auc(aSAH$outcome, -aSAH$ndka, percent = TRUE)), expected.ci.auc * 100) 46 | }) 47 | 48 | 49 | test_that("ci.auc.auc works with a partial AUC from a roc with full AUC", { 50 | ci.s100b <- ci.auc(r.s100b) 51 | expect_equal(attr(ci.s100b, "method"), "delong") 52 | pauc.s100b <- auc(r.s100b, partial.auc = c(1, .9), partial.auc.focus = "se", partial.auc.correct = TRUE) 53 | ci.pauc.s100b <- ci.auc(pauc.s100b, boot.n = 10) 54 | expect_equal(attr(ci.pauc.s100b, "method"), "bootstrap") 55 | expect_equal(attr(attr(ci.pauc.s100b, "auc"), "partial.auc"), c(1, .9)) 56 | expect_equal(attr(attr(ci.pauc.s100b, "auc"), "partial.auc.focus"), "sensitivity") 57 | expect_equal(attr(attr(ci.pauc.s100b, "auc"), "partial.auc.correct"), TRUE) 58 | }) 59 | 60 | 61 | # Only test whether ci.auc runs and returns without error. 62 | # Uses a very small number of iterations for speed 63 | # Doesn't test whether the results are correct. 64 | for (stratified in c(TRUE, FALSE)) { 65 | for (test.roc in list(r.s100b, smooth(r.s100b), auc(r.s100b), r.s100b.partial1, r.s100b.partial2$auc)) { 66 | test_that("ci.auc with bootstrap works", { 67 | n <- round(runif(1, 3, 9)) # keep boot.n small 68 | test.ci <- ci.auc(test.roc, method = "bootstrap", boot.n = n, conf.level = .91, boot.stratified = stratified) 69 | expect_is(test.ci, "ci.auc") 70 | expect_equal(attr(test.ci, "conf.level"), .91) 71 | expect_equal(attr(test.ci, "boot.n"), n) 72 | expect_equal(attr(test.ci, "names"), c("4.5%", "50%", "95.5%")) 73 | expect_equal(attr(test.ci, "boot.stratified"), stratified) 74 | expect_equal(attr(test.ci, "method"), "bootstrap") 75 | }) 76 | } 77 | } 78 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.coords.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.coords") 5 | 6 | test_that("ci.coords accepts threshold output with x=best", { 7 | expect_error(ci.coords(r.wfns, x = "best", input = "specificity", ret = c("threshold", "specificity", "sensitivity"), boot.n = 1), NA) 8 | }) 9 | 10 | test_that("ci.coords rejects threshold output except with x=best", { 11 | expect_error(ci.coords(r.wfns, x = 0.9, input = "specificity", ret = c("threshold", "specificity", "sensitivity"), boot.n = 1)) 12 | }) 13 | 14 | test_that("ci.coords accepts threshold output with x=best or if input was threshold", { 15 | expect_s3_class(ci.coords(r.wfns, x = 2, input = "threshold", ret = c("threshold", "specificity", "sensitivity"), boot.n = 1), "ci.coords") 16 | expect_s3_class(ci.coords(r.wfns, x = "best", ret = c("threshold", "specificity", "sensitivity"), boot.n = 1), "ci.coords") 17 | }) 18 | 19 | # Only test whether ci.coords runs and returns without error. 20 | # Uses a very small number of iterations for speed 21 | # Doesn't test whether the results are correct. 22 | valid_coords_input <- coord.is.monotone <- c( 23 | "threshold", "sensitivity", "specificity", "tn", "tp", "fn", "fp", "tpr", 24 | "tnr", "fpr", "fnr", "1-specificity", "1-sensitivity", "recall" 25 | ) 26 | for (input in valid_coords_input) { 27 | for (stratified in c(TRUE, FALSE)) { 28 | for (test.roc in list(r.s100b, smooth(r.s100b))) { 29 | context(sprintf("input: %s, stratified: %s, class: %s", input, stratified, class(test.roc))) 30 | test_that("ci.coords accepts one x and one ret", { 31 | skip_slow() 32 | obtained <- ci.coords(test.roc, 33 | x = 0.8, input = input, ret = "sp", 34 | boot.n = 3, conf.level = .91, boot.stratified = stratified 35 | ) 36 | expect_equal(attr(obtained, "ret"), "specificity") 37 | expect_equal(names(obtained), attr(obtained, "ret")) 38 | for (ci.mat in obtained) { 39 | expect_equal(dim(ci.mat), c(1, 3)) 40 | expect_equal(colnames(ci.mat), c("4.5%", "50%", "95.5%")) 41 | } 42 | }) 43 | 44 | test_that("ci.coords accepts one x and multiple ret", { 45 | skip_slow() 46 | obtained <- ci.coords(test.roc, 47 | x = 0.8, input = input, ret = c("sp", "ppv", "tp", "1-sensitivity"), 48 | boot.n = 3, conf.level = .91, boot.stratified = stratified 49 | ) 50 | expect_equal(attr(obtained, "ret"), c("specificity", "ppv", "tp", "1-sensitivity")) 51 | expect_equal(names(obtained), attr(obtained, "ret")) 52 | for (ci.mat in obtained) { 53 | expect_equal(dim(ci.mat), c(1, 3)) 54 | expect_equal(colnames(ci.mat), c("4.5%", "50%", "95.5%")) 55 | } 56 | }) 57 | 58 | test_that("ci.coords accepts multiple x and one ret", { 59 | skip_slow() 60 | obtained <- ci.coords(test.roc, 61 | x = c(0.8, 0.9), input = input, ret = "sp", 62 | boot.n = 3, conf.level = .91, boot.stratified = stratified 63 | ) 64 | expect_equal(attr(obtained, "ret"), "specificity") 65 | expect_equal(names(obtained), attr(obtained, "ret")) 66 | for (ci.mat in obtained) { 67 | expect_equal(dim(ci.mat), c(2, 3)) 68 | expect_equal(colnames(ci.mat), c("4.5%", "50%", "95.5%")) 69 | } 70 | }) 71 | 72 | test_that("ci.coords accepts multiple x and ret", { 73 | skip_slow() 74 | obtained <- ci.coords(test.roc, 75 | x = c(0.9, 0.8), input = input, ret = c("sp", "ppv", "tp", "1-se"), 76 | boot.n = 3, conf.level = .91, boot.stratified = stratified 77 | ) 78 | expect_equal(attr(obtained, "ret"), c("specificity", "ppv", "tp", "1-sensitivity")) 79 | expect_equal(names(obtained), attr(obtained, "ret")) 80 | for (ci.mat in obtained) { 81 | expect_equal(dim(ci.mat), c(2, 3)) 82 | expect_equal(colnames(ci.mat), c("4.5%", "50%", "95.5%")) 83 | } 84 | }) 85 | } 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.formula.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.formula") 5 | 6 | test_that("bootstrap cov works with smooth and !reuse.auc", { 7 | skip_slow() 8 | if (getRversion() > "3.6.0") { 9 | suppressWarnings(RNGkind(sample.kind = "Rounding")) 10 | } 11 | 12 | for (pair in list( 13 | list(ci, list()), 14 | list(ci.se, list(boot.n = 10)), 15 | list(ci.sp, list(boot.n = 10)), 16 | list(ci.thresholds, list(boot.n = 10)), 17 | list(ci.coords, list(boot.n = 10, x = 0.5)), 18 | list(ci.auc, list()) 19 | )) { 20 | fun <- pair[[1]] 21 | 22 | # First calculate ci with .default 23 | args.default <- c( 24 | list( 25 | response = aSAH$outcome, 26 | predictor = aSAH$s100b 27 | ), 28 | pair[[2]] 29 | ) 30 | set.seed(42) # For reproducible CI 31 | obs.default <- do.call(fun, args.default) 32 | 33 | # Then with .formula 34 | args.formula <- c( 35 | list( 36 | formula = outcome ~ s100b, 37 | data = aSAH 38 | ), 39 | pair[[2]] 40 | ) 41 | set.seed(42) # For reproducible CI 42 | obs.formula <- do.call(fun, args.formula) 43 | 44 | # Here we check both returned the same result 45 | # We ignore attributes, as we have different 46 | # roc objects, and unfortunately equivalent means 47 | # we only test near equality 48 | expect_equivalent(obs.default, obs.formula) 49 | } 50 | }) 51 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.se.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.se") 5 | 6 | # Only test whether ci.se runs and returns without error. 7 | # Uses a very small number of iterations for speed 8 | # Doesn't test whether the results are correct. 9 | 10 | 11 | for (stratified in c(TRUE, FALSE)) { 12 | for (test.roc in list(r.s100b, smooth(r.s100b))) { 13 | test_that("ci.se with default specificities", { 14 | n <- round(runif(1, 3, 9)) # keep boot.n small 15 | obtained <- ci.se(test.roc, 16 | boot.n = n, 17 | boot.stratified = stratified, conf.level = .91 18 | ) 19 | expect_is(obtained, "ci.se") 20 | expect_is(obtained, "ci") 21 | expect_equal(dim(obtained), c(11, 3)) 22 | expect_equal(attr(obtained, "conf.level"), .91) 23 | expect_equal(attr(obtained, "boot.n"), n) 24 | expect_equal(colnames(obtained), c("4.5%", "50%", "95.5%")) 25 | expect_equal(attr(obtained, "boot.stratified"), stratified) 26 | }) 27 | 28 | test_that("ci.se accepts one specificity", { 29 | n <- round(runif(1, 3, 9)) # keep boot.n small 30 | obtained <- ci.se(test.roc, 31 | specificities = 0.9, boot.n = n, 32 | boot.stratified = stratified, conf.level = .91 33 | ) 34 | expect_is(obtained, "ci.se") 35 | expect_is(obtained, "ci") 36 | expect_equal(dim(obtained), c(1, 3)) 37 | expect_equal(attr(obtained, "conf.level"), .91) 38 | expect_equal(attr(obtained, "boot.n"), n) 39 | expect_equal(colnames(obtained), c("4.5%", "50%", "95.5%")) 40 | expect_equal(attr(obtained, "boot.stratified"), stratified) 41 | }) 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.sp.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.sp") 5 | 6 | # Only test whether ci.sp runs and returns without error. 7 | # Uses a very small number of iterations for speed 8 | # Doesn't test whether the results are correct. 9 | 10 | for (stratified in c(TRUE, FALSE)) { 11 | for (test.roc in list(r.s100b, smooth(r.s100b))) { 12 | test_that("ci.sp with default sensitivities", { 13 | n <- round(runif(1, 3, 9)) # keep boot.n small 14 | obtained <- ci.sp(test.roc, 15 | boot.n = n, 16 | boot.stratified = stratified, conf.level = .91 17 | ) 18 | expect_is(obtained, "ci.sp") 19 | expect_is(obtained, "ci") 20 | expect_equal(dim(obtained), c(11, 3)) 21 | expect_equal(attr(obtained, "conf.level"), .91) 22 | expect_equal(attr(obtained, "boot.n"), n) 23 | expect_equal(colnames(obtained), c("4.5%", "50%", "95.5%")) 24 | expect_equal(attr(obtained, "boot.stratified"), stratified) 25 | }) 26 | 27 | test_that("ci.sp accepts one sensitivity", { 28 | n <- round(runif(1, 3, 9)) # keep boot.n small 29 | obtained <- ci.sp(test.roc, 30 | sensitivities = 0.9, boot.n = n, 31 | boot.stratified = stratified, conf.level = .91 32 | ) 33 | expect_is(obtained, "ci.sp") 34 | expect_is(obtained, "ci") 35 | expect_equal(dim(obtained), c(1, 3)) 36 | expect_equal(attr(obtained, "conf.level"), .91) 37 | expect_equal(attr(obtained, "boot.n"), n) 38 | expect_equal(colnames(obtained), c("4.5%", "50%", "95.5%")) 39 | expect_equal(attr(obtained, "boot.stratified"), stratified) 40 | }) 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /tests/testthat/test-ci.thresholds.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("ci.thresholds") 5 | 6 | # Only test whether ci.thresholds runs and returns without error. 7 | # Uses a very small number of iterations for speed 8 | # Doesn't test whether the results are correct. 9 | 10 | for (stratified in c(TRUE, FALSE)) { 11 | test_that("ci.threshold accepts thresholds=best", { 12 | n <- round(runif(1, 3, 9)) # keep boot.n small 13 | obtained <- ci.thresholds(r.wfns, 14 | thresholds = "best", boot.n = n, 15 | boot.stratified = stratified, conf.level = .91 16 | ) 17 | expect_is(obtained, "ci.thresholds") 18 | expect_is(obtained, "ci") 19 | expect_equal(names(obtained), c("specificity", "sensitivity")) 20 | expect_equal(dim(obtained$specificity), c(1, 3)) 21 | expect_equal(dim(obtained$sensitivity), c(1, 3)) 22 | expect_equal(attr(obtained, "conf.level"), .91) 23 | expect_equal(attr(obtained, "boot.n"), n) 24 | expect_equal(colnames(obtained$specificity), c("4.5%", "50%", "95.5%")) 25 | expect_equal(colnames(obtained$sensitivity), c("4.5%", "50%", "95.5%")) 26 | expect_equal(attr(obtained, "boot.stratified"), stratified) 27 | }) 28 | 29 | test_that("ci.threshold accepts thresholds=best", { 30 | n <- round(runif(1, 3, 9)) # keep boot.n small 31 | obtained <- ci.thresholds(r.ndka, 32 | thresholds = "local maximas", boot.n = n, 33 | boot.stratified = stratified, conf.level = .91 34 | ) 35 | expected.thresholds <- coords(r.ndka, x = "l", ret = "t", transpose = FALSE)$threshold 36 | expect_is(obtained, "ci.thresholds") 37 | expect_is(obtained, "ci") 38 | expect_equal(names(obtained), c("specificity", "sensitivity")) 39 | expect_equal(dim(obtained$specificity), c(length(expected.thresholds), 3)) 40 | expect_equal(dim(obtained$sensitivity), c(length(expected.thresholds), 3)) 41 | expect_equal(attr(obtained, "conf.level"), .91) 42 | expect_equal(attr(obtained, "boot.n"), n) 43 | expect_equal(colnames(obtained$specificity), c("4.5%", "50%", "95.5%")) 44 | expect_equal(colnames(obtained$sensitivity), c("4.5%", "50%", "95.5%")) 45 | expect_equal(attr(obtained, "boot.stratified"), stratified) 46 | }) 47 | 48 | test_that("ci.threshold accepts numeric thresholds", { 49 | n <- round(runif(1, 3, 9)) # keep boot.n small 50 | obtained <- ci.thresholds(r.ndka, 51 | thresholds = c(0.5, 0.2), boot.n = n, 52 | boot.stratified = stratified, conf.level = .91 53 | ) 54 | expected.thresholds <- coords(r.ndka, x = "l", ret = "t", transpose = FALSE)$threshold 55 | expect_is(obtained, "ci.thresholds") 56 | expect_is(obtained, "ci") 57 | expect_equal(names(obtained), c("specificity", "sensitivity")) 58 | expect_equal(dim(obtained$specificity), c(2, 3)) 59 | expect_equal(dim(obtained$sensitivity), c(2, 3)) 60 | expect_equal(attr(obtained, "conf.level"), .91) 61 | expect_equal(attr(obtained, "boot.n"), n) 62 | expect_equal(colnames(obtained$specificity), c("4.5%", "50%", "95.5%")) 63 | expect_equal(colnames(obtained$sensitivity), c("4.5%", "50%", "95.5%")) 64 | expect_equal(attr(obtained, "boot.stratified"), stratified) 65 | }) 66 | } 67 | -------------------------------------------------------------------------------- /tests/testthat/test-cov.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | test_that("cov with delong works", { 5 | expect_equal(cov(r.wfns, r.ndka), -0.000532967856762438) 6 | expect_equal(cov(r.ndka, r.s100b), -0.000756164938056579) 7 | expect_equal(cov(r.s100b, r.wfns), 0.00119615567376754) 8 | }) 9 | 10 | 11 | test_that("cov with obuchowski works", { 12 | expect_equal(cov(r.wfns, r.ndka, method = "obuchowski"), -3.917223e-06) 13 | expect_equal(cov(r.ndka, r.s100b, method = "obuchowski"), 0.0007945308) 14 | expect_equal(cov(r.s100b, r.wfns, method = "obuchowski"), 0.0008560803) 15 | }) 16 | 17 | 18 | test_that("cov works with auc and mixed roc/auc", { 19 | expect_equal(cov(auc(r.wfns), auc(r.ndka)), -0.000532967856762438) 20 | expect_equal(cov(auc(r.ndka), r.s100b), -0.000756164938056579) 21 | expect_equal(cov(r.s100b, auc(r.wfns)), 0.00119615567376754) 22 | }) 23 | 24 | 25 | test_that("cov with delong and percent works", { 26 | expect_equal(cov(r.wfns.percent, r.ndka.percent), -5.32967856762438) 27 | expect_equal(cov(r.ndka.percent, r.s100b.percent), -7.56164938056579) 28 | expect_equal(cov(r.s100b.percent, r.wfns.percent), 11.9615567376754) 29 | }) 30 | 31 | 32 | test_that("cov with delong, percent and mixed roc/auc works", { 33 | expect_equal(cov(auc(r.wfns.percent), r.ndka.percent), -5.32967856762438) 34 | expect_equal(cov(r.ndka.percent, auc(r.s100b.percent)), -7.56164938056579) 35 | expect_equal(cov(auc(r.s100b.percent), auc(r.wfns.percent)), 11.9615567376754) 36 | }) 37 | 38 | 39 | test_that("cov with obuchowski, percent and mixed roc/auc works", { 40 | expect_equal(cov(auc(r.wfns.percent), r.ndka.percent, method = "obuchowski"), -0.03917223) 41 | expect_equal(cov(r.ndka.percent, auc(r.s100b.percent), method = "obuchowski"), 7.9453082) 42 | expect_equal(cov(auc(r.s100b.percent), auc(r.wfns.percent), method = "obuchowski"), 8.560803) 43 | }) 44 | 45 | 46 | test_that("cov with different auc specifications warns", { 47 | expect_warning(cov(r.wfns, r.ndka.percent)) 48 | expect_warning(cov(r.wfns.percent, r.ndka)) 49 | # Also mixing auc/roc 50 | expect_warning(cov(auc(r.wfns), r.ndka.percent)) 51 | expect_warning(cov(r.wfns, auc(r.ndka.percent))) 52 | expect_warning(cov(r.wfns, auc(r.ndka.percent))) 53 | }) 54 | 55 | 56 | test_that("cov with delong, percent and direction = >", { 57 | expect_equal(cov(r.ndka.percent, r.s100b.percent), -7.56164938056579) 58 | }) 59 | 60 | 61 | test_that("cov with delong, percent, direction = > and mixed roc/auc", { 62 | r1 <- roc(aSAH$outcome, -aSAH$ndka, percent = TRUE) 63 | r2 <- roc(aSAH$outcome, -aSAH$s100b, percent = TRUE) 64 | expect_equal(cov(r1, r2), -7.56164938056579) 65 | expect_equal(cov(auc(r1), auc(r2)), -7.56164938056579) 66 | expect_equal(cov(auc(r1), r2), -7.56164938056579) 67 | expect_equal(cov(r1, auc(r2)), -7.56164938056579) 68 | }) 69 | 70 | 71 | test_that("cov with bootstrap works", { 72 | skip_slow() 73 | skip_if(getRversion() < "3.6.0") # added sample.kind 74 | RNGkind(sample.kind = "Rejection") 75 | set.seed(42) 76 | expect_equal(cov(r.wfns, r.ndka, method = "bootstrap", boot.n = 100), -0.000648524) 77 | expect_equal(cov(r.ndka.percent, r.s100b.percent, method = "bootstrap", boot.n = 100), -7.17528365) 78 | expect_equal(cov(r.s100b.partial1, r.wfns.partial1, method = "bootstrap", boot.n = 100), 2.294465e-05) 79 | expect_equal(cov(r.wfns, r.ndka, method = "bootstrap", boot.n = 100, boot.stratified = FALSE), -0.0007907488) 80 | }) 81 | 82 | test_that("bootstrap cov works with mixed roc, auc and smooth.roc objects", { 83 | skip_slow() 84 | for (roc1 in list(r.s100b, auc(r.s100b), smooth(r.s100b), r.s100b.partial2, r.s100b.partial2$auc)) { 85 | for (roc2 in list(r.wfns, auc(r.wfns), smooth(r.wfns), r.wfns.partial1, r.wfns.partial1$auc)) { 86 | n <- round(runif(1, 3, 9)) # keep boot.n small 87 | stratified <- sample(c(TRUE, FALSE), 1) 88 | suppressWarnings( # All sorts of warnings are expected 89 | obtained <- cov(roc1, roc2, 90 | method = "bootstrap", 91 | boot.n = n, boot.stratified = stratified 92 | ) 93 | ) 94 | expect_is(obtained, "numeric") 95 | expect_false(is.na(obtained)) 96 | } 97 | } 98 | }) 99 | 100 | test_that("bootstrap cov works with smooth and !reuse.auc", { 101 | skip_slow() 102 | skip_if(getRversion() < "3.6.0") # added sample.kind 103 | # First calculate cov by giving full curves 104 | roc1 <- smooth(roc(aSAH$outcome, aSAH$wfns, partial.auc = c(0.9, 1), partial.auc.focus = "sensitivity")) 105 | roc2 <- smooth(roc(aSAH$outcome, aSAH$s100b, partial.auc = c(0.9, 1), partial.auc.focus = "sensitivity")) 106 | 107 | suppressWarnings(RNGkind(sample.kind = "Rejection")) 108 | 109 | set.seed(42) # For reproducible CI 110 | expected_cov <- cov(roc1, roc2, boot.n = 100) 111 | expect_equal(expected_cov, -0.0000030024) 112 | 113 | # Now with reuse.auc 114 | set.seed(42) # For reproducible CI 115 | obtained_cov <- cov(smooth(r.wfns), smooth(r.s100b), 116 | reuse.auc = FALSE, 117 | partial.auc = c(0.9, 1), partial.auc.focus = "sensitivity", 118 | boot.n = 100 119 | ) 120 | expect_equal(expected_cov, obtained_cov) 121 | }) 122 | -------------------------------------------------------------------------------- /tests/testthat/test-deLongPlacementsCpp.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("DeLong Placements C++ code works") 5 | 6 | for (percent in c(FALSE, TRUE)) { 7 | for (marker in c("ndka", "wfns", "s100b")) { 8 | desc <- sprintf("delongPlacementsCpp runs with %s (percent = %s)", marker, percent) 9 | r <- roc(aSAH$outcome, aSAH[[marker]], percent = percent) 10 | test_that(desc, { 11 | placements <- pROC:::delongPlacementsCpp(r) 12 | expect_equal(placements, expected.placements[[marker]][["forward"]]) 13 | }) 14 | } 15 | 16 | for (marker in c("ndka", "wfns", "s100b")) { 17 | desc <- sprintf("delongPlacementsCpp runs with reversed levels and %s (percent = %s)", marker, percent) 18 | r <- roc(aSAH$outcome, aSAH[[marker]], levels = c("Poor", "Good"), percent = percent) 19 | test_that(desc, { 20 | placements <- pROC:::delongPlacementsCpp(r) 21 | expect_identical(names(placements), c("theta", "X", "Y")) 22 | }) 23 | } 24 | 25 | for (marker in c("ndka", "wfns", "s100b")) { 26 | desc <- sprintf("delongPlacementsCpp runs with reversed direction and %s (percent = %s)", marker, percent) 27 | r <- roc(aSAH$outcome, aSAH[[marker]], direction = ">", percent = percent) 28 | test_that(desc, { 29 | placements <- pROC:::delongPlacementsCpp(r) 30 | expect_identical(names(placements), c("theta", "X", "Y")) 31 | }) 32 | } 33 | 34 | for (marker in c("ndka", "wfns", "s100b")) { 35 | desc <- sprintf("delongPlacementsCpp runs with reversed levels reversed direction and %s (percent = %s)", marker, percent) 36 | r <- roc(aSAH$outcome, aSAH[[marker]], levels = c("Poor", "Good"), direction = ">", percent = percent) 37 | test_that(desc, { 38 | placements <- pROC:::delongPlacementsCpp(r) 39 | expect_identical(names(placements), c("theta", "X", "Y")) 40 | }) 41 | } 42 | } 43 | -------------------------------------------------------------------------------- /tests/testthat/test-geom_polygon_auc.R: -------------------------------------------------------------------------------- 1 | context("geom_polygon_auc") 2 | 3 | test_that("geom_polygon_auc works", { 4 | test_geom_polygon_auc_screenshot <- function() { 5 | print(ggroc(r.s100b) + geom_polygon_auc(r.s100b$auc)) 6 | } 7 | expect_ggroc_doppelganger("geom_polygon_auc.screenshot", test_geom_polygon_auc_screenshot) 8 | }) 9 | 10 | test_that("geom_polygon_auc works with percent and legacy.axes = TRUE", { 11 | test_geom_polygon_auc_percent_legacy_screenshot <- function() { 12 | print(ggroc(r.s100b.percent, legacy.axes = TRUE) + geom_polygon_auc(r.s100b.percent$auc, legacy.axes = TRUE)) 13 | } 14 | expect_ggroc_doppelganger("geom_polygon_auc.percent.legacy.screenshot", test_geom_polygon_auc_percent_legacy_screenshot) 15 | }) 16 | 17 | 18 | test_that("geom_polygon_auc works with percent and legacy.axes = TRUE", { 19 | test_geom_polygon_auc_partial_screenshot <- function() { 20 | auc_sp <- auc(r.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus = "sp") 21 | auc_se <- auc(r.s100b, partial.auc = c(0.8, 0.9), partial.auc.focus = "se") 22 | print(ggroc(r.s100b) + 23 | geom_polygon_auc(auc_se) + 24 | geom_polygon_auc(auc_sp)) 25 | } 26 | expect_ggroc_doppelganger("geom_polygon_auc.partial.screenshot", test_geom_polygon_auc_partial_screenshot) 27 | }) 28 | -------------------------------------------------------------------------------- /tests/testthat/test-ggroc.R: -------------------------------------------------------------------------------- 1 | context("ggroc") 2 | 3 | 4 | 5 | test_that("Ggroc screenshot looks normal", { 6 | skip_if(packageVersion("ggplot2") < "2.4") 7 | test_ggplot_screenshot <- function() { 8 | print(ggroc(r.s100b.percent, alpha = 0.5, colour = "red", linetype = 2, linewidth = 2)) 9 | } 10 | expect_ggroc_doppelganger("ggroc.screenshot", test_ggplot_screenshot) 11 | }) 12 | 13 | test_that("Ggroc works with legacy.axis and percent", { 14 | skip_if(packageVersion("ggplot2") < "2.4") 15 | 16 | # nothing 17 | test_ggplot_screenshot <- function() { 18 | print(ggroc(r.s100b)) 19 | } 20 | expect_ggroc_doppelganger("ggroc.screenshot_base", test_ggplot_screenshot) 21 | 22 | # percent 23 | test_ggplot_screenshot <- function() { 24 | print(ggroc(r.s100b.percent)) 25 | } 26 | expect_ggroc_doppelganger("ggroc.screenshot_percent", test_ggplot_screenshot) 27 | 28 | # legacy.axes 29 | test_ggplot_screenshot <- function() { 30 | print(ggroc(r.s100b, legacy.axes = TRUE)) 31 | } 32 | expect_ggroc_doppelganger("ggroc.screenshot_legacy", test_ggplot_screenshot) 33 | 34 | # percent, legacy.axes 35 | test_ggplot_screenshot <- function() { 36 | print(ggroc(r.s100b.percent, legacy.axes = TRUE)) 37 | } 38 | expect_ggroc_doppelganger("ggroc.screenshot_percent_legacy", test_ggplot_screenshot) 39 | }) 40 | 41 | test_that("Ggroc list screenshot looks normal", { 42 | test_ggplot_list_screenshot <- function() { 43 | print(ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka))) 44 | } 45 | expect_ggroc_doppelganger("ggroc.list.screenshot", test_ggplot_list_screenshot) 46 | }) 47 | 48 | test_that("Ggroc list can take multiple aes", { 49 | test_ggplot_list_screenshot <- function() { 50 | print(ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka), aes = c("c", "linetype"))) 51 | } 52 | expect_ggroc_doppelganger("ggroc.list.multi.aes", test_ggplot_list_screenshot) 53 | }) 54 | 55 | test_that("Ggroc list doesn't get merged with set colour", { 56 | test_ggplot_list_screenshot <- function() { 57 | print(ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka), colour = "red")) 58 | } 59 | expect_ggroc_doppelganger("ggroc.list.colour", test_ggplot_list_screenshot) 60 | }) 61 | 62 | test_that("Ggroc list extra aestetics screenshot looks normal", { 63 | test_ggplot_list_extra_aes_screenshot <- function() { 64 | print(ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka), aes = "linetype", color = "red")) 65 | } 66 | expect_ggroc_doppelganger("ggroc.list.extra.aes.screenshot", test_ggplot_list_extra_aes_screenshot) 67 | }) 68 | 69 | test_that("Ggroc list with group facet screenshot looks normal", { 70 | test_ggplot_list_group_facet_screenshot <- function() { 71 | library(ggplot2) 72 | g <- ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka), aes = "group") + facet_grid(. ~ name) 73 | print(g) 74 | } 75 | expect_ggroc_doppelganger("ggroc.list.group.facet.screenshot", test_ggplot_list_group_facet_screenshot) 76 | }) 77 | 78 | test_that("Ggroc aesthetics can be modified with scale_colour_manual", { 79 | test_ggplot_list_screenshot <- function() { 80 | print(ggroc(list(s100b = r.s100b, wfns = r.wfns, ndka = r.ndka), aes = c("c", "linetype")) + 81 | scale_colour_manual(values = c("purple", "yellow", "purple"))) 82 | } 83 | expect_ggroc_doppelganger("ggroc.list.scale.colour.manual", test_ggplot_list_screenshot) 84 | }) 85 | 86 | 87 | test_that("Ggroc screenshot looks normal with a single smooth.roc", { 88 | skip_if(packageVersion("ggplot2") < "2.4") 89 | test_ggplot_screenshot <- function() { 90 | print(ggroc(smooth(r.s100b), , alpha = 0.5, colour = "red", linetype = 2, linewidth = 2)) 91 | } 92 | expect_ggroc_doppelganger("ggroc.smooth.screenshot", test_ggplot_screenshot) 93 | }) 94 | 95 | test_that("Ggroc screenshot looks normal with a list of smooth.roc", { 96 | test_ggplot_screenshot <- function() { 97 | print(ggroc(list(s100b = smooth(r.s100b), wfns = smooth(r.wfns), ndka = smooth(r.ndka)))) 98 | } 99 | expect_ggroc_doppelganger("ggroc.smooth.list.screenshot", test_ggplot_screenshot) 100 | }) 101 | -------------------------------------------------------------------------------- /tests/testthat/test-large.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | 3 | context("large data sets") 4 | 5 | test_that("roc can deal with 1E5 data points and many thresholds", { 6 | response <- rbinom(1E5, 1, .5) 7 | predictor <- rnorm(1E5) 8 | # ~ 0.6s 9 | r <- roc(response, predictor) 10 | ci(r) 11 | expect_is(auc(r, partial.auc = c(0.9, 1)), "auc") 12 | }) 13 | 14 | test_that("roc can deal with 1E6 data points and few thresholds", { 15 | response <- rbinom(1E6, 1, .5) 16 | predictor <- rpois(1E6, 1) 17 | # ~ 0.3s 18 | r <- roc(response, predictor) 19 | ci(r) 20 | expect_is(auc(r, partial.auc = c(0.9, 1)), "auc") 21 | }) 22 | 23 | test_that("roc can deal with 1E7 data points and few thresholds", { 24 | skip_slow() 25 | response <- rbinom(1E7, 1, .5) 26 | predictor <- rpois(1E7, 1) 27 | # ~ 3s 28 | r <- roc(response, predictor) 29 | ci(r) 30 | expect_is(auc(r, partial.auc = c(0.9, 1)), "auc") 31 | }) 32 | -------------------------------------------------------------------------------- /tests/testthat/test-numeric-Inf.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | 3 | test_that("roc rejects rejects invalid data", { 4 | # Control always negative 5 | controls <- c(-Inf, 1, 2, 3, 4, 5) 6 | cases <- c(2, 3, 4, 5, 6) 7 | expect_warning(r <- roc(controls = controls, cases = cases), "Infinite value") 8 | expect_equal(r, NaN) 9 | 10 | # Control always positive 11 | # 100% specificity impossible 12 | controls <- c(1, 2, 3, 4, 5, Inf) 13 | cases <- c(2, 3, 4, 5, 6) 14 | expect_warning(r <- roc(controls = controls, cases = cases), "Infinite value") 15 | expect_equal(r, NaN) 16 | }) 17 | 18 | test_that("roc rejects rejects also valid data", { 19 | # OK 20 | controls <- c(1, 2, 3, 4, 5) 21 | cases <- c(-Inf, 2, 3, 4, 5, 6) 22 | expect_warning(r <- roc(controls = controls, cases = cases), "Infinite value") 23 | expect_equal(r, NaN) 24 | 25 | # OK 26 | controls <- c(1, 2, 3, 4, Inf) 27 | cases <- c(2, 3, 4, 5, 6) 28 | expect_warning(r <- roc(controls = controls, cases = cases), "Infinite value") 29 | expect_equal(r, NaN) 30 | }) 31 | -------------------------------------------------------------------------------- /tests/testthat/test-numeric-accuracy.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | numacc.response <- c(2, 1, 1, 2, 2, 1, 2, 2, 1, 1, 1, 2, 1, 2, 2, 2, 2, 2) 5 | numacc.predictor <- c( 6 | 0.960602681556147, 0.0794407386056549, 0.144842404246611, 7 | 0.931816485855784, 0.931816485855784, 0.97764041048215, 0.653549466997938699464, 8 | 0.796401132206396, 0.427720540184519, 0.811278021288732, 0.0188323116581187, 9 | 0.653549466997938588442, 0.653549466997938477419, 0.959111701445925, 0.931816485855784, 10 | 0.663663279418747, 0.800100838413179, 0.780456095511079 11 | ) 12 | expected.auc <- 0x1.8ef606a63bd82p-1 13 | # Predictor has near-ties that can break numerical comparisons 14 | 15 | test_that("AUC is consistent with numerical near-ties", { 16 | r2 <- roc(numacc.response, numacc.predictor, algorithm = 2) 17 | expect_equal(expected.auc, as.numeric(auc(r2))) 18 | }) 19 | 20 | test_that("AUC is consistent with numerical near-ties and direction = >", { 21 | r2 <- roc(2 - numacc.response, numacc.predictor, algorithm = 2) 22 | expect_equal(expected.auc, as.numeric(auc(r2))) 23 | }) 24 | 25 | test_that("delong theta is consistent with auc", { 26 | r2 <- roc(numacc.response, numacc.predictor, algorithm = 2) 27 | expect_equal(pROC:::delongPlacements(r2)$theta, as.numeric(auc(r2))) 28 | }) 29 | 30 | test_that("delong theta is consistent with auc and direction = >", { 31 | r2 <- roc(2 - numacc.response, numacc.predictor, algorithm = 2) 32 | expect_equal(pROC:::delongPlacements(r2)$theta, as.numeric(auc(r2))) 33 | }) 34 | 35 | # Test some crazy values 36 | # Multiple sequencial near-tie that will break the thresholding algorithm at the limits close to +-Inf or 0 37 | # Compare that with an "easy" curve with values with well defined intermediate averages 38 | test_that("Hard predictor has same results as easy one", { 39 | numacc.predictor.hard <- c( 40 | -0x1.fffffffffffffp+1023, -0x1.ffffffffffffep+1023, -0x1.ffffffffffffdp+1023, # Close to -Inf 41 | -0x1.249ad2594c37fp+332, -0x1.249ad2594c37ep+332, -0x1.249ad2594c37dp+332, -0x1.249ad2594c37cp+332, -0x1.249ad2594c37bp+332, -0x1.249ad2594c37ap+332, # Close to -1e100 42 | -0x0.0000000000003p-1022, -0x0.0000000000002p-1022, -0x0.0000000000001p-1022, -0x0p+0, # Close to -0 43 | 0x0p+0, 0x0.0000000000001p-1022, 0x0.0000000000002p-1022, 0x0.0000000000003p-1022, # Close to +0 44 | 0x1.249ad2594c37ap+332, 0x1.249ad2594c37bp+332, 0x1.249ad2594c37cp+332, 0x1.249ad2594c37dp+332, 0x1.249ad2594c37ep+332, 0x1.249ad2594c37fp+332, # Close to +1e100 45 | 0x1.ffffffffffffdp+1023, 0x1.ffffffffffffep+1023, 0x1.fffffffffffffp+1023 46 | ) # Close to +Inf 47 | numacc.predictor.easy <- c( 48 | -103, -102, -101, 49 | -10, -9, -8, -7, -6, -5, 50 | -0.1, -0.01, -0.001, 0, 51 | 0, 0.001, 0.01, 0.1, 52 | 5, 6, 7, 8, 9, 10, 53 | 101, 102, 103 54 | ) 55 | response <- rbinom(length(numacc.predictor.easy), 1, 0.5) 56 | roc.hard <- roc(response, numacc.predictor.hard, direction = "<") 57 | roc.easy <- roc(response, numacc.predictor.easy, direction = "<") 58 | expect_equal(roc.hard$sensitivities, roc.easy$sensitivities, info = paste("Random response: ", paste(response, collapse = ","))) 59 | expect_equal(roc.hard$specificities, roc.easy$specificities, info = paste("Random response: ", paste(response, collapse = ","))) 60 | expect_equal(roc.hard$direction, roc.easy$direction, info = paste("Random response: ", paste(response, collapse = ","))) 61 | }) 62 | 63 | test_that("Hard predictor has same results as easy one, random sampling", { 64 | skip_slow() 65 | numacc.predictor.hard <- c( 66 | -0x1.fffffffffffffp+1023, -0x1.ffffffffffffep+1023, -0x1.ffffffffffffdp+1023, # Close to -Inf 67 | -0x1.249ad2594c37fp+332, -0x1.249ad2594c37ep+332, -0x1.249ad2594c37dp+332, -0x1.249ad2594c37cp+332, -0x1.249ad2594c37bp+332, -0x1.249ad2594c37ap+332, # Close to -1e100 68 | -0x0.0000000000003p-1022, -0x0.0000000000002p-1022, -0x0.0000000000001p-1022, -0x0p+0, # Close to -0 69 | 0x0p+0, 0x0.0000000000001p-1022, 0x0.0000000000002p-1022, 0x0.0000000000003p-1022, # Close to +0 70 | 0x1.249ad2594c37ap+332, 0x1.249ad2594c37bp+332, 0x1.249ad2594c37cp+332, 0x1.249ad2594c37dp+332, 0x1.249ad2594c37ep+332, 0x1.249ad2594c37fp+332, # Close to +1e100 71 | 0x1.ffffffffffffdp+1023, 0x1.ffffffffffffep+1023, 0x1.fffffffffffffp+1023 72 | ) # Close to +Inf 73 | numacc.predictor.easy <- c( 74 | -103, -102, -101, 75 | -10, -9, -8, -7, -6, -5, 76 | -0.1, -0.01, -0.001, 0, 77 | 0, 0.001, 0.01, 0.1, 78 | 5, 6, 7, 8, 9, 10, 79 | 101, 102, 103 80 | ) 81 | a <- replicate(100, { 82 | response <- rbinom(length(numacc.predictor.easy), 1, 0.5) 83 | sample.vector <- sample(length(numacc.predictor.easy), replace = as.logical(rbinom(1, 1, 0.5))) 84 | expect_message(roc.hard <- roc(response, numacc.predictor.hard[sample.vector], direction = "<")) 85 | expect_message(roc.easy <- roc(response, numacc.predictor.easy[sample.vector], direction = "<")) 86 | expect_equal(roc.hard$sensitivities, roc.easy$sensitivities, 87 | info = 88 | c( 89 | paste("Random response: ", paste(response, collapse = ",")), 90 | paste("Random sample:", paste(sample.vector, collapse = ",")) 91 | ) 92 | ) 93 | expect_equal(roc.hard$specificities, roc.easy$specificities, 94 | info = 95 | c( 96 | paste("Random response: ", paste(response, collapse = ",")), 97 | paste("Random sample:", paste(sample.vector, collapse = ",")) 98 | ) 99 | ) 100 | expect_equal(roc.hard$direction, roc.easy$direction, 101 | info = 102 | c( 103 | paste("Random response: ", paste(response, collapse = ",")), 104 | paste("Random sample:", paste(sample.vector, collapse = ",")) 105 | ) 106 | ) 107 | }) 108 | }) 109 | -------------------------------------------------------------------------------- /tests/testthat/test-onload.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | 3 | context("onLoad") 4 | 5 | test_that(".parseRcppVersion works", { 6 | expect_equal(pROC:::.parseRcppVersion("65538"), "1.0.2") 7 | expect_equal(pROC:::.parseRcppVersion("1"), "0.0.1") 8 | }) 9 | 10 | test_that("We're running the right Rcpp version", { 11 | skip_if_not(exists("run_slow_tests") && run_slow_tests, message = "Skipping error-prone Rcpp version check") 12 | skip_if(Rcpp:::getRcppVersion() == "1.0.3", "RCPP_VERSION broken in 1.0.3") 13 | 14 | # This check will often fail, RCPP_VERSION is regularly out of sync, 15 | # for instance Rcpp 1.0.4.6 has RCPP_VERSION 1.0.4. We can't expect 16 | # it to be silent, however we still want it to execute without error 17 | # expect_silent(pROC:::.checkRcppVersion()) 18 | pROC:::.checkRcppVersion() 19 | 20 | # Replace the actual RcppVersion with a dummy function that returns 1 21 | # (= 0.0.1) so we actually see a warning 22 | saved.RcppVersion <- pROC:::RcppVersion 23 | assignInNamespace("RcppVersion", function() { 24 | return("1") 25 | }, "pROC") 26 | expect_warning(pROC:::.checkRcppVersion()) 27 | # Restore 28 | assignInNamespace("RcppVersion", saved.RcppVersion, "pROC") 29 | }) 30 | -------------------------------------------------------------------------------- /tests/testthat/test-roc.test-venkatraman.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | test_that("paired venkatraman works as expected", { 5 | skip_slow() 6 | ht <- roc.test(r.s100b, r.wfns, method = "venkatraman", boot.n = 12) 7 | expect_venkatraman_htest(ht) 8 | expect_equal(ht$alternative, "two.sided") 9 | expect_equal(ht$method, "Venkatraman's test for two paired ROC curves") 10 | expect_equal(unname(ht$parameter), 12) 11 | # Test output 12 | ht$statistic <- c(E = 42) 13 | ht$p.value <- 0 14 | expect_known_output(print(ht), "print_output/roc.test-venkatraman.paired") 15 | }) 16 | 17 | test_that("unpaired venkatraman works as expected", { 18 | skip_slow() 19 | expect_warning(ht <- roc.test(r.s100b, r.wfns, method = "venkatraman", boot.n = 12, paired = FALSE), "paired") 20 | expect_venkatraman_htest(ht) 21 | expect_equal(ht$alternative, "two.sided") 22 | expect_equal(ht$method, "Venkatraman's test for two unpaired ROC curves") 23 | expect_equal(unname(ht$parameter), 12) 24 | # Test output 25 | ht$statistic <- c(E = 41) 26 | ht$p.value <- 0.548347196932 27 | expect_known_output(print(ht), "print_output/roc.test-venkatraman.unpaired") 28 | }) 29 | 30 | test_that("non stratified venkatraman works as expected", { 31 | skip_slow() 32 | ht <- roc.test(r.s100b, r.wfns, method = "venkatraman", boot.n = 12, boot.stratified = FALSE) 33 | expect_venkatraman_htest(ht) 34 | expect_equal(ht$alternative, "two.sided") 35 | expect_equal(ht$method, "Venkatraman's test for two paired ROC curves") 36 | expect_equal(unname(ht$parameter), 12) 37 | # Test output 38 | ht$statistic <- c(E = 43) 39 | ht$p.value <- 0.05 40 | expect_known_output(print(ht), "print_output/roc.test-venkatraman.unstratified") 41 | }) 42 | 43 | test_that("non stratified, unpaired venkatraman works as expected", { 44 | skip_slow() 45 | expect_warning(ht <- roc.test(r.s100b, r.wfns, method = "venkatraman", boot.n = 12, boot.stratified = FALSE, paired = FALSE), "paired") 46 | expect_venkatraman_htest(ht) 47 | expect_equal(ht$alternative, "two.sided") 48 | expect_equal(ht$method, "Venkatraman's test for two unpaired ROC curves") 49 | expect_equal(unname(ht$parameter), 12) 50 | # Test output 51 | ht$statistic <- c(E = 43) 52 | ht$p.value <- 0.05 53 | expect_known_output(print(ht), "print_output/roc.test-venkatraman.unpaired.unstratified") 54 | }) 55 | -------------------------------------------------------------------------------- /tests/testthat/test-roc.utils.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("roc.utils") 5 | 6 | test_that("roc_utils_thr_idx finds correc thresholds with direction=<", { 7 | obtained <- pROC:::roc_utils_thr_idx(r.s100b, c(-Inf, 0.205, 0.055, Inf)) 8 | expect_equal(obtained, c(1, 18, 4, 51)) 9 | }) 10 | 11 | test_that("roc_utils_thr_idx finds correc thresholds with direction=>", { 12 | obtained <- pROC:::roc_utils_thr_idx(r.s100b, c(Inf, -Inf, 0.05, 0.055, 0.52, 0.205)) 13 | expect_equal(obtained, c(51, 1, 3, 4, 40, 18)) 14 | }) 15 | 16 | test_that("roc_utils_calc_coords works", { 17 | obtained <- pROC:::roc_utils_calc_coords(r.s100b, -1:-4, c(1, .5, .1, 0), c(0, .5, .9, 1), c(12, .9)) 18 | expect_equal(obtained, expected_roc_utils_calc_coords) 19 | }) 20 | 21 | test_that("roc_utils_calc_coords works with percent", { 22 | obtained <- pROC:::roc_utils_calc_coords(r.s100b.percent, -1:-4, c(100, 50, 10, 0), c(0, 50, 90, 100), c(12, .9)) 23 | expect_equal(obtained, expected_roc_utils_calc_coords.percent) 24 | }) 25 | 26 | test_that("roc_utils_match_coords_input_args works", { 27 | expect_equal(pROC:::roc_utils_match_coords_input_args("t"), "threshold") 28 | expect_equal(pROC:::roc_utils_match_coords_input_args("threshold"), "threshold") 29 | expect_equal(pROC:::roc_utils_match_coords_input_args("fp"), "fp") 30 | expect_equal(pROC:::roc_utils_match_coords_input_args("1-se"), "1-sensitivity") 31 | for (coord in names(which(pROC:::coord.is.monotone))) { 32 | expect_equal(pROC:::roc_utils_match_coords_input_args(coord), coord) 33 | } 34 | 35 | # Errors 36 | # t with threshold=False 37 | expect_error(pROC:::roc_utils_match_coords_input_args("t", threshold = FALSE)) 38 | # all only for ret 39 | expect_error(pROC:::roc_utils_match_coords_input_args("all")) 40 | # Only one allowed 41 | expect_error(pROC:::roc_utils_match_coords_input_args(c("specificity", "sensitivity"))) 42 | # Invalid arg 43 | expect_error(pROC:::roc_utils_match_coords_input_args("blah")) 44 | # Not monotone 45 | expect_error(pROC:::roc_utils_match_coords_input_args("npe")) 46 | expect_error(pROC:::roc_utils_match_coords_input_args("accuracy")) 47 | }) 48 | 49 | 50 | test_that("roc_utils_match_coords_ret_args works", { 51 | expect_equal(pROC:::roc_utils_match_coords_ret_args("t"), "threshold") 52 | expect_equal(pROC:::roc_utils_match_coords_ret_args("threshold"), "threshold") 53 | expect_equal(pROC:::roc_utils_match_coords_ret_args("fp"), "fp") 54 | expect_equal(pROC:::roc_utils_match_coords_ret_args("1-se"), "1-sensitivity") 55 | expect_equal(pROC:::roc_utils_match_coords_ret_args("npe"), "1-npv") 56 | for (coord in pROC:::roc.utils.valid.coords) { 57 | expect_equal(pROC:::roc_utils_match_coords_ret_args(coord), coord) 58 | } 59 | expect_equal(pROC:::roc_utils_match_coords_ret_args(pROC:::roc.utils.valid.coords), pROC:::roc.utils.valid.coords) 60 | 61 | # Errors 62 | # t with threshold=False 63 | expect_error(pROC:::roc_utils_match_coords_ret_args("t", threshold = FALSE)) 64 | # Invalid arg 65 | expect_error(pROC:::roc_utils_match_coords_ret_args("blah")) 66 | # The following should be invalid but somehow it seems valid to say: 67 | # match.arg(c("sensitivity", "blah"), "sensitivity", TRUE) 68 | # and the extra 'blah' arg is ignored by match.arg. 69 | # Ignoring for now 70 | # expect_error(pROC:::roc_utils_match_coords_ret_args(c("sensitivity", "blah"))) 71 | }) 72 | -------------------------------------------------------------------------------- /tests/testthat/test-roc.utils.percent.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("roc.utils.percent") 5 | 6 | test_that("roc_utils_topercent works on full AUC", { 7 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r.wfns), r.wfns.percent) 8 | }) 9 | 10 | test_that("roc_utils_unpercent works on full AUC", { 11 | expect_equal_ignore_call(pROC:::roc_utils_unpercent.roc(r.wfns.percent), r.wfns) 12 | }) 13 | 14 | test_that("roc_utils_topercent works on partial AUC", { 15 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r.wfns.partial1), r.wfns.percent.partial1) 16 | }) 17 | 18 | test_that("roc_utils_unpercent works on partial AUC", { 19 | expect_equal_ignore_call(pROC:::roc_utils_unpercent.roc(r.wfns.percent.partial1), r.wfns.partial1) 20 | }) 21 | 22 | test_that("roc_utils_topercent works with CI", { 23 | r <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE) 24 | r.percent <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE, percent = TRUE) 25 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r), r.percent) 26 | }) 27 | 28 | test_that("roc_utils_unpercent works with CI", { 29 | r <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE) 30 | r.percent <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE, percent = TRUE) 31 | expect_equal_ignore_call(pROC:::roc_utils_unpercent.roc(r.percent), r) 32 | }) 33 | 34 | test_that("roc_utils_topercent works without AUC", { 35 | r <- roc(aSAH$outcome, aSAH$wfns, auc = FALSE) 36 | r.percent <- roc(aSAH$outcome, aSAH$wfns, auc = FALSE, percent = TRUE) 37 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r), r.percent) 38 | }) 39 | 40 | test_that("roc_utils_unpercent works without AUC", { 41 | r <- roc(aSAH$outcome, aSAH$wfns, auc = FALSE) 42 | r.percent <- roc(aSAH$outcome, aSAH$wfns, auc = FALSE, percent = TRUE) 43 | expect_equal_ignore_call(pROC:::roc_utils_unpercent.roc(r.percent), r) 44 | }) 45 | 46 | test_that("roc_utils_topercent works with different types of CI", { 47 | r <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE) 48 | r.percent <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE, percent = TRUE) 49 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r), r.percent) 50 | }) 51 | 52 | test_that("roc.utils.to/unpercent works with ci .thresholds, .sp, .se", { 53 | skip_slow() 54 | for (of in c("thresholds", "sp", "se")) { 55 | set.seed(42) 56 | r <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE, of = of) 57 | set.seed(42) 58 | r.percent <- roc(aSAH$outcome, aSAH$wfns, ci = TRUE, percent = TRUE, of = of) 59 | expect_equal_ignore_call(pROC:::roc_utils_unpercent.roc(r.percent), r) 60 | expect_equal_ignore_call(pROC:::roc_utils_topercent.roc(r), r.percent) 61 | } 62 | }) 63 | -------------------------------------------------------------------------------- /tests/testthat/test-smooth.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | context("smooth") 5 | 6 | # Define some density functions 7 | 8 | unif.density <- function(x, n, from, to, bw, kernel, ...) { 9 | smooth.x <- seq(from = from, to = to, length.out = n) 10 | smooth.y <- dunif(smooth.x, min = min(x), max = max(x)) 11 | return(smooth.y) 12 | } 13 | 14 | norm.density <- function(x, n, from, to, bw, kernel, ...) { 15 | smooth.x <- seq(from = from, to = to, length.out = n) 16 | smooth.y <- dnorm(smooth.x, mean = mean(x), sd = sd(x)) 17 | return(smooth.y) 18 | } 19 | 20 | lnorm.density <- function(x, n, from, to, bw, kernel, ...) { 21 | smooth.x <- seq(from = from, to = to, length.out = n) 22 | smooth.y <- dlnorm(smooth.x, meanlog = mean(x), sdlog = sd(x)) 23 | return(smooth.y) 24 | } 25 | 26 | test_that("We fall back to the standard smooth", { 27 | tukey <- smooth(c(4, 1, 3, 6, 6, 4, 1, 6, 2, 4, 2)) 28 | expect_is(tukey, "tukeysmooth") 29 | expect_equal(as.numeric(tukey), c(3, 3, 3, 3, 4, 4, 4, 4, 2, 2, 2)) 30 | }) 31 | 32 | test_that("smooth with a density function works", { 33 | smoothed <- smooth(r.ndka, method = "density", density = unif.density, n = 10) 34 | expect_is(smoothed, "smooth.roc") 35 | expect_equal(smoothed$sensitivities, c(1, 1, 1, 0.875, 0.75, 0.625, 0.5, 0.375, 0.25, 0.125, 0, 0)) 36 | expect_equal(smoothed$specificities, c(0, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1)) 37 | expect_equal(as.numeric(smoothed$auc), 0.9375) 38 | }) 39 | 40 | test_that("smooth with two density functions works", { 41 | smoothed <- smooth(r.ndka, method = "density", density.controls = norm.density, density.cases = lnorm.density, n = 10) 42 | expect_is(smoothed, "smooth.roc") 43 | expect_equal(smoothed$sensitivities, c( 44 | 1, 1, 1, 0.635948942024884, 0.460070154191559, 0.344004532431686, 45 | 0.25735248652959, 0.188201024566009, 0.130658598389315, 0.0813814489619488, 46 | 0.0382893349015216, 0 47 | )) 48 | expect_equal(smoothed$specificities, c(0, 0, 0.832138478872629, 0.99999996787709, 1, 1, 1, 1, 1, 1, 1, 1)) 49 | expect_equal(as.numeric(smoothed$auc), 0.9694449) 50 | }) 51 | 52 | 53 | test_that("smooth with fitdistr works", { 54 | smoothed <- smooth(r.ndka, method = "fitdistr", n = 10) 55 | expect_is(smoothed, "smooth.roc") 56 | expect_equal(smoothed$sensitivities, c( 57 | 1, 1, 0.65584212882921, 0.303849532306639, 0.0922807400203477, 58 | 0.017547821937714, 0.00203415264061833, 0.000141550295211778, 59 | 5.86072275643637e-06, 1.43622216786009e-07, 2.05997195401133e-09, 60 | 0 61 | )) 62 | expect_equal(smoothed$specificities, c( 63 | 0, 0, 0.961731211013412, 0.999999997253703, 1, 1, 1, 1, 1, 64 | 1, 1, 1 65 | )) 66 | expect_equal(as.numeric(smoothed$auc), 0.814600645965216) 67 | }) 68 | 69 | test_that("smooth with fitdistr different densities works", { 70 | smoothed <- smooth(r.ndka, method = "fitdistr", density.controls = "normal", density.cases = "lognormal", n = 10) 71 | expect_is(smoothed, "smooth.roc") 72 | expect_equal(smoothed$sensitivities, c( 73 | 1, 1, 0.174065394158716, 0.0241224684680268, 0.00565556180305715, 74 | 0.0017644346804079, 0.000654794610631603, 0.000269912354252342, 75 | 0.000116632088037343, 4.89426737202444e-05, 1.6544031070368e-05, 76 | 0 77 | )) 78 | expect_equal(smoothed$specificities, c( 79 | 0, 0, 0.961731211013412, 0.999999997253703, 1, 1, 1, 1, 1, 80 | 1, 1, 1 81 | )) 82 | expect_equal(as.numeric(smoothed$auc), 0.568359871182632) 83 | }) 84 | 85 | test_that("smooth with fitdistr with a density function works", { 86 | smoothed <- smooth(r.ndka, 87 | method = "fitdistr", n = 10, 88 | density.controls = dnorm, start.controls = list(mean = 10, sd = 10), 89 | density.cases = dlnorm, start = list(meanlog = 2.7, sdlog = .822) 90 | ) 91 | expect_is(smoothed, "smooth.roc") 92 | expect_equal(smoothed$sensitivities, c( 93 | 1, 1, 0.174065542189585, 0.0241224212514905, 0.00565553823693818, 94 | 0.00176442417351747, 0.000654789746505889, 0.000269910020195159, 95 | 0.000116630962648119, 4.8942161699917e-05, 1.65438472509127e-05, 96 | 0 97 | )) 98 | expect_equal(smoothed$specificities, c( 99 | 0, 0, 0.961730914432089, 0.999999997253745, 1, 1, 1, 1, 1, 100 | 1, 1, 1 101 | )) 102 | expect_equal(as.numeric(smoothed$auc), 0.568359799581078) 103 | }) 104 | -------------------------------------------------------------------------------- /tests/testthat/test-var.R: -------------------------------------------------------------------------------- 1 | library(pROC) 2 | data(aSAH) 3 | 4 | 5 | test_that("var with delong works", { 6 | expect_equal(var(r.wfns), 0.00146991470882363) 7 | expect_equal(var(r.ndka), 0.0031908105493913) 8 | expect_equal(var(r.s100b), 0.00266868245717244) 9 | }) 10 | 11 | 12 | test_that("var works with auc", { 13 | expect_equal(var(auc(r.wfns)), 0.00146991470882363) 14 | expect_equal(var(auc(r.ndka)), 0.0031908105493913) 15 | expect_equal(var(auc(r.s100b)), 0.00266868245717244) 16 | }) 17 | 18 | 19 | test_that("var with delong and percent works", { 20 | expect_equal(var(r.wfns.percent), 14.6991470882363) 21 | expect_equal(var(r.ndka.percent), 31.908105493913) 22 | expect_equal(var(r.s100b.percent), 26.6868245717244) 23 | }) 24 | 25 | 26 | test_that("var works with auc and percent", { 27 | expect_equal(var(auc(r.wfns.percent)), 14.6991470882363) 28 | expect_equal(var(auc(r.ndka.percent)), 31.908105493913) 29 | expect_equal(var(auc(r.s100b.percent)), 26.6868245717244) 30 | }) 31 | 32 | 33 | test_that("var with delong and percent works", { 34 | expect_equal(var(roc(aSAH$outcome, -aSAH$ndka, percent = TRUE)), 31.908105493913) 35 | expect_equal(var(roc(aSAH$outcome, -aSAH$s100b, percent = TRUE)), 26.6868245717244) 36 | }) 37 | 38 | # Only test whether var runs and returns without error. 39 | # Uses a very small number of iterations for speed 40 | # Doesn't test whether the results are correct. 41 | test_that("bootstrap var runs with roc, auc and smooth.roc objects", { 42 | skip_slow() 43 | for (roc1 in list(r.s100b, auc(r.s100b), smooth(r.s100b), r.s100b.partial1, r.s100b.partial1$auc)) { 44 | n <- round(runif(1, 3, 9)) # keep boot.n small 45 | for (stratified in c(TRUE, FALSE)) { 46 | stratified <- sample(c(TRUE, FALSE), 1) 47 | obtained <- var(roc1, 48 | method = "bootstrap", 49 | boot.n = n, boot.stratified = stratified 50 | ) 51 | expect_is(obtained, "numeric") 52 | expect_false(is.na(obtained)) 53 | } 54 | } 55 | }) 56 | --------------------------------------------------------------------------------