diff --git a/.Rbuildignore b/.Rbuildignore index 590d6e1..71dc3f9 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,7 +2,6 @@ ^\.Rproj\.user$ ^README\.Rmd$ ^cran-comments\.md$ -^NEWS\.md$ ^\.github$ ^\.git$ ^\.gitignore$ @@ -16,5 +15,5 @@ ^\.pre-commit-config\.yaml$ ^CRAN-SUBMISSION$ ^doc$ -^docs$ ^Meta$ +^\.Rhistory$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index d4f5466..67c91a8 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -1,11 +1,12 @@ # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, master] + branches: [main, master, v1.0.0-dev] pull_request: - branches: [main, master] + workflow_dispatch: -name: R-CMD-check +name: R-CMD-check.yaml permissions: read-all @@ -21,18 +22,16 @@ jobs: config: - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} - - {os: ubuntu-latest, r: 'release'} - - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} R_KEEP_PKG_SOURCE: yes - _R_CHECK_FORCE_SUGGESTS_: false - _R_CHECK_CRAN_INCOMING_REMOTE_: false - _R_CHECK_CRAN_INCOMING_: false steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v6 - uses: r-lib/actions/setup-pandoc@v2 @@ -40,18 +39,6 @@ jobs: with: r-version: ${{ matrix.config.r }} http-user-agent: ${{ matrix.config.http-user-agent }} - use-public-rspm: true - - - name: Install system dependencies (Linux) - if: runner.os == 'Linux' - run: | - sudo apt-get update - sudo apt-get install -y libcurl4-openssl-dev libxml2-dev libssl-dev libfontconfig1-dev - - - name: Install system dependencies (macOS) - if: runner.os == 'macOS' - run: | - brew install --cask xquartz - uses: r-lib/actions/setup-r-dependencies@v2 with: @@ -61,7 +48,5 @@ jobs: - uses: r-lib/actions/check-r-package@v2 with: upload-snapshots: true - build_args: 'c("--no-manual", "--compact-vignettes=gs+qpdf")' - error-on: '"error"' - env: - _R_CHECK_FORCE_SUGGESTS_: false + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' + error-on: '"note"' diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 857959a..217401e 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -23,12 +23,9 @@ concurrency: cancel-in-progress: false jobs: - pkgdown: + # Builds the site for every event; pull requests stop here. + build: runs-on: ubuntu-latest - # Only restrict concurrency for non-PR jobs - environment: - name: github-pages - url: ${{ steps.deployment.outputs.page_url }} env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} permissions: @@ -54,14 +51,28 @@ jobs: shell: Rscript {0} - name: Setup Pages + if: github.event_name != 'pull_request' uses: actions/configure-pages@v4 - name: Upload artifact + if: github.event_name != 'pull_request' uses: actions/upload-pages-artifact@v3 with: path: docs + # The github-pages environment accepts deployments from the default branch + # only, so the job that uses it does not run for pull requests. + deploy: + if: github.event_name != 'pull_request' + needs: build + runs-on: ubuntu-latest + environment: + name: github-pages + url: ${{ steps.deployment.outputs.page_url }} + permissions: + pages: write + id-token: write + steps: - name: Deploy to GitHub Pages id: deployment - if: github.event_name != 'pull_request' uses: actions/deploy-pages@v4 diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 6e04d99..f50c0e8 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -2,35 +2,62 @@ # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help on: push: - branches: [main, master] + branches: [main, master, v1.0.0-dev] pull_request: - branches: [main, master] + workflow_dispatch: -name: test-coverage +name: test-coverage.yaml + +permissions: read-all jobs: test-coverage: runs-on: ubuntu-latest env: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + # Run the tests skipped on CRAN so that coverage includes them + NOT_CRAN: true steps: - - uses: actions/checkout@v4 + - uses: actions/checkout@v6 - uses: r-lib/actions/setup-r@v2 - with: - use-public-rspm: true - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::covr + extra-packages: any::covr, any::xml2 needs: coverage - name: Test coverage run: | - covr::codecov( + cov <- covr::package_coverage( quiet = FALSE, clean = FALSE, install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + print(cov) + covr::to_cobertura(cov) shell: Rscript {0} + + - uses: codecov/codecov-action@fb8b3582c8e4def4969c97caa2f19720cb33a72f # v7 + with: + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v7 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/DESCRIPTION b/DESCRIPTION index 6a51ed5..bab3360 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: BayesianQDM Type: Package -Title: Bayesian Quantitative Decision-Making Framework for Binary and Continuous Endpoints -Version: 0.1.0 +Title: Bayesian Quantitative Decision-Making Framework for Binary, Continuous and Time-to-Event Endpoints +Version: 1.0.0 Authors@R: c( person(given = "Gosuke", family = "Homma", @@ -10,48 +10,44 @@ Authors@R: c( person(given = "Yusuke", family = "Yamaguchi", role = c("aut"))) -Description: Provides comprehensive methods to calculate posterior probabilities, - posterior predictive probabilities, and Go/NoGo/Gray decision probabilities - for quantitative decision-making under a Bayesian paradigm in clinical trials. - The package supports both single and two-endpoint analyses for binary and - continuous outcomes, with controlled, uncontrolled, and external designs. - For single continuous endpoints, three calculation methods are - available: numerical integration (NI), Monte Carlo simulation (MC), and - Moment-Matching approximation (MM). For two continuous endpoints, a bivariate - Normal-Inverse-Wishart conjugate model is implemented with MC and MM methods. - For two binary endpoints, a Dirichlet-multinomial model is implemented. - External designs incorporate historical data through power priors - using exact conjugate representations (Normal-Inverse-Chi-squared for single - continuous, Normal-Inverse-Wishart for two continuous, and Dirichlet for - binary endpoints), enabling closed-form posterior computation without Markov - chain Monte Carlo (MCMC) sampling. This approach significantly reduces - computational burden while preserving complete Bayesian rigor. The package - also provides grid-search functions to find optimal Go and NoGo thresholds - that satisfy user-specified operating characteristic criteria for all - supported endpoint types and study designs. S3 print() and plot() methods - are provided for all decision probability classes, enabling formatted display - and visualisation of Go/NoGo/Gray operating characteristics across treatment - scenarios. - See Kang, Yamaguchi, and Han (2026) - for the methodological framework. +Description: Bayesian quantitative decision-making for proof-of-concept + clinical trials with Go, NoGo and Gray decisions. A study is specified by + its sample sizes, conjugate prior distributions, external data borrowed + through power priors, a concurrent, external, hypothetical or fixed + control group, and a decision criterion based on the posterior or + posterior predictive probability of the treatment effect. The package + computes the decision for observed data, the operating characteristics + of a design under scenarios for the true parameters, the decision + thresholds that control the probabilities of false Go and false NoGo + decisions, and the decision boundaries over possible observed data. One + or two binary endpoints (Beta-binomial and Dirichlet-multinomial + models), one or two continuous endpoints (Normal-Inverse-chi-squared and + Normal-Inverse-Wishart models) and one time-to-event endpoint evaluated + by the milestone survival probability (exponential model with Gamma + priors) are supported. The posterior distributions have closed forms, so + Markov chain Monte Carlo (MCMC) sampling is not needed; the + probabilities are computed by exact summation, numerical integration, a + moment-matching approximation or Monte Carlo simulation, with the main + computations in C++. See Kang, Yamaguchi, and Han (2026) + for the methodological framework. License: GPL (>= 2) Encoding: UTF-8 Language: en-US Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.3 Imports: ggplot2 (>= 3.4.0), - gridExtra, - mvtnorm, + grDevices, + Rcpp, stats +LinkingTo: + Rcpp Suggests: - testthat (>= 3.0.0), knitr, rmarkdown, - dplyr, - tidyr, - purrr, - spelling + spelling, + testthat (>= 3.0.0) VignetteBuilder: knitr +Config/testthat/edition: 3 URL: https://gosukehommaEX.github.io/BayesianQDM/, https://github.com/gosukehommaEX/BayesianQDM BugReports: https://github.com/gosukehommaEX/BayesianQDM/issues +Config/roxygen2/version: 8.0.0 diff --git a/NAMESPACE b/NAMESPACE index 4866701..c44212f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,82 +1,60 @@ # Generated by roxygen2: do not edit by hand -S3method(plot,getgamma1bin) -S3method(plot,getgamma1cont) -S3method(plot,getgamma2bin) -S3method(plot,getgamma2cont) -S3method(plot,pbayesdecisionprob1bin) -S3method(plot,pbayesdecisionprob1cont) -S3method(plot,pbayesdecisionprob2bin) -S3method(plot,pbayesdecisionprob2cont) -S3method(print,pbayesdecisionprob1bin) -S3method(print,pbayesdecisionprob1cont) -S3method(print,pbayesdecisionprob2bin) -S3method(print,pbayesdecisionprob2cont) -export(allmultinom) -export(getgamma1bin) -export(getgamma1cont) -export(getgamma2bin) -export(getgamma2cont) -export(getjointbin) -export(pbayesdecisionprob1bin) -export(pbayesdecisionprob1cont) -export(pbayesdecisionprob2bin) -export(pbayesdecisionprob2cont) -export(pbayespostpred1bin) -export(pbayespostpred1cont) -export(pbayespostpred2bin) -export(pbayespostpred2cont) +S3method(format,qdm_borrow) +S3method(format,qdm_calibration) +S3method(format,qdm_conduct) +S3method(format,qdm_criterion) +S3method(format,qdm_data) +S3method(format,qdm_decision) +S3method(format,qdm_design) +S3method(format,qdm_hypothetical) +S3method(format,qdm_prior) +S3method(plot,qdm_boundary) +S3method(plot,qdm_calibration) +S3method(plot,qdm_oc) +S3method(print,qdm_borrow) +S3method(print,qdm_boundary) +S3method(print,qdm_calibration) +S3method(print,qdm_conduct) +S3method(print,qdm_criterion) +S3method(print,qdm_data) +S3method(print,qdm_decision) +S3method(print,qdm_design) +S3method(print,qdm_hypothetical) +S3method(print,qdm_oc) +S3method(print,qdm_prior) +export(borrow) +export(cellprob_binary2) +export(conduct_tte) +export(criterion_posterior) +export(criterion_predictive) +export(data_binary) +export(data_binary2) +export(data_continuous) +export(data_continuous2) +export(data_tte) +export(design_binary) +export(design_binary2) +export(design_continuous) +export(design_continuous2) +export(design_tte) +export(hypothetical) export(pbetabinomdiff) export(pbetadiff) -export(ptdiff_MC) -export(ptdiff_MM) -export(ptdiff_NI) +export(prior_beta) +export(prior_dirichlet) +export(prior_gamma) +export(prior_niw) +export(prior_nix) +export(prior_vague) +export(psurvdiff) +export(ptdiff) +export(qdm_boundary) +export(qdm_calibrate) +export(qdm_decide) +export(qdm_oc) +export(qdm_regions) export(rdirichlet) -importFrom(ggplot2,aes) -importFrom(ggplot2,annotate) -importFrom(ggplot2,coord_cartesian) -importFrom(ggplot2,element_blank) -importFrom(ggplot2,element_line) -importFrom(ggplot2,element_text) -importFrom(ggplot2,geom_hline) -importFrom(ggplot2,geom_line) -importFrom(ggplot2,geom_point) -importFrom(ggplot2,geom_text) -importFrom(ggplot2,geom_tile) -importFrom(ggplot2,geom_vline) -importFrom(ggplot2,ggplot) -importFrom(ggplot2,guide_colorsteps) -importFrom(ggplot2,guide_legend) -importFrom(ggplot2,guides) -importFrom(ggplot2,labs) -importFrom(ggplot2,margin) -importFrom(ggplot2,scale_color_gradient) -importFrom(ggplot2,scale_color_manual) -importFrom(ggplot2,scale_color_stepsn) -importFrom(ggplot2,scale_fill_gradient) -importFrom(ggplot2,scale_fill_manual) -importFrom(ggplot2,scale_fill_stepsn) -importFrom(ggplot2,scale_linetype_manual) -importFrom(ggplot2,scale_x_continuous) -importFrom(ggplot2,scale_y_continuous) -importFrom(ggplot2,theme) -importFrom(ggplot2,theme_bw) -importFrom(ggplot2,unit) -importFrom(grDevices,col2rgb) -importFrom(grDevices,rgb) -importFrom(gridExtra,grid.arrange) -importFrom(mvtnorm,pmvt) -importFrom(stats,dbeta) -importFrom(stats,dbinom) -importFrom(stats,dmultinom) -importFrom(stats,dt) -importFrom(stats,integrate) -importFrom(stats,pbeta) -importFrom(stats,pt) -importFrom(stats,rbinom) -importFrom(stats,rchisq) -importFrom(stats,rgamma) -importFrom(stats,rmultinom) -importFrom(stats,rnorm) -importFrom(stats,rt) -importFrom(stats,setNames) +importFrom(Rcpp,sourceCpp) +importFrom(ggplot2,.data) +useDynLib(BayesianQDM, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 7c5db43..62aef6c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,299 @@ +# BayesianQDM 1.0.0 + +This version is a redesign of the package and is not backward compatible with +version 0.1.0. A study is described by small specification objects (priors, +data, external data, hypothetical controls and decision criteria) that are +combined into a design, and three functions work with any design: +`qdm_decide()`, `qdm_oc()` and `qdm_calibrate()`. `qdm_boundary()` shows the +decision boundaries of a design. Formulas and numerical +methods that were wrong in version 0.1.0 have been corrected (see below), so +some results differ from those of version 0.1.0. `vignette("migration")` +shows how to translate code written for version 0.1.0. + +## Correspondence with version 0.1.0 + +| Version 0.1.0 | Version 1.0.0 | +|---|---| +| `pbayespostpred1bin()`, `pbayespostpred1cont()`, `pbayespostpred2bin()`, `pbayespostpred2cont()` | `qdm_decide()` with a design and observed data | +| `pbayesdecisionprob1bin()`, `pbayesdecisionprob1cont()`, `pbayesdecisionprob2bin()`, `pbayesdecisionprob2cont()` | `qdm_oc()` | +| `getgamma1bin()`, `getgamma1cont()`, `getgamma2bin()`, `getgamma2cont()` | `qdm_calibrate()` | +| Arguments `prob`, `design`, `prior`, `CalcMethod`, `theta_*`, `gamma_*`, `a_*`, `b_*`, `kappa0_*` and similar | Arguments of `criterion_*()`, `prior_*()` and `design_*()` | +| Arguments `ne_*`, `ye_*`, `alpha0e_*`, `bar_ye_*`, `se_*` | `borrow(data_*(...), a0)` | +| Arguments `z`, `z00` to `z11`, `mu0_c`, `r` | `hypothetical()` | +| `ptdiff_NI()`, `ptdiff_MC()`, `ptdiff_MM()` | `ptdiff()` with `method = "NI"`, `"MC"` or `"MM"` | +| `pbetadiff()`, `pbetabinomdiff()` | Same names, with the arguments ordered by group | +| `getjointbin()` | `cellprob_binary2()` | +| `allmultinom()` | Internal function | +| `rdirichlet()` | Same name | +| `print()` and `plot()` methods for eight classes | Methods for `qdm_decision`, `qdm_oc`, `qdm_calibration`, `qdm_boundary`, `qdm_design` and the specification objects | + +## Documentation, validation and computation + +* Seven vignettes: an overview, one for each type of endpoint, and a guide + to migrating from version 0.1.0. +* `inst/validation/` contains scripts that compare the package with + published and submitted results (Kang et al., 2026; Huang et al., + submitted; Yamaguchi, Homma, Takeda and Maruo, submitted; Yamaguchi et + al., submitted), and + `inst/validation/results/summary.md` reports the comparisons, with a + registered reason for every difference beyond rounding, including the + results that are not reproduced. +* The numerical integration and the Monte Carlo loops are written in C++ + with Rcpp. + +## Specification functions + +* Priors: `prior_beta()`, `prior_dirichlet()`, `prior_nix()`, `prior_niw()`, + `prior_gamma()` and `prior_vague()`. +* Data summaries: `data_binary()`, `data_continuous()`, `data_binary2()`, + `data_continuous2()` and `data_tte()`. +* Conduct of a study with a time-to-event endpoint (enrollment, dropout and + time of the analysis): `conduct_tte()`. +* External data with a power prior weight from 0 to 1: `borrow()`. +* Hypothetical control for uncontrolled studies: `hypothetical()`. +* Decision criteria: `criterion_posterior()` and `criterion_predictive()`. + For all endpoints, the Go criterion is that the probability of the Go + region is at least `gamma_go` and the NoGo criterion is that the + probability of the NoGo region is at least `gamma_nogo`. +* `qdm_regions()` shows the numbering of the regions for two endpoints. + +## Designs and operations: one binary endpoint + +* `design_binary()` specifies a study with one binary endpoint: sample sizes, + Beta priors, external data for either group (`borrow()`), and a concurrent, + external-only (`n_c = 0` with `external_c`) or hypothetical (`n_c = 0` with + `hypothetical_c`) control group. +* `qdm_decide()` computes the probabilities of the Go and NoGo regions for + observed data and returns the decision: Go, NoGo, Gray, or Miss (both + criteria met). +* `qdm_oc()` computes the probabilities of the four decisions under + scenarios for the true response rates by exact enumeration of the + outcomes. Miss decisions are reported in their own column with a warning; + the arguments `error_if_Miss` and `Gray_inc_Miss` of version 0.1.0 are + removed. +* `qdm_calibrate()` chooses `gamma_go` and `gamma_nogo` as the smallest grid + values for which the probabilities that the Go criterion is met under one + scenario and that the NoGo criterion is met under another are at most + their targets (version 0.1.0 required them to be less than the targets), + and returns the design with these thresholds and its decision + probabilities. +* `print()` methods for designs, decisions, operating characteristics and + calibrations, and `plot()` methods (ggplot2) for operating characteristics + and calibrations. Without a concurrent control group, the thresholds in + the plot of operating characteristics are shifted by the mean of the + distribution of the control group. +* Probabilities are no longer set to 0 below `.Machine$double.eps^0.25`. A + probability that is below a threshold by less than 1e-10 is treated as + equal to the threshold, so that exact ties are not decided by rounding + errors. + +## Designs and operations: one continuous endpoint + +* `design_continuous()` specifies a study with one normally distributed + endpoint: sample sizes, Normal-Inverse-chi-squared (`prior_nix()`) or vague + (`prior_vague()`) priors, external data for either group (`borrow()`), a + concurrent, external-only or hypothetical control group, and the method + used to compute the probabilities (`"NI"`, `"MM"` or `"MC"`). +* External data enter through the conjugate representation of the power + prior. With the vague prior, the posterior distribution of the mean has + `a0 * n_e + n - 1` degrees of freedom, and the posterior scale uses the + same denominator (version 0.1.0 used `a0 * n_e + n`, so the posterior did + not reduce to the one without external data as `a0` tends to 0). +* The posterior predictive distribution of the mean of `m` future subjects + is `t(nu_n, mu_n, sigma_n^2 * (1 / kappa_n + 1 / m))`. Version 0.1.0 used + the squared scale `sigma_n^2 * (1 + 1 / kappa_n) / m`, which treats the `m` + future subjects as independent draws from the predictive distribution of + one subject and understates the uncertainty for `m` of 2 or more. +* A hypothetical control (`hypothetical(mean = mu0c, r = r)`) gives the + control mean the distribution `t(nu_nt, mu0c, r * sigma_nt^2 / kappa_nt)` + (Kang et al., 2026, Section 4.2.4). For the predictive criterion its + squared scale is `r * sigma_nt^2 * (1 / kappa_nt + 1 / m_c)`. +* `qdm_oc()` and `qdm_calibrate()` simulate the sample means and standard + deviations of `nsim` studies, with the same random numbers for all + scenarios. With `method = "MC"`, the probabilities of the Go and NoGo + regions are estimated from the same draws, so that they add up to 1 for + the predictive criterion. +* `qdm_decide()` has a `seed` argument for designs with `method = "MC"`. + +## Designs and operations: two binary endpoints + +* `design_binary2()` specifies a study with two binary endpoints: sample + sizes, Dirichlet priors for the probabilities of the four combinations of + responses (`prior_dirichlet()`), external data for either group + (`borrow(data_binary2(...), a0)`), a concurrent, external-only or + hypothetical control group, the number of Monte Carlo draws `nMC`, and + whether the operating characteristics are computed by enumerating all + outcomes (`enumerate = TRUE`, the default) or by simulation. +* For two endpoints, `criterion_posterior()` and `criterion_predictive()` + have the argument `rule`. With `rule = "joint"` (the default), the + criteria are on the probabilities of unions of regions (`go_regions` and + `nogo_regions`, numbered as in `qdm_regions()`). With `rule = "and"` or + `rule = "or"`, the criteria are on each endpoint separately (the + probability that the effect exceeds its TV, or is at most its MAV), with + one threshold for both endpoints or one per endpoint. +* The posterior predictive probabilities of the regions are computed + exactly from the joint distribution of the numbers of future responders + on the two endpoints (Dirichlet-multinomial distribution) instead of by + Monte Carlo simulation. A future effect equal to the null value is not + counted as larger; version 0.1.0 compared differences of rounded + proportions, so some exact ties were counted as larger. +* The posterior probabilities of the regions are estimated with `nMC` + draws (default 10000) from the Dirichlet posterior distributions, computed + in C++. The probabilities of all regions, and of the Go and NoGo regions, + are estimated from the same draws, and `qdm_decide()` reports all of them. + `qdm_decide()`, `qdm_oc()` and `qdm_calibrate()` take `seed` for these + draws. +* `qdm_oc()` takes scenarios with the columns `pi_t1`, `pi_t2`, `rho_t`, + `pi_c1`, `pi_c2` and `rho_c`. With enumeration, the region probabilities + are computed once for every pair of treatment and control outcomes, with + the same Monte Carlo draws for all pairs, and weighted by the multinomial + probabilities under each scenario. With simulation, all scenarios use the + same uniform random numbers. Enumeration is limited to 1e7 pairs of + outcomes (for example, 24 subjects in each group). A scenario whose + correlation is outside the feasible range for its response rates is not + evaluable: its probabilities are `NA` with a warning (version 0.1.0 + stopped with an error in its Monte Carlo path). `qdm_calibrate()` requires + feasible scenarios. +* `plot()` of operating characteristics for two endpoints draws a heat map + of the probability of each decision over the effects on the two endpoints + and marks scenarios that are not evaluable with "NE". + +## Designs and operations: two continuous endpoints + +* `design_continuous2()` specifies a study with two continuous endpoints: + sample sizes, Normal-Inverse-Wishart (`prior_niw()`) or vague + (`prior_vague()`) priors, external data for either group + (`borrow(data_continuous2(...), a0)`), a concurrent, external-only or + hypothetical (`hypothetical(mean = c(m1, m2), r = r)`) control group, the + decision criterion for two endpoints (with `rule` as for two binary + endpoints), and the method used to compute the probabilities (`"MM"` or + `"MC"`). +* The posterior parameters are updated with the external data (power prior) + and then with the current data; the vague prior corresponds to + `kappa0 = 0`, `nu0 = -1` and `Lambda0 = 0`. +* The posterior predictive distribution of the mean of `m` future subjects + has the scale matrix `(1 / kappa_n + 1 / m) * Lambda_n / (nu_n - 1)`. + Version 0.1.0 used `(1 + kappa_n) / kappa_n * Lambda_n / (nu_n - 1) / m`, + which treats the `m` future subjects as independent draws from the + predictive distribution of one subject. +* With `method = "MM"`, the moment-matching approximation of the difference + of two bivariate t distributions is used, and its rectangle probabilities + are computed by numerical integration in C++ for real degrees of freedom + (version 0.1.0 rounded the degrees of freedom to an integer for + `mvtnorm::pmvt()`). With `method = "MC"`, the probabilities of all + regions are estimated from the same draws, and every simulated study uses + its own draws (version 0.1.0 used the same draws for all simulated + studies, so the Monte Carlo error did not average out). +* `qdm_oc()` takes scenarios with the columns `mu_t1`, `mu_t2`, `sd_t1`, + `sd_t2`, `rho_t`, `mu_c1`, `mu_c2`, `sd_c1`, `sd_c2` and `rho_c`, and + simulates the sample means and the sums of squares and cross-products + (Bartlett decomposition of the Wishart distribution) of `nsim` studies + with the same random numbers for all scenarios. + +## Fixed control + +* All design functions have the argument `fixed_c` for a single-arm study + compared with a known value of the control parameter (a response rate, a + mean, or a milestone survival probability; one value per endpoint for two + endpoints). It requires `n_c = 0` and `prior_c = NULL`. The effect is the + treatment parameter minus the fixed value, so the probabilities depend + only on the posterior distribution of the treatment group: Beta + probabilities (one binary endpoint), t probabilities (one continuous + endpoint), probabilities of the bivariate t distribution by numerical + integration for any degrees of freedom (two continuous endpoints), Monte + Carlo draws from the Dirichlet posterior (posterior probabilities for two + binary endpoints), Gamma probabilities (posterior probabilities for a + time-to-event endpoint), and exact predictive probabilities for binary + endpoints, in which a future proportion equal to the fixed value plus the + null value is not counted as larger. The argument `method` is not used + for continuous endpoints. +* Without a concurrent control group, the thresholds in the plot of + operating characteristics are shifted by the fixed value. + +## Designs and operations: one time-to-event endpoint + +* `design_tte()` specifies a study with one time-to-event endpoint evaluated + by the survival probability at a milestone time: exponential event times + with Gamma priors on the hazards (`prior_gamma()`), data summarized by the + number of events and the total observed time (`data_tte()`), external + data for either group through a power prior, and a concurrent, + external-only, hypothetical or fixed control group. The effect is the + difference of the milestone survival probabilities. +* Posterior probabilities are computed by numerical integration over the + control hazard (`psurvdiff()`), or exactly for a fixed control. + Posterior predictive probabilities are estimated by simulating `nMC` + future studies conducted as specified by `conduct_future`, with hazards + drawn from the posterior distributions; the milestone survival of each + group in the future study is estimated at the posterior mean of the + hazard given the future data and the prior of the group. +* `qdm_oc()` and `qdm_calibrate()` simulate `nsim` studies with piecewise + uniform enrollment, piecewise exponential dropout and an analysis at a + calendar time or at a given number of events among all subjects of the + study (`conduct_tte()`), under scenarios given by the median survival + times (`median_t`, `median_c`), with the same random numbers for all + scenarios. + +## Decision boundaries + +* `qdm_boundary()` computes the decision for each point of a grid of + possible observed data of the treatment group, and its `plot()` method + draws the regions of the data that lead to Go, NoGo, Gray and Miss + decisions: the numbers of responders of the two groups (one binary + endpoint with a concurrent control group) or the number of responders and + the sample size (without one), the observed mean (or difference in means) + and the standard deviation or sample size (one continuous endpoint), the + observed means (or differences in means) of the two endpoints (two + continuous endpoints), and the number of events and the total observed + time (time-to-event endpoint). Two binary endpoints are not supported. + +## Plots + +* The `plot()` methods for operating characteristics, calibrations and + decision boundaries return ggplot2 objects, which can be changed further + by adding ggplot2 functions such as `labs()` and `theme()`. In all three + plots, arguments set the colors of the decisions (`col_go`, `col_nogo`, + `col_gray` and `col_miss`, green, red, gray and orange by default; the + calibration plot uses `col_go` and `col_nogo`), the base font size + (`base_size`, 11 by default instead of 28 in version 0.1.0) and the + position of the legend (`legend_position`). The plots of operating + characteristics and calibrations also take the width of the lines + (`linewidth`), and the plot of operating characteristics the size of the + points (`point_size`) and of the text drawn in the plot (`label_size`). + Other arguments are ignored with a warning. +* The heat maps of two endpoints shade each panel from white (probability 0) + to the color of its decision (probability 1); their colors are set by the + color arguments. They have no legend, since each cell shows its + probability. Scenarios that are not evaluable are white and marked "NE". + +## Distribution functions + +* `pbetadiff()` has the argument order `(q, a_t, b_t, a_c, b_c)`. The range + of integration is restricted to the support and split at quantiles of both + Beta distributions, so concentrated distributions are integrated + accurately. When a shape parameter of the control group is below 1, the + integral near the unbounded end of its density is computed after a change + of variables that removes the singularity. The computation is done in C++. +* `pbetabinomdiff()` has the argument order + `(q, m_t, a_t, b_t, m_c, a_c, b_c)` and computes the probability mass + functions on the log scale, so large numbers of future subjects no longer + cause overflow. Values of `q` far outside [-1, 1] are handled exactly. +* `ptdiff()` replaces `ptdiff_NI()`, `ptdiff_MC()` and `ptdiff_MM()`. The + numerical integration now covers the whole real line (version 0.1.0 + truncated the range, with errors of up to about 3e-4 for small degrees of + freedom). It integrates over the group with the smaller scale, splits the + range around the peak of the density and the change of the other factor, + and integrates the parts far from the origin on a logarithmic scale, so + that scale ratios from 1e-9 to 1e3 and degrees of freedom from 0.5 to + `Inf` are handled. +* `rdirichlet()` always returns a matrix. +* `cellprob_binary2()` replaces `getjointbin()`. +* `psurvdiff()` computes the distribution function of the difference of two + milestone survival probabilities with Gamma distributed exponential + hazards, by adaptive quadrature in C++ over the hazard of one group, with + the range split at quantiles of both hazards and a change of variables + near 0 when a shape parameter is below 1. Each tail is computed directly, + so both are accurate near 0. + # BayesianQDM 0.1.0 ## Resubmission diff --git a/R/BayesianQDM-package.R b/R/BayesianQDM-package.R new file mode 100644 index 0000000..d2fd7d0 --- /dev/null +++ b/R/BayesianQDM-package.R @@ -0,0 +1,16 @@ +#' BayesianQDM: Bayesian Quantitative Decision-Making for Clinical Trials +#' +#' Tools for Go/NoGo/Gray decision-making in proof-of-concept clinical trials +#' under a Bayesian framework. A trial is described by small specification +#' objects (priors, data, external data with power priors, hypothetical +#' controls and decision criteria), and the decision rule is evaluated for +#' observed data or for its operating characteristics. +#' \code{vignette("overview", package = "BayesianQDM")} introduces the +#' package, and \code{vignette("migration", package = "BayesianQDM")} shows +#' how to translate code written for version 0.1.0. +#' +#' @keywords internal +#' @useDynLib BayesianQDM, .registration = TRUE +#' @importFrom Rcpp sourceCpp +#' @importFrom ggplot2 .data +"_PACKAGE" diff --git a/R/RcppExports.R b/R/RcppExports.R new file mode 100644 index 0000000..b3b7077 --- /dev/null +++ b/R/RcppExports.R @@ -0,0 +1,47 @@ +# Generated by using Rcpp::compileAttributes() -> do not edit by hand +# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +cpp_pbetadiff_upper <- function(q, a_t, b_t, a_c, b_c) { + .Call(`_BayesianQDM_cpp_pbetadiff_upper`, q, a_t, b_t, a_c, b_c) +} + +cpp_psurvdiff_upper <- function(q, t0, a_t, b_t, a_c, b_c) { + .Call(`_BayesianQDM_cpp_psurvdiff_upper`, q, t0, a_t, b_t, a_c, b_c) +} + +cpp_ptdiff_mc_upper <- function(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC) { + .Call(`_BayesianQDM_cpp_ptdiff_mc_upper`, q, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC) +} + +cpp_ptdiff_mc_regions <- function(q_go, q_nogo, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC) { + .Call(`_BayesianQDM_cpp_ptdiff_mc_regions`, q_go, q_nogo, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC) +} + +cpp_ptdiff_ni_upper <- function(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c) { + .Call(`_BayesianQDM_cpp_ptdiff_ni_upper`, q, mu_t, scale_t, df_t, mu_c, scale_c, df_c) +} + +cpp_post_regions_binary2 <- function(alpha_t, alpha_c, pair_t, pair_c, tv, mav, masks, nMC, value_c) { + .Call(`_BayesianQDM_cpp_post_regions_binary2`, alpha_t, alpha_c, pair_t, pair_c, tv, mav, masks, nMC, value_c) +} + +cpp_pred_regions_binary2 <- function(alpha_t, alpha_c, pair_t, pair_c, m_t, m_c, q, masks, value_c) { + .Call(`_BayesianQDM_cpp_pred_regions_binary2`, alpha_t, alpha_c, pair_t, pair_c, m_t, m_c, q, masks, value_c) +} + +cpp_regions_continuous2_mm <- function(loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks) { + .Call(`_BayesianQDM_cpp_regions_continuous2_mm`, loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks) +} + +cpp_regions_continuous2_mc <- function(loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks, nMC) { + .Call(`_BayesianQDM_cpp_regions_continuous2_mc`, loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks, nMC) +} + +cpp_tte_oc_data <- function(nsim, n_t, n_c, hazard_t, hazard_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events) { + .Call(`_BayesianQDM_cpp_tte_oc_data`, nsim, n_t, n_c, hazard_t, hazard_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events) +} + +cpp_pred_tte <- function(shape_t, rate_t, shape_c, rate_c, fixed_c, prior_t, prior_c, m_t, m_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events, t0, q, nMC) { + .Call(`_BayesianQDM_cpp_pred_tte`, shape_t, rate_t, shape_c, rate_c, fixed_c, prior_t, prior_c, m_t, m_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events, t0, q, nMC) +} + diff --git a/R/allmultinom.R b/R/allmultinom.R deleted file mode 100644 index 91a7f3b..0000000 --- a/R/allmultinom.R +++ /dev/null @@ -1,97 +0,0 @@ -#' Enumerate All Multinomial Count Vectors for a Bivariate Binary Outcome -#' -#' Generates the complete set of non-negative integer vectors -#' \eqn{(x_{00}, x_{01}, x_{10}, x_{11})} satisfying -#' \eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j}, where \eqn{n_j} is the -#' sample size of group \eqn{j \in \{t, c\}}. Each row of the returned matrix -#' corresponds to one possible realisation of the aggregated bivariate binary -#' counts. This enumeration is a prerequisite for exact operating -#' characteristic assessment in \code{\link{pbayesdecisionprob2bin}}. -#' -#' @param n A single non-negative integer giving the sample size of the group -#' (\eqn{n_j}). -#' -#' @return An integer matrix with \eqn{\binom{n_j + 3}{3}} rows and 4 columns -#' named \code{x00}, \code{x01}, \code{x10}, \code{x11}. -#' Each row is a distinct non-negative integer solution to -#' \eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j}. -#' Rows are ordered by \code{x00} (ascending), then \code{x10} -#' (ascending), then \code{x01} (ascending). -#' -#' @details -#' The number of non-negative integer solutions to -#' \eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j} is the stars-and-bars count -#' \deqn{\binom{n_j + 3}{3} = \frac{(n_j + 1)(n_j + 2)(n_j + 3)}{6}.} -#' For example, \eqn{n_j = 10} yields 286 rows and \eqn{n_j = 20} yields -#' 1771 rows. The matrix is pre-allocated to avoid repeated memory -#' reallocation, making the function efficient for the sample sizes typical -#' in rare-disease proof-of-concept studies. -#' -#' This function is an internal computational building block used by -#' \code{\link{pbayesdecisionprob2bin}} to enumerate the sample space over -#' which multinomial probabilities and decision indicators are summed when -#' computing exact operating characteristics. -#' -#' @examples -#' # Example 1: n = 2 (smallest non-trivial case) -#' allmultinom(2) -#' -#' # Example 2: n = 10 (typical rare-disease PoC group size) -#' mat <- allmultinom(10) -#' nrow(mat) # Should be choose(13, 3) = 286 -#' all(rowSums(mat) == 10) # Every row must sum to n -#' -#' # Example 3: n = 0 (edge case - only the all-zero row) -#' allmultinom(0) -#' -#' # Example 4: Verify column names -#' colnames(allmultinom(5)) -#' -#' # Example 5: Row counts match the stars-and-bars formula -#' n <- 15L -#' mat <- allmultinom(n) -#' nrow(mat) == choose(n + 3L, 3L) # Should be TRUE -#' -#' @export -allmultinom <- function(n) { - - # --- Input validation --- - if (!is.numeric(n) || length(n) != 1L || is.na(n) || - n != floor(n) || n < 0L) { - stop("'n' must be a single non-negative integer") - } - - n <- as.integer(n) - - # --- Pre-allocate output matrix --- - # Number of rows = C(n+3, 3) = (n+1)(n+2)(n+3) / 6 - n_rows <- as.integer((n + 1L) * (n + 2L) * (n + 3L) / 6L) - out <- matrix(0L, nrow = n_rows, ncol = 4L) - colnames(out) <- c("x00", "x01", "x10", "x11") - - # --- Enumerate all solutions via nested loops --- - # Outer loop: x00 from 0 to n - # Middle loop: x10 from 0 to (n - x00) - # Inner loop: x01 from 0 to (n - x00 - x10) - # x11 is the remainder: n - x00 - x10 - x01 - k <- 0L - for (x00 in 0L:n) { - rem1 <- n - x00 - for (x10 in 0L:rem1) { - rem2 <- rem1 - x10 - - # Fill a block of (rem2 + 1) rows at once using vectorised assignment - m <- rem2 + 1L - idx <- (k + 1L):(k + m) - - out[idx, 1L] <- x00 # x00 constant within block - out[idx, 2L] <- 0L:rem2 # x01 varies from 0 to rem2 - out[idx, 3L] <- x10 # x10 constant within block - out[idx, 4L] <- rem2 - 0L:rem2 # x11 = rem2 - x01 - - k <- k + m - } - } - - return(out) -} diff --git a/R/borrow.R b/R/borrow.R new file mode 100644 index 0000000..807bd95 --- /dev/null +++ b/R/borrow.R @@ -0,0 +1,28 @@ +#' External data borrowed through a power prior +#' +#' Specifies external (historical) data for one group together with the +#' power prior weight \eqn{a_0}. The likelihood of the external data is raised +#' to the power \eqn{a_0}, so that \eqn{a_0 = 0} ignores the external data and +#' \eqn{a_0 = 1} pools it with the current data. For the conjugate models used +#' in this package the resulting posterior distribution has a closed form, so +#' no Markov chain Monte Carlo sampling is needed. +#' +#' @param data External data created by \code{\link{data_binary}}, +#' \code{\link{data_continuous}}, \code{\link{data_binary2}}, +#' \code{\link{data_continuous2}} or \code{\link{data_tte}}. +#' @param a0 Power prior weight, a number from 0 to 1. +#' +#' @return An object of class \code{"qdm_borrow"} with elements \code{data} and +#' \code{a0}. +#' +#' @examples +#' borrow(data_binary(n = 20, y = 8), a0 = 0.5) +#' @export +borrow <- function(data, a0) { + if (!inherits(data, "qdm_data")) { + stop("'data' must be created by a data_*() function, such as data_binary().", + call. = FALSE) + } + check_numeric(a0, "a0", lower = 0, upper = 1) + structure(list(data = data, a0 = a0), class = "qdm_borrow") +} diff --git a/R/boundary_binary.R b/R/boundary_binary.R new file mode 100644 index 0000000..71b3e2a --- /dev/null +++ b/R/boundary_binary.R @@ -0,0 +1,46 @@ +#' Decision boundary data for one binary endpoint +#' +#' @param design An object of class \code{"qdm_design_binary"}. +#' @param n_t Numbers of subjects in the treatment group (a single number +#' with a concurrent control group). +#' +#' @return A list with elements \code{grid} (data frame), \code{p_go}, +#' \code{p_nogo} and \code{axes} (see \code{qdm_boundary()}). +#' @noRd +boundary_binary <- function(design, n_t) { + check_numeric(n_t, "n_t", len = NULL, lower = 1, integer = TRUE) + n_t <- sort(unique(as.integer(round(n_t)))) + if (design$control == "concurrent") { + if (length(n_t) != 1L) { + stop(paste("'n_t' must be a single number for a design with a", + "concurrent control group."), call. = FALSE) + } + n_c <- design$n_c + grid <- expand.grid(y_t = 0:n_t, y_c = 0:n_c) + grid <- data.frame(n_t = n_t, y_t = grid$y_t, n_c = n_c, y_c = grid$y_c) + post_c <- posterior_binary(design$prior_c, n_c, grid$y_c, + external = design$external_c) + axes <- list(x = "y_c", y = "y_t", + xlab = sprintf("Responders in the control group (n = %d)", + n_c), + ylab = sprintf("Responders in the treatment group (n = %d)", + n_t), + caption = NULL) + } else { + grid <- data.frame(n_t = rep(n_t, n_t + 1L), + y_t = unlist(lapply(n_t, function(n) 0:n))) + post_c <- if (design$control == "fixed") { + NULL + } else { + posterior_binary(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + } + axes <- list(x = "n_t", y = "y_t", xlab = "Treatment group size", + ylab = "Responders in the treatment group", caption = NULL) + } + post_t <- posterior_binary(design$prior_t, grid$n_t, grid$y_t, + external = design$external_t) + p <- region_prob_binary(design$criterion, post_t$a, post_t$b, post_c$a, + post_c$b, fixed = design$fixed_c) + list(grid = grid, p_go = p$go, p_nogo = p$nogo, axes = axes) +} diff --git a/R/boundary_continuous.R b/R/boundary_continuous.R new file mode 100644 index 0000000..fc88c4b --- /dev/null +++ b/R/boundary_continuous.R @@ -0,0 +1,72 @@ +#' Decision boundary data for one continuous endpoint +#' +#' @param design An object of class \code{"qdm_design_continuous"}. +#' @param n_t,mean_t,sd_t Values of the grid (at most one of \code{n_t} and +#' \code{sd_t} with more than one value). +#' @param data_c Observed control data (concurrent control only). +#' +#' @return A list with elements \code{grid} (data frame), \code{p_go}, +#' \code{p_nogo} and \code{axes} (see \code{qdm_boundary()}). +#' @noRd +boundary_continuous <- function(design, n_t, mean_t, sd_t, data_c) { + if (is.null(mean_t) || is.null(sd_t)) { + stop("'mean_t' and 'sd_t' must be given for a continuous endpoint.", + call. = FALSE) + } + check_numeric(n_t, "n_t", len = NULL, lower = 2, integer = TRUE) + check_numeric(mean_t, "mean_t", len = NULL) + check_numeric(sd_t, "sd_t", len = NULL, lower = 0, lower_open = TRUE) + n_t <- sort(unique(as.integer(round(n_t)))) + mean_t <- sort(unique(mean_t)) + sd_t <- sort(unique(sd_t)) + if (length(n_t) > 1L && length(sd_t) > 1L) { + stop("Only one of 'n_t' and 'sd_t' may have more than one value.", + call. = FALSE) + } + concurrent <- design$control == "concurrent" + if (concurrent && !inherits(data_c, "qdm_data_continuous")) { + stop("'data_c' must be created by data_continuous().", call. = FALSE) + } + grid <- expand.grid(mean_t = mean_t, sd_t = sd_t, n_t = n_t, + KEEP.OUT.ATTRS = FALSE) + grid <- grid[, c("n_t", "mean_t", "sd_t")] + p_go <- numeric(nrow(grid)) + p_nogo <- numeric(nrow(grid)) + for (n in n_t) { + rows <- which(grid$n_t == n) + post_t <- posterior_continuous(design$prior_t, n, grid$mean_t[rows], + grid$sd_t[rows], + external = design$external_t) + post_c <- if (concurrent) { + control_posterior_continuous(design, post_t, data_c$n, data_c$mean, + data_c$sd) + } else { + control_posterior_continuous(design, post_t) + } + if (!is.null(post_c)) { + check_df_mm(post_t$nu[1L], post_c$nu[1L], design$method) + } + p <- region_prob_continuous(design$criterion, post_t, post_c, + design$method, design$nMC, + fixed = design$fixed_c) + p_go[rows] <- p$go + p_nogo[rows] <- p$nogo + } + x <- if (length(sd_t) > 1L) "sd_t" else "n_t" + xlab <- if (x == "sd_t") { + "Observed treatment standard deviation" + } else { + "Treatment group size" + } + if (concurrent) { + grid$diff <- grid$mean_t - data_c$mean + axes <- list(x = x, y = "diff", xlab = xlab, + ylab = "Observed difference in means", + caption = sprintf("Control data: %s", + format(data_c, digits = 4L))) + } else { + axes <- list(x = x, y = "mean_t", xlab = xlab, + ylab = "Observed treatment mean", caption = NULL) + } + list(grid = grid, p_go = p_go, p_nogo = p_nogo, axes = axes) +} diff --git a/R/boundary_continuous2.R b/R/boundary_continuous2.R new file mode 100644 index 0000000..5d78b96 --- /dev/null +++ b/R/boundary_continuous2.R @@ -0,0 +1,68 @@ +#' Decision boundary data for two continuous endpoints +#' +#' @param design An object of class \code{"qdm_design_continuous2"}. +#' @param n_t Number of subjects in the treatment group (a single number). +#' @param mean_t List of two numeric vectors of observed treatment means. +#' @param cov_t Observed treatment covariance matrix. +#' @param data_c Observed control data (concurrent control only). +#' +#' @return A list with elements \code{grid} (data frame), \code{p_go}, +#' \code{p_nogo} (vectors, or lists of two for the marginal rules) and +#' \code{axes} (see \code{qdm_boundary()}). +#' @noRd +boundary_continuous2 <- function(design, n_t, mean_t, cov_t, data_c) { + if (!is.list(mean_t) || length(mean_t) != 2L || is.null(cov_t)) { + stop(paste("For two continuous endpoints, 'mean_t' must be a list of two", + "numeric vectors and 'cov_t' must be given."), call. = FALSE) + } + check_numeric(n_t, "n_t", lower = 3, integer = TRUE) + check_numeric(mean_t[[1L]], "mean_t[[1]]", len = NULL) + check_numeric(mean_t[[2L]], "mean_t[[2]]", len = NULL) + check_pd_matrix(cov_t, "cov_t") + concurrent <- design$control == "concurrent" + if (concurrent && !inherits(data_c, "qdm_data_continuous2")) { + stop("'data_c' must be created by data_continuous2().", call. = FALSE) + } + grid <- expand.grid(mean_t1 = sort(unique(mean_t[[1L]])), + mean_t2 = sort(unique(mean_t[[2L]]))) + n_t <- as.integer(round(n_t)) + post_t <- posterior_continuous2(design$prior_t, n_t, + cbind(grid$mean_t1, grid$mean_t2), cov_t, + external = design$external_t) + post_c <- if (concurrent) { + control_posterior_continuous2(design, post_t, data_c$n, data_c$mean, + data_c$cov) + } else { + control_posterior_continuous2(design, post_t) + } + crit <- design$criterion + dist_c <- NULL + if (!is.null(post_c)) { + check_df_mm(post_t$nu[1L] - 1, post_c$nu[1L] - 1, design$method, + "method = \"MC\"") + dist_c <- mean_dist_continuous2(post_c, crit$type, crit$m_c) + } + dist_t <- mean_dist_continuous2(post_t, crit$type, crit$m_t) + sets <- region_sets(crit) + p <- region_prob_continuous2(crit, dist_t, dist_c, c(sets$go, sets$nogo), + design$method, design$nMC, + fixed = design$fixed_c) + s <- split_sets(p, length(sets$go)) + grid <- data.frame(n_t = n_t, mean_t1 = grid$mean_t1, + mean_t2 = grid$mean_t2) + if (concurrent) { + grid$diff1 <- grid$mean_t1 - data_c$mean[1L] + grid$diff2 <- grid$mean_t2 - data_c$mean[2L] + axes <- list(x = "diff1", y = "diff2", + xlab = "Observed difference in means, endpoint 1", + ylab = "Observed difference in means, endpoint 2", + caption = sprintf("Control data: %s", + format(data_c, digits = 4L))) + } else { + axes <- list(x = "mean_t1", y = "mean_t2", + xlab = "Observed treatment mean, endpoint 1", + ylab = "Observed treatment mean, endpoint 2", + caption = NULL) + } + list(grid = grid, p_go = s$go, p_nogo = s$nogo, axes = axes) +} diff --git a/R/boundary_tte.R b/R/boundary_tte.R new file mode 100644 index 0000000..5332f4f --- /dev/null +++ b/R/boundary_tte.R @@ -0,0 +1,51 @@ +#' Decision boundary data for one time-to-event endpoint +#' +#' @param design An object of class \code{"qdm_design_tte"}. +#' @param n_t Number of subjects in the treatment group, used for the default +#' numbers of events. +#' @param events_t Numbers of events of the treatment group (by default +#' \code{0:n_t}). +#' @param exposure_t Total observed times of the treatment group. +#' @param data_c Observed control data (concurrent control only). +#' +#' @return A list with elements \code{grid} (data frame), \code{p_go}, +#' \code{p_nogo} and \code{axes} (see \code{qdm_boundary()}). +#' @noRd +boundary_tte <- function(design, n_t, events_t, exposure_t, data_c) { + if (is.null(exposure_t)) { + stop("'exposure_t' must be given for a time-to-event endpoint.", + call. = FALSE) + } + check_numeric(n_t, "n_t", lower = 1, integer = TRUE) + if (is.null(events_t)) { + events_t <- 0:round(n_t) + } + check_numeric(events_t, "events_t", len = NULL, lower = 0, integer = TRUE) + check_numeric(exposure_t, "exposure_t", len = NULL, lower = 0, + lower_open = TRUE) + concurrent <- design$control == "concurrent" + if (concurrent && !inherits(data_c, "qdm_data_tte")) { + stop("'data_c' must be created by data_tte().", call. = FALSE) + } + grid <- expand.grid(events_t = sort(unique(round(events_t))), + exposure_t = sort(unique(exposure_t)), + KEEP.OUT.ATTRS = FALSE) + post_t <- posterior_tte(design$prior_t, grid$events_t, grid$exposure_t, + external = design$external_t) + post_c <- switch( + design$control, + concurrent = posterior_tte(design$prior_c, data_c$events, + data_c$exposure, external = design$external_c), + fixed = NULL, + posterior_tte(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + ) + p <- region_prob_tte(design, post_t, post_c) + axes <- list(x = "exposure_t", y = "events_t", + xlab = "Total observed time of the treatment group", + ylab = "Events in the treatment group", + caption = if (concurrent) { + sprintf("Control data: %s", format(data_c, digits = 4L)) + }) + list(grid = grid, p_go = p$go, p_nogo = p$nogo, axes = axes) +} diff --git a/R/cellprob_binary2.R b/R/cellprob_binary2.R new file mode 100644 index 0000000..8b66908 --- /dev/null +++ b/R/cellprob_binary2.R @@ -0,0 +1,56 @@ +#' Joint cell probabilities of two binary endpoints +#' +#' Converts the marginal response rates of two binary endpoints and their +#' correlation into the probabilities of the four joint response patterns. +#' +#' For two Bernoulli variables with response rates \eqn{\pi_1} and +#' \eqn{\pi_2}, the Pearson correlation \eqn{\rho} determines +#' \deqn{p_{11} = \pi_1 \pi_2 + \rho \sqrt{\pi_1 (1 - \pi_1) \pi_2 (1 - \pi_2)},} +#' and \eqn{p_{10} = \pi_1 - p_{11}}, \eqn{p_{01} = \pi_2 - p_{11}}, +#' \eqn{p_{00} = 1 - p_{10} - p_{01} - p_{11}}. All four probabilities are +#' non-negative only if +#' \eqn{\max(0, \pi_1 + \pi_2 - 1) \le p_{11} \le \min(\pi_1, \pi_2)}, which +#' bounds the feasible range of \eqn{\rho}. An error is raised if \code{rho} +#' is outside this range by more than \code{tol}. +#' +#' @param pi1 Response rate of endpoint 1, strictly between 0 and 1. +#' @param pi2 Response rate of endpoint 2, strictly between 0 and 1. +#' @param rho Correlation between the two endpoints. +#' @param tol Tolerance for the feasibility check. +#' +#' @return A named numeric vector of the probabilities of the cells +#' \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"} (first digit: +#' endpoint 1; second digit: endpoint 2), summing to 1. +#' +#' @family distributions +#' @examples +#' cellprob_binary2(pi1 = 0.3, pi2 = 0.4, rho = 0.3) +#' @export +cellprob_binary2 <- function(pi1, pi2, rho, tol = 1e-10) { + check_numeric(pi1, "pi1", lower = 0, upper = 1, lower_open = TRUE, + upper_open = TRUE) + check_numeric(pi2, "pi2", lower = 0, upper = 1, lower_open = TRUE, + upper_open = TRUE) + check_numeric(rho, "rho") + check_numeric(tol, "tol", lower = 0) + sd_prod <- sqrt(pi1 * (1 - pi1) * pi2 * (1 - pi2)) + p11_min <- max(0, pi1 + pi2 - 1) + p11_max <- min(pi1, pi2) + rho_min <- (p11_min - pi1 * pi2) / sd_prod + rho_max <- (p11_max - pi1 * pi2) / sd_prod + if (rho < rho_min - tol || rho > rho_max + tol) { + stop(sprintf(paste("'rho' = %s is infeasible for pi1 = %s and pi2 = %s;", + "the feasible range is from %s to %s."), + format(rho, digits = 6), format(pi1, digits = 6), + format(pi2, digits = 6), format(rho_min, digits = 6), + format(rho_max, digits = 6)), + call. = FALSE) + } + # Clamp to the feasible range to absorb rounding errors + p11 <- min(max(pi1 * pi2 + rho * sd_prod, p11_min), p11_max) + p10 <- pi1 - p11 + p01 <- pi2 - p11 + p00 <- 1 - p10 - p01 - p11 + p <- pmax(c("00" = p00, "01" = p01, "10" = p10, "11" = p11), 0) + p / sum(p) +} diff --git a/R/cellprob_scenarios.R b/R/cellprob_scenarios.R new file mode 100644 index 0000000..1bc3ec6 --- /dev/null +++ b/R/cellprob_scenarios.R @@ -0,0 +1,21 @@ +#' Cell probabilities of scenarios for two binary endpoints +#' +#' Applies \code{\link{cellprob_binary2}} to each scenario. A scenario whose +#' correlation is outside the feasible range for its response rates is not +#' evaluable and gives missing probabilities. +#' +#' @param pi1,pi2,rho Numeric vectors of response rates and correlations +#' (checked), one element per scenario. +#' +#' @return A numeric matrix with one row per scenario and the columns +#' \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"}; rows of +#' infeasible scenarios are \code{NA}. +#' @noRd +cellprob_scenarios <- function(pi1, pi2, rho) { + out <- t(vapply(seq_along(pi1), function(s) { + tryCatch(cellprob_binary2(pi1[s], pi2[s], rho[s]), + error = function(e) rep(NA_real_, 4L)) + }, numeric(4))) + dimnames(out) <- list(NULL, c("00", "01", "10", "11")) + out +} diff --git a/R/check_color.R b/R/check_color.R new file mode 100644 index 0000000..ab802e3 --- /dev/null +++ b/R/check_color.R @@ -0,0 +1,21 @@ +#' Validate a color argument +#' +#' Checks that an argument is a single color that R recognizes: a color name +#' (see \code{grDevices::colors()}) or a hexadecimal code such as +#' \code{"#658D1B"}. +#' +#' @param x Object to check. +#' @param name Name of the argument, used in error messages. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_color <- function(x, name) { + ok <- is.character(x) && length(x) == 1L && !is.na(x) && + !inherits(tryCatch(grDevices::col2rgb(x), error = function(e) e), + "error") + if (!ok) { + stop(sprintf(paste("'%s' must be a single color name or hexadecimal", + "color code."), name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_conduct.R b/R/check_conduct.R new file mode 100644 index 0000000..6635756 --- /dev/null +++ b/R/check_conduct.R @@ -0,0 +1,26 @@ +#' Check the conduct of a study +#' +#' @param x Object to check: an object of class \code{"qdm_conduct"} (or +#' \code{NULL} if \code{allow_null} is \code{TRUE}). +#' @param name Name of the argument, used in error messages. +#' @param n Number of subjects of the study; an analysis at an event must +#' not need more events than subjects. +#' @param allow_null Logical; whether \code{NULL} is accepted. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_conduct <- function(x, name, n, allow_null = FALSE) { + if (is.null(x) && allow_null) { + return(invisible(x)) + } + if (!inherits(x, "qdm_conduct")) { + stop(sprintf("'%s' must be created by conduct_tte().", name), + call. = FALSE) + } + if (!is.null(x$cut_events) && x$cut_events > n) { + stop(sprintf(paste("The analysis of '%s' is at event %d, but the study", + "has only %d subjects."), name, x$cut_events, n), + call. = FALSE) + } + invisible(x) +} diff --git a/R/check_design.R b/R/check_design.R new file mode 100644 index 0000000..fb035f3 --- /dev/null +++ b/R/check_design.R @@ -0,0 +1,13 @@ +#' Check that an argument is a design +#' +#' @param design Object to check. +#' +#' @return \code{design}, invisibly. +#' @noRd +check_design <- function(design) { + if (!inherits(design, "qdm_design")) { + stop(paste("'design' must be created by a design_*() function, such as", + "design_binary()."), call. = FALSE) + } + invisible(design) +} diff --git a/R/check_df_mm.R b/R/check_df_mm.R new file mode 100644 index 0000000..d5f392c --- /dev/null +++ b/R/check_df_mm.R @@ -0,0 +1,23 @@ +#' Check the degrees of freedom required by the moment-matching method +#' +#' The moment-matching approximations of \code{\link{ptdiff}} and of two +#' continuous endpoints require the fourth moments of both t distributions to +#' exist. +#' +#' @param df_t,df_c Degrees of freedom of the distributions of the treatment +#' and control means. +#' @param method One of \code{"NI"}, \code{"MM"} or \code{"MC"}. +#' @param alternative The methods suggested in the error message. +#' +#' @return \code{NULL}, invisibly. +#' @noRd +check_df_mm <- function(df_t, df_c, method, + alternative = "method = \"NI\" or \"MC\"") { + if (method == "MM" && (df_t <= 4 || df_c <= 4)) { + stop(sprintf(paste("method = \"MM\" requires the distributions of both", + "group means to have more than 4 degrees of freedom", + "(here %s and %s). Use %s."), + format(df_t), format(df_c), alternative), call. = FALSE) + } + invisible(NULL) +} diff --git a/R/check_external_binary.R b/R/check_external_binary.R new file mode 100644 index 0000000..454cc1d --- /dev/null +++ b/R/check_external_binary.R @@ -0,0 +1,16 @@ +#' Check external data for a binary endpoint +#' +#' @param x Object to check: \code{NULL} or an object of class +#' \code{"qdm_borrow"} with binary data. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_external_binary <- function(x, name) { + if (!is.null(x) && (!inherits(x, "qdm_borrow") || + !inherits(x$data, "qdm_data_binary"))) { + stop(sprintf("'%s' must be NULL or created by borrow() with data_binary().", + name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_external_binary2.R b/R/check_external_binary2.R new file mode 100644 index 0000000..2ca5a8f --- /dev/null +++ b/R/check_external_binary2.R @@ -0,0 +1,16 @@ +#' Check external data for two binary endpoints +#' +#' @param x Object to check: \code{NULL} or an object of class +#' \code{"qdm_borrow"} with data for two binary endpoints. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_external_binary2 <- function(x, name) { + if (!is.null(x) && (!inherits(x, "qdm_borrow") || + !inherits(x$data, "qdm_data_binary2"))) { + stop(sprintf(paste("'%s' must be NULL or created by borrow() with", + "data_binary2()."), name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_external_continuous.R b/R/check_external_continuous.R new file mode 100644 index 0000000..0d7d291 --- /dev/null +++ b/R/check_external_continuous.R @@ -0,0 +1,16 @@ +#' Check external data for a continuous endpoint +#' +#' @param x Object to check: \code{NULL} or an object of class +#' \code{"qdm_borrow"} with continuous data. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_external_continuous <- function(x, name) { + if (!is.null(x) && (!inherits(x, "qdm_borrow") || + !inherits(x$data, "qdm_data_continuous"))) { + stop(sprintf(paste("'%s' must be NULL or created by borrow() with", + "data_continuous()."), name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_external_continuous2.R b/R/check_external_continuous2.R new file mode 100644 index 0000000..46a0403 --- /dev/null +++ b/R/check_external_continuous2.R @@ -0,0 +1,16 @@ +#' Check external data for two continuous endpoints +#' +#' @param x Object to check: \code{NULL} or an object of class +#' \code{"qdm_borrow"} with data of two continuous endpoints. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_external_continuous2 <- function(x, name) { + if (!is.null(x) && (!inherits(x, "qdm_borrow") || + !inherits(x$data, "qdm_data_continuous2"))) { + stop(sprintf(paste("'%s' must be NULL or created by borrow() with", + "data_continuous2()."), name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_external_tte.R b/R/check_external_tte.R new file mode 100644 index 0000000..62c2702 --- /dev/null +++ b/R/check_external_tte.R @@ -0,0 +1,16 @@ +#' Check external data for a time-to-event endpoint +#' +#' @param x Object to check: \code{NULL} or an object of class +#' \code{"qdm_borrow"} with time-to-event data. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_external_tte <- function(x, name) { + if (!is.null(x) && (!inherits(x, "qdm_borrow") || + !inherits(x$data, "qdm_data_tte"))) { + stop(sprintf("'%s' must be NULL or created by borrow() with data_tte().", + name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_fixed_c.R b/R/check_fixed_c.R new file mode 100644 index 0000000..0056239 --- /dev/null +++ b/R/check_fixed_c.R @@ -0,0 +1,22 @@ +#' Check a fixed control value +#' +#' @param x Object to check: \code{NULL} or the fixed value(s) of the +#' parameter of the control group. +#' @param n_endpoints Number of endpoints (the required length of \code{x}). +#' @param probability Logical; if \code{TRUE}, the values are probabilities +#' (response rates or milestone survival probabilities) and must be from 0 +#' to 1. +#' +#' @return \code{x} as a numeric vector, or \code{NULL}. +#' @noRd +check_fixed_c <- function(x, n_endpoints, probability) { + if (is.null(x)) { + return(NULL) + } + if (probability) { + check_numeric(x, "fixed_c", len = n_endpoints, lower = 0, upper = 1) + } else { + check_numeric(x, "fixed_c", len = n_endpoints) + } + as.numeric(x) +} diff --git a/R/check_flag.R b/R/check_flag.R new file mode 100644 index 0000000..4552358 --- /dev/null +++ b/R/check_flag.R @@ -0,0 +1,15 @@ +#' Validate a logical flag +#' +#' Checks that an argument is a single non-missing logical value. +#' +#' @param x Object to check. +#' @param name Name of the argument, used in error messages. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_flag <- function(x, name) { + if (!is.logical(x) || length(x) != 1L || is.na(x)) { + stop(sprintf("'%s' must be TRUE or FALSE.", name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_numeric.R b/R/check_numeric.R new file mode 100644 index 0000000..036706b --- /dev/null +++ b/R/check_numeric.R @@ -0,0 +1,53 @@ +#' Validate a numeric argument +#' +#' Checks the type, length, finiteness, integer property and range of a +#' numeric argument, and stops with an informative message if a check fails. +#' +#' @param x Object to check. +#' @param name Name of the argument, used in error messages. +#' @param len Required length, or \code{NULL} to accept any positive length. +#' @param lower,upper Lower and upper bounds for all elements. +#' @param lower_open,upper_open Logical; if \code{TRUE}, the bound itself is +#' not allowed. +#' @param integer Logical; if \code{TRUE}, all elements must be whole numbers. +#' @param allow_inf Logical; if \code{TRUE}, infinite values are accepted. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_numeric <- function(x, name, len = 1L, lower = -Inf, upper = Inf, + lower_open = FALSE, upper_open = FALSE, + integer = FALSE, allow_inf = FALSE) { + if (!is.numeric(x) || length(x) == 0L) { + stop(sprintf("'%s' must be numeric.", name), call. = FALSE) + } + if (!is.null(len) && length(x) != len) { + stop(sprintf("'%s' must have length %d.", name, len), call. = FALSE) + } + if (anyNA(x)) { + stop(sprintf("'%s' must not contain missing values.", name), + call. = FALSE) + } + if (!allow_inf && any(is.infinite(x))) { + stop(sprintf("'%s' must be finite.", name), call. = FALSE) + } + if (integer && any(is.finite(x) & abs(x - round(x)) > 1e-8)) { + stop(sprintf("'%s' must contain whole numbers only.", name), + call. = FALSE) + } + bad_lower <- if (lower_open) any(x <= lower) else any(x < lower) + bad_upper <- if (upper_open) any(x >= upper) else any(x > upper) + if (bad_lower || bad_upper) { + parts <- character(0) + if (is.finite(lower)) { + parts <- c(parts, paste(if (lower_open) "greater than" else "at least", + format(lower))) + } + if (is.finite(upper)) { + parts <- c(parts, paste(if (upper_open) "less than" else "at most", + format(upper))) + } + stop(sprintf("'%s' must be %s.", name, paste(parts, collapse = " and ")), + call. = FALSE) + } + invisible(x) +} diff --git a/R/check_pd_matrix.R b/R/check_pd_matrix.R new file mode 100644 index 0000000..ec41dc8 --- /dev/null +++ b/R/check_pd_matrix.R @@ -0,0 +1,29 @@ +#' Validate a symmetric positive definite matrix +#' +#' Checks that an argument is a finite numeric square matrix of the given +#' dimension that is symmetric and positive definite. +#' +#' @param x Object to check. +#' @param name Name of the argument, used in error messages. +#' @param dim Required number of rows and columns. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_pd_matrix <- function(x, name, dim = 2L) { + if (!is.matrix(x) || !is.numeric(x) || nrow(x) != dim || ncol(x) != dim) { + stop(sprintf("'%s' must be a numeric %d x %d matrix.", name, dim, dim), + call. = FALSE) + } + if (anyNA(x) || any(!is.finite(x))) { + stop(sprintf("'%s' must contain finite values only.", name), + call. = FALSE) + } + if (max(abs(x - t(x))) > 1e-8 * max(1, max(abs(x)))) { + stop(sprintf("'%s' must be symmetric.", name), call. = FALSE) + } + ev <- eigen((x + t(x)) / 2, symmetric = TRUE, only.values = TRUE)$values + if (min(ev) <= 0) { + stop(sprintf("'%s' must be positive definite.", name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_prior_beta.R b/R/check_prior_beta.R new file mode 100644 index 0000000..075f491 --- /dev/null +++ b/R/check_prior_beta.R @@ -0,0 +1,14 @@ +#' Check that an argument is a Beta prior +#' +#' @param x Object to check. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_prior_beta <- function(x, name) { + if (!inherits(x, "qdm_prior_beta")) { + stop(sprintf("'%s' must be created by prior_beta().", name), + call. = FALSE) + } + invisible(x) +} diff --git a/R/check_prior_continuous.R b/R/check_prior_continuous.R new file mode 100644 index 0000000..63ecd51 --- /dev/null +++ b/R/check_prior_continuous.R @@ -0,0 +1,14 @@ +#' Check that an argument is a prior for a continuous endpoint +#' +#' @param x Object to check. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_prior_continuous <- function(x, name) { + if (!inherits(x, c("qdm_prior_nix", "qdm_prior_vague"))) { + stop(sprintf("'%s' must be created by prior_nix() or prior_vague().", + name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_prior_continuous2.R b/R/check_prior_continuous2.R new file mode 100644 index 0000000..067f76c --- /dev/null +++ b/R/check_prior_continuous2.R @@ -0,0 +1,14 @@ +#' Check that an argument is a prior for two continuous endpoints +#' +#' @param x Object to check. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_prior_continuous2 <- function(x, name) { + if (!inherits(x, c("qdm_prior_niw", "qdm_prior_vague"))) { + stop(sprintf("'%s' must be created by prior_niw() or prior_vague().", + name), call. = FALSE) + } + invisible(x) +} diff --git a/R/check_prior_control.R b/R/check_prior_control.R new file mode 100644 index 0000000..83cabdc --- /dev/null +++ b/R/check_prior_control.R @@ -0,0 +1,32 @@ +#' Check the prior distribution of the control group of a design +#' +#' The prior distribution of the control group is not used for a fixed +#' control and, for continuous endpoints, for a hypothetical control; it must +#' then be \code{NULL}, so that a specification is not silently ignored. +#' Otherwise it is checked by \code{check}. +#' +#' @param prior_c The argument \code{prior_c} of the design. +#' @param control Form of the control group (see \code{control_form()}). +#' @param check Function that checks the prior, called as +#' \code{check(prior_c, "prior_c")}. +#' @param unused Forms of the control group for which the prior is not used. +#' +#' @return \code{prior_c}, invisibly. +#' @noRd +check_prior_control <- function(prior_c, control, check, unused = "fixed") { + if (control %in% unused) { + if (!is.null(prior_c)) { + reason <- if (control == "fixed") { + "whose value is given by 'fixed_c'" + } else { + paste("whose distribution is determined by 'hypothetical_c' and the", + "posterior distribution of the treatment group") + } + stop(sprintf("'prior_c' must be NULL for a %s control, %s.", control, + reason), call. = FALSE) + } + } else { + check(prior_c, "prior_c") + } + invisible(prior_c) +} diff --git a/R/check_prior_dirichlet.R b/R/check_prior_dirichlet.R new file mode 100644 index 0000000..2cdeae9 --- /dev/null +++ b/R/check_prior_dirichlet.R @@ -0,0 +1,14 @@ +#' Check that an argument is a Dirichlet prior +#' +#' @param x Object to check. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_prior_dirichlet <- function(x, name) { + if (!inherits(x, "qdm_prior_dirichlet")) { + stop(sprintf("'%s' must be created by prior_dirichlet().", name), + call. = FALSE) + } + invisible(x) +} diff --git a/R/check_prior_gamma.R b/R/check_prior_gamma.R new file mode 100644 index 0000000..c4c2c19 --- /dev/null +++ b/R/check_prior_gamma.R @@ -0,0 +1,14 @@ +#' Check that an argument is a Gamma prior +#' +#' @param x Object to check. +#' @param name Name of the argument, used in the error message. +#' +#' @return \code{x}, invisibly. +#' @noRd +check_prior_gamma <- function(x, name) { + if (!inherits(x, "qdm_prior_gamma")) { + stop(sprintf("'%s' must be created by prior_gamma().", name), + call. = FALSE) + } + invisible(x) +} diff --git a/R/check_regions.R b/R/check_regions.R new file mode 100644 index 0000000..85c47dd --- /dev/null +++ b/R/check_regions.R @@ -0,0 +1,30 @@ +#' Validate Go and NoGo region sets +#' +#' Checks that the Go and NoGo region sets for two endpoints are non-empty, +#' contain valid region numbers without duplicates, and are disjoint. +#' +#' @param go_regions,nogo_regions Region numbers. +#' @param n_regions Number of regions (9 for posterior probability, 4 for +#' predictive probability). +#' +#' @return A list with sorted integer vectors \code{go} and \code{nogo}. +#' @noRd +check_regions <- function(go_regions, nogo_regions, n_regions) { + check_numeric(go_regions, "go_regions", len = NULL, lower = 1, + upper = n_regions, integer = TRUE) + check_numeric(nogo_regions, "nogo_regions", len = NULL, lower = 1, + upper = n_regions, integer = TRUE) + go <- as.integer(round(go_regions)) + nogo <- as.integer(round(nogo_regions)) + if (anyDuplicated(go) > 0L) { + stop("'go_regions' must not contain duplicated values.", call. = FALSE) + } + if (anyDuplicated(nogo) > 0L) { + stop("'nogo_regions' must not contain duplicated values.", call. = FALSE) + } + if (length(intersect(go, nogo)) > 0L) { + stop("'go_regions' and 'nogo_regions' must not share any region.", + call. = FALSE) + } + list(go = sort(go), nogo = sort(nogo)) +} diff --git a/R/check_rule.R b/R/check_rule.R new file mode 100644 index 0000000..1a5debf --- /dev/null +++ b/R/check_rule.R @@ -0,0 +1,51 @@ +#' Check the thresholds, regions and rule of a decision criterion +#' +#' For one endpoint, the thresholds are single numbers and the regions and +#' the rule are not used. For two endpoints with \code{rule = "joint"}, the +#' thresholds are single numbers and the Go and NoGo regions are unions of +#' the regions of \code{\link{qdm_regions}}. With \code{rule = "and"} or +#' \code{"or"}, the criteria are based on the marginal probabilities of each +#' endpoint; the thresholds may differ between the endpoints, and the regions +#' are not used. +#' +#' @param rule One of \code{"joint"}, \code{"and"} or \code{"or"}. +#' @param n_endpoints Number of endpoints (1 or 2). +#' @param gamma_go,gamma_nogo Thresholds. +#' @param go_regions,nogo_regions Region numbers. +#' @param regions_given Logical; whether the regions were specified by the +#' user. +#' @param n_regions Number of regions (9 or 4). +#' +#' @return A list with elements \code{rule}, \code{gamma_go}, +#' \code{gamma_nogo} (of length 2 for the marginal rules), \code{go} and +#' \code{nogo} (sorted region numbers, or \code{NULL}). +#' @noRd +check_rule <- function(rule, n_endpoints, gamma_go, gamma_nogo, go_regions, + nogo_regions, regions_given, n_regions) { + marginal <- n_endpoints == 2L && rule != "joint" + len <- if (marginal) NULL else 1L + check_numeric(gamma_go, "gamma_go", len = len, lower = 0, upper = 1, + lower_open = TRUE, upper_open = TRUE) + check_numeric(gamma_nogo, "gamma_nogo", len = len, lower = 0, upper = 1, + lower_open = TRUE, upper_open = TRUE) + if (n_endpoints == 1L) { + return(list(rule = "joint", gamma_go = gamma_go, gamma_nogo = gamma_nogo, + go = NULL, nogo = NULL)) + } + if (!marginal) { + regions <- check_regions(go_regions, nogo_regions, n_regions = n_regions) + return(list(rule = "joint", gamma_go = gamma_go, gamma_nogo = gamma_nogo, + go = regions$go, nogo = regions$nogo)) + } + if (regions_given) { + stop("'go_regions' and 'nogo_regions' are used only with rule = \"joint\".", + call. = FALSE) + } + if (length(gamma_go) > 2L || length(gamma_nogo) > 2L) { + stop(sprintf(paste("With rule = \"%s\", 'gamma_go' and 'gamma_nogo' must", + "have length 1 or 2 (one threshold per endpoint)."), + rule), call. = FALSE) + } + list(rule = rule, gamma_go = rep_len(gamma_go, 2L), + gamma_nogo = rep_len(gamma_nogo, 2L), go = NULL, nogo = NULL) +} diff --git a/R/check_scenarios.R b/R/check_scenarios.R new file mode 100644 index 0000000..b29d988 --- /dev/null +++ b/R/check_scenarios.R @@ -0,0 +1,56 @@ +#' Check the scenarios of operating characteristics +#' +#' Checks that the scenarios are a data frame with the columns required by +#' the design, with values in the allowed range. +#' +#' @param design An object of class \code{"qdm_design"}. +#' @param scenarios Object to check. +#' @param name Name of the argument, used in error messages. +#' @param one_row Logical; if \code{TRUE}, exactly one row is required. +#' @param feasible Logical; if \code{TRUE}, scenarios of two binary endpoints +#' whose correlation is infeasible for their response rates are rejected +#' (otherwise they are reported as not evaluable by \code{qdm_oc()}). +#' +#' @return \code{scenarios} as a plain data frame. +#' @noRd +check_scenarios <- function(design, scenarios, name = "scenarios", + one_row = FALSE, feasible = FALSE) { + if (!is.data.frame(scenarios) || nrow(scenarios) == 0L) { + stop(sprintf("'%s' must be a data frame with at least one row.", name), + call. = FALSE) + } + if (one_row && nrow(scenarios) != 1L) { + stop(sprintf("'%s' must have exactly one row.", name), call. = FALSE) + } + scenarios <- as.data.frame(scenarios) + cols <- scenario_columns(design) + if (!all(cols$names %in% names(scenarios))) { + stop(sprintf("'%s' must have the column(s) %s.", name, + paste(cols$names, collapse = ", ")), call. = FALSE) + } + if (any(c("Go", "NoGo", "Gray", "Miss") %in% names(scenarios))) { + stop(sprintf("'%s' must not have columns named Go, NoGo, Gray or Miss.", + name), call. = FALSE) + } + for (k in seq_along(cols$names)) { + col <- cols$names[k] + check_numeric(scenarios[[col]], sprintf("%s$%s", name, col), len = NULL, + lower = cols$lower[k], upper = cols$upper[k], + lower_open = cols$lower_open[k], + upper_open = cols$upper_open[k]) + } + if (feasible && design$endpoint == "binary2") { + groups <- if (design$control == "concurrent") c("t", "c") else "t" + for (g in groups) { + cells <- cellprob_scenarios(scenarios[[paste0("pi_", g, "1")]], + scenarios[[paste0("pi_", g, "2")]], + scenarios[[paste0("rho_", g)]]) + if (anyNA(cells)) { + stop(sprintf(paste("'%s$rho_%s' is outside the feasible range for", + "the response rates (see cellprob_binary2())."), + name, g), call. = FALSE) + } + } + } + scenarios +} diff --git a/R/conduct_args.R b/R/conduct_args.R new file mode 100644 index 0000000..dd06657 --- /dev/null +++ b/R/conduct_args.R @@ -0,0 +1,17 @@ +#' Arguments of the C++ simulation functions for the conduct of a study +#' +#' @param conduct An object of class \code{"qdm_conduct"}. +#' +#' @return A list with elements \code{acc_time}, \code{acc_cum}, +#' \code{drop_start}, \code{drop_hazard}, \code{cut_time} (infinite for an +#' analysis at an event) and \code{cut_events} (0 for an analysis at a +#' time), in the order of the arguments of \code{cpp_tte_oc_data()}. +#' @noRd +conduct_args <- function(conduct) { + list(acc_time = conduct$accrual_time, acc_cum = conduct$accrual_cum, + drop_start = conduct$dropout_time, + drop_hazard = conduct$dropout_hazard, + cut_time = if (is.null(conduct$cut_time)) Inf else conduct$cut_time, + cut_events = if (is.null(conduct$cut_events)) 0L else + conduct$cut_events) +} diff --git a/R/conduct_tte.R b/R/conduct_tte.R new file mode 100644 index 0000000..17f16d5 --- /dev/null +++ b/R/conduct_tte.R @@ -0,0 +1,96 @@ +#' Conduct of a study with a time-to-event endpoint +#' +#' Specifies how subjects are enrolled, how they drop out and when the +#' analysis takes place. The operating characteristics of a design with a +#' time-to-event endpoint (\code{\link{design_tte}}) are computed by +#' simulating studies conducted in this way, and the posterior predictive +#' probabilities by simulating future studies. +#' +#' The subjects of all groups are enrolled at independent times with a +#' piecewise uniform distribution: the enrollment period is divided by +#' \code{accrual_time}, and the probability of an interval is proportional +#' to its rate in \code{accrual_rate} times its length (only the relative +#' rates matter). The dropout time of a subject, measured from enrollment, +#' has a piecewise exponential distribution with hazard +#' \code{dropout_hazard[j]} from time \code{dropout_time[j]} (the last hazard +#' applies until infinity), independently of the event time. The analysis +#' takes place at the calendar time \code{cut_time} after the start of +#' enrollment, or at the calendar time of the \code{cut_events}-th event +#' among all subjects of the study (if fewer events occur, all subjects are +#' followed until their event or dropout). A subject enrolled at time +#' \eqn{e} with event time \eqn{T} and dropout time \eqn{C} contributes the +#' observed time \eqn{\min(T, C, \textrm{cut} - e)} (0 if enrolled after the +#' analysis) and an event if \eqn{T \le C} and \eqn{e + T \le \textrm{cut}}. +#' +#' @param accrual_time Boundaries of the enrollment intervals: an increasing +#' numeric vector that starts at 0, of length at least 2. +#' @param accrual_rate Non-negative relative enrollment rates of the +#' intervals, one fewer than \code{accrual_time}, with a positive sum. The +#' default is a constant rate (uniform enrollment). +#' @param dropout_time Start times of the pieces of the dropout hazard: an +#' increasing numeric vector that starts at 0. +#' @param dropout_hazard Non-negative dropout hazards of the pieces, of the +#' same length as \code{dropout_time}. The default \code{0} means no +#' dropout. +#' @param cut_time Calendar time of the analysis after the start of +#' enrollment (positive), or \code{NULL}. +#' @param cut_events Number of events that triggers the analysis (a whole +#' number of at least 1), or \code{NULL}. Exactly one of \code{cut_time} and +#' \code{cut_events} must be given. +#' +#' @return An object of class \code{"qdm_conduct"} with the arguments and the +#' element \code{accrual_cum}, the cumulative probabilities of enrollment +#' at the ends of the intervals. +#' +#' @seealso \code{\link{design_tte}} +#' @examples +#' # Enrollment over 15 months with increasing rates, dropout hazard 0.00226 +#' # per month, analysis 15.44 months after the start of enrollment +#' conduct_tte(accrual_time = c(0, 5, 10, 15), accrual_rate = c(0.4, 2, 4.5), +#' dropout_hazard = 0.00226, cut_time = 15.44) +#' +#' # Uniform enrollment over 12 months, analysis at the 20th event +#' conduct_tte(accrual_time = c(0, 12), cut_events = 20) +#' @export +conduct_tte <- function(accrual_time, + accrual_rate = rep(1, length(accrual_time) - 1L), + dropout_time = 0, dropout_hazard = 0, + cut_time = NULL, cut_events = NULL) { + check_numeric(accrual_time, "accrual_time", len = NULL, lower = 0) + if (length(accrual_time) < 2L || accrual_time[1L] != 0 || + any(diff(accrual_time) <= 0)) { + stop(paste("'accrual_time' must be an increasing vector of at least two", + "values that starts at 0."), call. = FALSE) + } + check_numeric(accrual_rate, "accrual_rate", len = length(accrual_time) - 1L, + lower = 0) + if (sum(accrual_rate) <= 0) { + stop("'accrual_rate' must have a positive sum.", call. = FALSE) + } + check_numeric(dropout_time, "dropout_time", len = NULL, lower = 0) + if (dropout_time[1L] != 0 || any(diff(dropout_time) <= 0)) { + stop("'dropout_time' must be an increasing vector that starts at 0.", + call. = FALSE) + } + check_numeric(dropout_hazard, "dropout_hazard", len = length(dropout_time), + lower = 0) + if (is.null(cut_time) == is.null(cut_events)) { + stop("Specify exactly one of 'cut_time' and 'cut_events'.", + call. = FALSE) + } + if (!is.null(cut_time)) { + check_numeric(cut_time, "cut_time", lower = 0, lower_open = TRUE) + } else { + check_numeric(cut_events, "cut_events", lower = 1, integer = TRUE) + cut_events <- as.integer(round(cut_events)) + } + w <- accrual_rate * diff(accrual_time) + cum <- cumsum(w) / sum(w) + cum[length(cum)] <- 1 + structure(list(accrual_time = as.numeric(accrual_time), + accrual_rate = as.numeric(accrual_rate), accrual_cum = cum, + dropout_time = as.numeric(dropout_time), + dropout_hazard = as.numeric(dropout_hazard), + cut_time = cut_time, cut_events = cut_events), + class = "qdm_conduct") +} diff --git a/R/control_form.R b/R/control_form.R new file mode 100644 index 0000000..90d189e --- /dev/null +++ b/R/control_form.R @@ -0,0 +1,38 @@ +#' Form of the control group of a design +#' +#' Checks the combination of the control group arguments of a design and +#' returns the form of the control group. +#' +#' @param n_c Number of subjects in the concurrent control group. +#' @param external_c External control data or \code{NULL}. +#' @param hypothetical_c Hypothetical control or \code{NULL}. +#' @param fixed_c Fixed control value(s) or \code{NULL}. +#' +#' @return \code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +#' \code{"fixed"}. +#' @noRd +control_form <- function(n_c, external_c, hypothetical_c, fixed_c = NULL) { + if (n_c > 0) { + if (!is.null(hypothetical_c)) { + stop("'hypothetical_c' can be used only when 'n_c' is 0.", + call. = FALSE) + } + if (!is.null(fixed_c)) { + stop("'fixed_c' can be used only when 'n_c' is 0.", call. = FALSE) + } + return("concurrent") + } + given <- c(external = !is.null(external_c), + hypothetical = !is.null(hypothetical_c), + fixed = !is.null(fixed_c)) + if (!any(given)) { + stop(paste("When 'n_c' is 0, specify 'external_c' (external control", + "data), 'hypothetical_c' (hypothetical control) or 'fixed_c'", + "(fixed control value)."), call. = FALSE) + } + if (sum(given) > 1L) { + stop(paste("When 'n_c' is 0, specify only one of 'external_c',", + "'hypothetical_c' and 'fixed_c'."), call. = FALSE) + } + names(given)[given] +} diff --git a/R/control_location.R b/R/control_location.R new file mode 100644 index 0000000..ca93296 --- /dev/null +++ b/R/control_location.R @@ -0,0 +1,44 @@ +#' Location of the distribution of the control group without a concurrent +#' control +#' +#' Used to shift the thresholds in plots of operating characteristics of a +#' design without a concurrent control group. For a fixed control it is the +#' fixed value. Otherwise, for a binary endpoint it is the mean of the Beta +#' distribution of the control response rate; for a continuous endpoint it +#' is the location of the t distribution of the control mean (the posterior +#' mean given the external control data, or \eqn{\mu_{0c}} of a hypothetical +#' control); for a time-to-event endpoint it is the mean of the milestone +#' survival probability, \eqn{(b / (b + t_0))^a} for a control hazard with +#' the Gamma distribution of shape \eqn{a} and rate \eqn{b}. +#' +#' @param design An object of class \code{"qdm_design"} for one endpoint +#' without a concurrent control group. +#' +#' @return A number. +#' @noRd +control_location <- function(design) { + if (design$control == "fixed") { + return(design$fixed_c) + } + switch( + design$endpoint, + binary = { + post <- posterior_binary(design$prior_c, 0, 0, + external = design$external_c, + hypothetical = design$hypothetical_c) + post$a / (post$a + post$b) + }, + continuous = if (design$control == "hypothetical") { + design$hypothetical_c$mean + } else { + posterior_continuous(design$prior_c, 0L, + external = design$external_c)$mu + }, + tte = { + post <- posterior_tte(design$prior_c, 0, 0, + external = design$external_c, + hypothetical = design$hypothetical_c) + (post$rate / (post$rate + design$milestone))^post$shape + } + ) +} diff --git a/R/control_posterior_continuous.R b/R/control_posterior_continuous.R new file mode 100644 index 0000000..249af2d --- /dev/null +++ b/R/control_posterior_continuous.R @@ -0,0 +1,40 @@ +#' Distribution of the control mean for a continuous endpoint +#' +#' Returns the parameters of the distribution of the control mean of a +#' continuous design in the form returned by \code{posterior_continuous()}, +#' so that the mean has the distribution +#' \eqn{t_{\nu}(\mu, \sigma^2 / \kappa)}. For a concurrent control group it is +#' the posterior distribution given the external control data (if any) and +#' the current control data; for an external control it is the posterior +#' distribution given the external data only. For a hypothetical control +#' (Kang et al., 2026, Section 4.2.4) it is +#' \eqn{\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 / \kappa_{nt})}, +#' given by \eqn{\mu = \mu_{0c}}, \eqn{\kappa = \kappa_{nt}}, +#' \eqn{\nu = \nu_{nt}} and \eqn{\sigma^2 = r \sigma_{nt}^2}; with these +#' parameters the posterior predictive distribution of the mean of \eqn{m_c} +#' future control subjects is +#' \eqn{t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 (1 / \kappa_{nt} + 1 / m_c))}. +#' For a fixed control there is no distribution and \code{NULL} is returned. +#' +#' @param design An object of class \code{"qdm_design_continuous"}. +#' @param post_t Posterior parameters of the treatment group, as returned by +#' \code{posterior_continuous()}. +#' @param n,mean,sd Current control data (concurrent control only). +#' +#' @return A list with elements \code{mu}, \code{kappa}, \code{nu} and +#' \code{sigma2}, or \code{NULL} for a fixed control. +#' @noRd +control_posterior_continuous <- function(design, post_t, n = 0L, mean = 0, + sd = 0) { + switch( + design$control, + concurrent = posterior_continuous(design$prior_c, n, mean, sd, + external = design$external_c), + external = posterior_continuous(design$prior_c, 0L, + external = design$external_c), + hypothetical = list(mu = design$hypothetical_c$mean, + kappa = post_t$kappa, nu = post_t$nu, + sigma2 = design$hypothetical_c$r * post_t$sigma2), + fixed = NULL + ) +} diff --git a/R/control_posterior_continuous2.R b/R/control_posterior_continuous2.R new file mode 100644 index 0000000..46e5cf6 --- /dev/null +++ b/R/control_posterior_continuous2.R @@ -0,0 +1,36 @@ +#' Parameters of the distribution of the control group of two continuous +#' endpoints +#' +#' For a concurrent control group, the posterior parameters given the +#' external and current control data; for external control data only, the +#' parameters given the external data; for a hypothetical control, the +#' pseudo-parameters \eqn{(\mu_{0c}, \kappa_{nt}, \nu_{nt}, r \Lambda_{nt})} +#' from the posterior parameters of the treatment group (Yamaguchi et al., +#' submitted, Section A.2.6); for a fixed control, \code{NULL}. +#' +#' @param design An object of class \code{"qdm_design_continuous2"}. +#' @param post_t Posterior parameters of the treatment group (see +#' \code{posterior_continuous2()}). +#' @param n,mean,cov Current control data (concurrent control only). +#' +#' @return A list as returned by \code{posterior_continuous2()}, or +#' \code{NULL} for a fixed control. +#' @noRd +control_posterior_continuous2 <- function(design, post_t, n = 0L, + mean = c(0, 0), + cov = matrix(0, 2L, 2L)) { + switch( + design$control, + concurrent = posterior_continuous2(design$prior_c, n, mean, cov, + external = design$external_c), + external = posterior_continuous2(design$prior_c, 0L, + external = design$external_c), + hypothetical = list( + mu = matrix(design$hypothetical_c$mean, nrow(post_t$mu), 2L, + byrow = TRUE), + kappa = post_t$kappa, nu = post_t$nu, + Lambda = design$hypothetical_c$r * post_t$Lambda + ), + fixed = NULL + ) +} diff --git a/R/criterion_posterior.R b/R/criterion_posterior.R new file mode 100644 index 0000000..9531c04 --- /dev/null +++ b/R/criterion_posterior.R @@ -0,0 +1,106 @@ +#' Decision criterion based on posterior probability +#' +#' Specifies a Go/NoGo decision criterion based on the posterior probability +#' of the treatment effect \eqn{\theta} (the difference between the treatment +#' and control groups) given the proof-of-concept data \eqn{D}. +#' +#' For one endpoint, the Go region is \eqn{\theta > \theta_{TV}} and the NoGo +#' region is \eqn{\theta \le \theta_{MAV}}. The Go criterion is +#' \eqn{\Pr(\theta > \theta_{TV} \mid D) \ge \gamma_{go}} and the NoGo +#' criterion is \eqn{\Pr(\theta \le \theta_{MAV} \mid D) \ge \gamma_{nogo}}. +#' In the notation of Kang et al. (2026), where the NoGo criterion is +#' \eqn{\Pr(\theta > \theta_{MAV} \mid D) \le \gamma_2}, this corresponds to +#' \eqn{\gamma_{nogo} = 1 - \gamma_2}. +#' +#' For two endpoints, the target values and minimum acceptable values divide +#' the plane of \eqn{(\theta_1, \theta_2)} into nine regions (see +#' \code{\link{qdm_regions}}). The Go criterion is that the posterior +#' probability of the union of \code{go_regions} is at least +#' \eqn{\gamma_{go}}, and the NoGo criterion is that the posterior probability +#' of the union of \code{nogo_regions} is at least \eqn{\gamma_{nogo}} +#' (Yamaguchi et al., submitted, equations 2 and 3). With \code{rule = "and"} +#' or \code{"or"}, the criteria are instead based on the marginal posterior +#' probabilities of each endpoint (equations 4 and 5): the Go criterion is +#' \eqn{\Pr(\theta_1 > \theta_{TV1} \mid D) \ge \gamma_{go1}} and (or) +#' \eqn{\Pr(\theta_2 > \theta_{TV2} \mid D) \ge \gamma_{go2}}, and the NoGo +#' criterion is \eqn{\Pr(\theta_1 \le \theta_{MAV1} \mid D) \ge +#' \gamma_{nogo1}} and (or) +#' \eqn{\Pr(\theta_2 \le \theta_{MAV2} \mid D) \ge \gamma_{nogo2}}. +#' +#' The decision is Go if only the Go criterion is met, NoGo if only the NoGo +#' criterion is met, Gray if neither is met, and Miss if both are met. For one +#' endpoint, Miss can occur only when \eqn{\gamma_{go} + \gamma_{nogo} \le 1}. +#' +#' @param theta_tv Target value (TV) of the treatment effect: a number for one +#' endpoint or a numeric vector of length 2 for two endpoints. +#' @param theta_mav Minimum acceptable value (MAV) of the treatment effect, of +#' the same length as \code{theta_tv}. Each element must be smaller than the +#' corresponding element of \code{theta_tv}. +#' @param gamma_go Probability threshold for the Go criterion, strictly +#' between 0 and 1. With \code{rule = "and"} or \code{"or"}, one threshold +#' per endpoint (a single number is used for both). +#' @param gamma_nogo Probability threshold for the NoGo criterion, strictly +#' between 0 and 1, given in the same way as \code{gamma_go}. +#' @param go_regions Region numbers (from 1 to 9) forming the Go region for two +#' endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +#' default, region 1, requires both effects to exceed their target values. +#' @param nogo_regions Region numbers (from 1 to 9) forming the NoGo region for +#' two endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +#' default, region 9, requires both effects to be at most their minimum +#' acceptable values. +#' @param rule For two endpoints, \code{"joint"} (the default; probabilities +#' of unions of regions), \code{"and"} or \code{"or"} (marginal +#' probabilities of each endpoint, combined with AND or OR). Ignored for one +#' endpoint. +#' +#' @return An object of class +#' \code{c("qdm_criterion_posterior", "qdm_criterion")}. +#' +#' @references +#' Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +#' decision-making framework in cell and gene therapy development for rare +#' diseases. \emph{Journal of Biopharmaceutical Statistics}. +#' \doi{10.1080/10543406.2026.2655410} +#' +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' @family criteria +#' @examples +#' # One endpoint +#' criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' +#' # Two endpoints +#' criterion_posterior(theta_tv = c(0.2, 0.15), theta_mav = c(0.1, 0.05), +#' gamma_go = 0.3, gamma_nogo = 0.4) +#' +#' # Two endpoints, marginal criteria combined with AND +#' criterion_posterior(theta_tv = c(0.2, 0.15), theta_mav = c(0.1, 0.05), +#' gamma_go = c(0.6, 0.5), gamma_nogo = 0.7, rule = "and") +#' @export +criterion_posterior <- function(theta_tv, theta_mav, gamma_go, gamma_nogo, + go_regions = 1L, nogo_regions = 9L, + rule = c("joint", "and", "or")) { + check_numeric(theta_tv, "theta_tv", len = NULL) + n_endpoints <- length(theta_tv) + if (!(n_endpoints %in% c(1L, 2L))) { + stop("'theta_tv' must have length 1 (one endpoint) or 2 (two endpoints).", + call. = FALSE) + } + check_numeric(theta_mav, "theta_mav", len = n_endpoints) + if (any(theta_tv <= theta_mav)) { + stop("Each element of 'theta_tv' must be greater than that of 'theta_mav'.", + call. = FALSE) + } + rule <- match.arg(rule) + given <- !missing(go_regions) || !missing(nogo_regions) + r <- check_rule(rule, n_endpoints, gamma_go, gamma_nogo, go_regions, + nogo_regions, regions_given = given, n_regions = 9L) + structure(list(type = "posterior", n_endpoints = n_endpoints, + theta_tv = theta_tv, theta_mav = theta_mav, + gamma_go = r$gamma_go, gamma_nogo = r$gamma_nogo, + go_regions = r$go, nogo_regions = r$nogo, rule = r$rule), + class = c("qdm_criterion_posterior", "qdm_criterion")) +} diff --git a/R/criterion_predictive.R b/R/criterion_predictive.R new file mode 100644 index 0000000..012fcb2 --- /dev/null +++ b/R/criterion_predictive.R @@ -0,0 +1,87 @@ +#' Decision criterion based on posterior predictive probability +#' +#' Specifies a Go/NoGo decision criterion based on the posterior predictive +#' probability of the treatment effect \eqn{\tilde\theta} that will be +#' observed in a future study with \code{m_t} and \code{m_c} subjects in the +#' treatment and control groups, given the proof-of-concept data \eqn{D}. +#' The future effect is the difference between the future sample proportions +#' (binary endpoints) or sample means (continuous endpoints). +#' +#' For one endpoint, the Go region is \eqn{\tilde\theta > \theta_{NULL}} and +#' the NoGo region is \eqn{\tilde\theta \le \theta_{NULL}}. The Go criterion +#' is \eqn{\Pr(\tilde\theta > \theta_{NULL} \mid D) \ge \gamma_{go}} and the +#' NoGo criterion is +#' \eqn{\Pr(\tilde\theta \le \theta_{NULL} \mid D) \ge \gamma_{nogo}}. Because +#' the two probabilities add up to 1, a Gray decision is possible only when +#' \eqn{\gamma_{go} + \gamma_{nogo} > 1}, and Miss decisions can occur only when +#' \eqn{\gamma_{go} + \gamma_{nogo} \le 1}. +#' +#' For two endpoints, the null values divide the plane of +#' \eqn{(\tilde\theta_1, \tilde\theta_2)} into four regions (see +#' \code{\link{qdm_regions}}), and the criteria are based on the predictive +#' probabilities of the unions of \code{go_regions} and \code{nogo_regions} +#' (Yamaguchi et al., submitted, equations 7 and 8). With \code{rule = "and"} +#' or \code{"or"}, they are based on the marginal predictive probabilities of +#' each endpoint, \eqn{\Pr(\tilde\theta_k > \theta_{NULLk} \mid D)} for Go +#' and \eqn{\Pr(\tilde\theta_k \le \theta_{NULLk} \mid D)} for NoGo, +#' combined with AND or OR (equations 9 and 10). +#' +#' @param theta_null Null value of the treatment effect in the future study: a +#' number for one endpoint or a numeric vector of length 2 for two +#' endpoints. +#' @param m_t,m_c Numbers of subjects in the treatment and control groups of +#' the future study (whole numbers of at least 1). +#' @param gamma_go Probability threshold for the Go criterion, strictly +#' between 0 and 1. With \code{rule = "and"} or \code{"or"}, one threshold +#' per endpoint (a single number is used for both). +#' @param gamma_nogo Probability threshold for the NoGo criterion, strictly +#' between 0 and 1, given in the same way as \code{gamma_go}. +#' @param go_regions Region numbers (from 1 to 4) forming the Go region for two +#' endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +#' default, region 1, requires both future effects to exceed their null +#' values. +#' @param nogo_regions Region numbers (from 1 to 4) forming the NoGo region for +#' two endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +#' default, region 4, requires both future effects to be at most their null +#' values. +#' @param rule For two endpoints, \code{"joint"} (the default; probabilities +#' of unions of regions), \code{"and"} or \code{"or"} (marginal +#' probabilities of each endpoint, combined with AND or OR). Ignored for one +#' endpoint. +#' +#' @return An object of class +#' \code{c("qdm_criterion_predictive", "qdm_criterion")}. +#' +#' @references +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' @family criteria +#' @examples +#' criterion_predictive(theta_null = 0, m_t = 50, gamma_go = 0.9, +#' gamma_nogo = 0.7) +#' @export +criterion_predictive <- function(theta_null, m_t, m_c = m_t, gamma_go, + gamma_nogo, go_regions = 1L, + nogo_regions = 4L, + rule = c("joint", "and", "or")) { + check_numeric(theta_null, "theta_null", len = NULL) + n_endpoints <- length(theta_null) + if (!(n_endpoints %in% c(1L, 2L))) { + stop("'theta_null' must have length 1 (one endpoint) or 2 (two endpoints).", + call. = FALSE) + } + check_numeric(m_t, "m_t", lower = 1, integer = TRUE) + check_numeric(m_c, "m_c", lower = 1, integer = TRUE) + rule <- match.arg(rule) + given <- !missing(go_regions) || !missing(nogo_regions) + r <- check_rule(rule, n_endpoints, gamma_go, gamma_nogo, go_regions, + nogo_regions, regions_given = given, n_regions = 4L) + structure(list(type = "predictive", n_endpoints = n_endpoints, + theta_null = theta_null, m_t = as.integer(round(m_t)), + m_c = as.integer(round(m_c)), gamma_go = r$gamma_go, + gamma_nogo = r$gamma_nogo, go_regions = r$go, + nogo_regions = r$nogo, rule = r$rule), + class = c("qdm_criterion_predictive", "qdm_criterion")) +} diff --git a/R/data_binary.R b/R/data_binary.R new file mode 100644 index 0000000..36fdc14 --- /dev/null +++ b/R/data_binary.R @@ -0,0 +1,25 @@ +#' Binary endpoint data +#' +#' Summarizes the data of one group for a single binary endpoint as the number +#' of subjects and the number of responders. Used for observed proof-of-concept +#' data, external data and hypothetical control data. +#' +#' @param n Number of subjects (a whole number of at least 1). +#' @param y Number of responders (a whole number from 0 to \code{n}). +#' +#' @return An object of class \code{c("qdm_data_binary", "qdm_data")} with +#' integer elements \code{n} and \code{y}. +#' +#' @family data +#' @examples +#' data_binary(n = 12, y = 7) +#' @export +data_binary <- function(n, y) { + check_numeric(n, "n", lower = 1, integer = TRUE) + check_numeric(y, "y", lower = 0, integer = TRUE) + if (y > n) { + stop("'y' must not exceed 'n'.", call. = FALSE) + } + structure(list(n = as.integer(round(n)), y = as.integer(round(y))), + class = c("qdm_data_binary", "qdm_data")) +} diff --git a/R/data_binary2.R b/R/data_binary2.R new file mode 100644 index 0000000..b5fb78f --- /dev/null +++ b/R/data_binary2.R @@ -0,0 +1,33 @@ +#' Data for two binary endpoints +#' +#' Summarizes the data of one group for two binary endpoints by the counts of +#' the four joint response patterns. +#' +#' The cells are ordered as \code{"00"}, \code{"01"}, \code{"10"} and +#' \code{"11"}, where the first digit is the response on endpoint 1 and the +#' second digit is the response on endpoint 2 (1 = response, 0 = no +#' response). +#' +#' @param counts A numeric vector of four non-negative whole numbers in the +#' cell order \code{"00"}, \code{"01"}, \code{"10"}, \code{"11"}, with a +#' total of at least 1. +#' +#' @return An object of class \code{c("qdm_data_binary2", "qdm_data")} with +#' elements \code{n} (the total count) and \code{counts} (a named integer +#' vector of length 4). +#' +#' @family data +#' @examples +#' data_binary2(c(4, 2, 3, 6)) +#' @export +data_binary2 <- function(counts) { + check_numeric(counts, "counts", len = 4L, lower = 0, integer = TRUE) + counts <- stats::setNames(as.integer(round(counts)), + c("00", "01", "10", "11")) + n <- sum(counts) + if (n < 1L) { + stop("'counts' must contain at least one subject.", call. = FALSE) + } + structure(list(n = n, counts = counts), + class = c("qdm_data_binary2", "qdm_data")) +} diff --git a/R/data_continuous.R b/R/data_continuous.R new file mode 100644 index 0000000..ca4d99e --- /dev/null +++ b/R/data_continuous.R @@ -0,0 +1,24 @@ +#' Continuous endpoint data +#' +#' Summarizes the data of one group for a single continuous endpoint by its +#' sufficient statistics: the number of subjects, the sample mean and the +#' sample standard deviation (with divisor \code{n - 1}). +#' +#' @param n Number of subjects (a whole number of at least 2). +#' @param mean Sample mean. +#' @param sd Sample standard deviation (positive). +#' +#' @return An object of class \code{c("qdm_data_continuous", "qdm_data")} with +#' elements \code{n}, \code{mean} and \code{sd}. +#' +#' @family data +#' @examples +#' data_continuous(n = 12, mean = 3.2, sd = 2.0) +#' @export +data_continuous <- function(n, mean, sd) { + check_numeric(n, "n", lower = 2, integer = TRUE) + check_numeric(mean, "mean") + check_numeric(sd, "sd", lower = 0, lower_open = TRUE) + structure(list(n = as.integer(round(n)), mean = mean, sd = sd), + class = c("qdm_data_continuous", "qdm_data")) +} diff --git a/R/data_continuous2.R b/R/data_continuous2.R new file mode 100644 index 0000000..4476c5f --- /dev/null +++ b/R/data_continuous2.R @@ -0,0 +1,27 @@ +#' Data for two continuous endpoints +#' +#' Summarizes the data of one group for two continuous endpoints by their +#' sufficient statistics: the number of subjects, the vector of sample means +#' and the sample covariance matrix (with divisor \code{n - 1}). +#' +#' @param n Number of subjects (a whole number of at least 3). +#' @param mean Numeric vector of length 2, the sample means of endpoints 1 and +#' 2. +#' @param cov A 2 x 2 symmetric positive definite sample covariance matrix. +#' +#' @return An object of class \code{c("qdm_data_continuous2", "qdm_data")} +#' with elements \code{n}, \code{mean} and \code{cov}. +#' +#' @family data +#' @examples +#' data_continuous2(n = 12, mean = c(3.2, 1.5), +#' cov = matrix(c(4, 1.2, 1.2, 2), nrow = 2)) +#' @export +data_continuous2 <- function(n, mean, cov) { + check_numeric(n, "n", lower = 3, integer = TRUE) + check_numeric(mean, "mean", len = 2L) + check_pd_matrix(cov, "cov") + structure(list(n = as.integer(round(n)), mean = as.numeric(mean), + cov = unname(cov)), + class = c("qdm_data_continuous2", "qdm_data")) +} diff --git a/R/data_tte.R b/R/data_tte.R new file mode 100644 index 0000000..99b560a --- /dev/null +++ b/R/data_tte.R @@ -0,0 +1,30 @@ +#' Time-to-event endpoint data +#' +#' Summarizes the data of one group for a time-to-event endpoint by the +#' sufficient statistics of the exponential model: the number of events and +#' the total observed time (the sum over subjects of the time from entry to +#' the event or censoring). Used for observed proof-of-concept data, external +#' data and hypothetical control data. +#' +#' With exponential event times and independent censoring, the likelihood of +#' the hazard \eqn{\lambda} is proportional to +#' \eqn{\lambda^d \exp(-\lambda E)} for \eqn{d} events and total observed +#' time \eqn{E}, so these two numbers are all that the analysis needs. +#' +#' @param events Number of events (a whole number of at least 0). +#' @param exposure Total observed time (positive), in the same unit as the +#' milestone time of the design. +#' +#' @return An object of class \code{c("qdm_data_tte", "qdm_data")} with +#' elements \code{events} and \code{exposure}. +#' +#' @family data +#' @examples +#' data_tte(events = 5, exposure = 40) +#' @export +data_tte <- function(events, exposure) { + check_numeric(events, "events", lower = 0, integer = TRUE) + check_numeric(exposure, "exposure", lower = 0, lower_open = TRUE) + structure(list(events = as.integer(round(events)), exposure = exposure), + class = c("qdm_data_tte", "qdm_data")) +} diff --git a/R/dbetabinom.R b/R/dbetabinom.R new file mode 100644 index 0000000..69db32d --- /dev/null +++ b/R/dbetabinom.R @@ -0,0 +1,14 @@ +#' Beta-binomial probability mass function +#' +#' Computes the probability mass function of the Beta-binomial distribution +#' on the log scale to avoid overflow and underflow for large \code{m}. +#' +#' @param k Integer vector of counts from 0 to \code{m}. +#' @param m Number of trials. +#' @param a,b Positive shape parameters. +#' +#' @return A numeric vector of probabilities. +#' @noRd +dbetabinom <- function(k, m, a, b) { + exp(lchoose(m, k) + lbeta(k + a, m - k + b) - lbeta(a, b)) +} diff --git a/R/decide_binary.R b/R/decide_binary.R new file mode 100644 index 0000000..c90c0a4 --- /dev/null +++ b/R/decide_binary.R @@ -0,0 +1,47 @@ +#' Posterior distributions and region probabilities for observed binary data +#' +#' @param design An object of class \code{"qdm_design_binary"}. +#' @param data_t,data_c Observed data of the treatment and control groups; +#' \code{data_c} is \code{NULL} for a design without a concurrent control +#' group. +#' +#' @return A list with elements \code{prob_go}, \code{prob_nogo}, +#' \code{posterior_t} and \code{posterior_c} (named vectors of the Beta +#' parameters \code{a} and \code{b}; for a fixed control, +#' \code{posterior_c} is the fixed value named \code{value}). +#' @noRd +decide_binary <- function(design, data_t, data_c) { + if (!inherits(data_t, "qdm_data_binary")) { + stop("'data_t' must be created by data_binary().", call. = FALSE) + } + if (design$control == "concurrent") { + if (!inherits(data_c, "qdm_data_binary")) { + stop(paste("'data_c' must be created by data_binary() for a design", + "with a concurrent control group."), call. = FALSE) + } + post_c <- posterior_binary(design$prior_c, data_c$n, data_c$y, + external = design$external_c) + } else { + if (!is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + post_c <- if (design$control == "fixed") { + NULL + } else { + posterior_binary(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + } + } + post_t <- posterior_binary(design$prior_t, data_t$n, data_t$y, + external = design$external_t) + p <- region_prob_binary(design$criterion, post_t$a, post_t$b, post_c$a, + post_c$b, fixed = design$fixed_c) + list(prob_go = p$go, prob_nogo = p$nogo, + posterior_t = c(a = post_t$a, b = post_t$b), + posterior_c = if (is.null(post_c)) { + c(value = design$fixed_c) + } else { + c(a = post_c$a, b = post_c$b) + }) +} diff --git a/R/decide_binary2.R b/R/decide_binary2.R new file mode 100644 index 0000000..ce30f07 --- /dev/null +++ b/R/decide_binary2.R @@ -0,0 +1,59 @@ +#' Region probabilities for observed data of two binary endpoints +#' +#' @param design An object of class \code{"qdm_design_binary2"}. +#' @param data_t,data_c Observed data of the treatment and control groups; +#' \code{data_c} is \code{NULL} for a design without a concurrent control +#' group. +#' +#' @return A list with elements \code{prob_go}, \code{prob_nogo} (one number, +#' or one per endpoint for the marginal rules), \code{prob_regions} (the +#' probabilities of all regions, \code{R1} to \code{R9} or \code{R1} to +#' \code{R4}), \code{posterior_t} and \code{posterior_c} (named vectors of +#' Dirichlet parameters; for a fixed control, \code{posterior_c} is the +#' fixed values named \code{value1} and \code{value2}). All probabilities +#' are computed from the same Monte Carlo draws. +#' @noRd +decide_binary2 <- function(design, data_t, data_c) { + if (!inherits(data_t, "qdm_data_binary2")) { + stop("'data_t' must be created by data_binary2().", call. = FALSE) + } + alpha_t <- posterior_binary2(design$prior_t, data_t$counts, + external = design$external_t) + if (design$control == "concurrent") { + if (!inherits(data_c, "qdm_data_binary2")) { + stop(paste("'data_c' must be created by data_binary2() for a design", + "with a concurrent control group."), call. = FALSE) + } + alpha_c <- posterior_binary2(design$prior_c, data_c$counts, + external = design$external_c) + } else { + if (!is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + alpha_c <- if (design$control == "fixed") { + NULL + } else { + posterior_binary2(design$prior_c, c(0, 0, 0, 0), + external = design$external_c, + hypothetical = design$hypothetical_c) + } + } + crit <- design$criterion + n_regions <- if (crit$type == "posterior") 9L else 4L + sets <- region_sets(crit) + p <- region_prob_binary2(crit, alpha_t, alpha_c, 1L, 1L, + c(as.list(seq_len(n_regions)), sets$go, + sets$nogo), design$nMC, fixed = design$fixed_c) + n_go <- length(sets$go) + list(prob_go = p[1L, n_regions + seq_len(n_go)], + prob_nogo = p[1L, n_regions + n_go + seq_len(n_go)], + prob_regions = stats::setNames(p[1L, seq_len(n_regions)], + paste0("R", seq_len(n_regions))), + posterior_t = alpha_t[1L, ], + posterior_c = if (is.null(alpha_c)) { + c(value1 = design$fixed_c[1L], value2 = design$fixed_c[2L]) + } else { + alpha_c[1L, ] + }) +} diff --git a/R/decide_continuous.R b/R/decide_continuous.R new file mode 100644 index 0000000..90c1f0a --- /dev/null +++ b/R/decide_continuous.R @@ -0,0 +1,50 @@ +#' Posterior distributions and region probabilities for observed continuous +#' data +#' +#' @param design An object of class \code{"qdm_design_continuous"}. +#' @param data_t,data_c Observed data of the treatment and control groups; +#' \code{data_c} is \code{NULL} for a design without a concurrent control +#' group. +#' +#' @return A list with elements \code{prob_go}, \code{prob_nogo}, +#' \code{posterior_t} and \code{posterior_c} (named vectors of the +#' parameters \code{mu}, \code{kappa}, \code{nu} and \code{sigma}; for a +#' fixed control, \code{posterior_c} is the fixed value named +#' \code{value}). +#' @noRd +decide_continuous <- function(design, data_t, data_c) { + if (!inherits(data_t, "qdm_data_continuous")) { + stop("'data_t' must be created by data_continuous().", call. = FALSE) + } + post_t <- posterior_continuous(design$prior_t, data_t$n, data_t$mean, + data_t$sd, external = design$external_t) + if (design$control == "concurrent") { + if (!inherits(data_c, "qdm_data_continuous")) { + stop(paste("'data_c' must be created by data_continuous() for a", + "design with a concurrent control group."), call. = FALSE) + } + post_c <- control_posterior_continuous(design, post_t, data_c$n, + data_c$mean, data_c$sd) + } else { + if (!is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + post_c <- control_posterior_continuous(design, post_t) + } + if (!is.null(post_c)) { + check_df_mm(post_t$nu, post_c$nu, design$method) + } + p <- region_prob_continuous(design$criterion, post_t, post_c, + design$method, design$nMC, + fixed = design$fixed_c) + params <- function(post) { + if (is.null(post)) { + return(c(value = design$fixed_c)) + } + c(mu = post$mu, kappa = post$kappa, nu = post$nu, + sigma = sqrt(post$sigma2)) + } + list(prob_go = p$go, prob_nogo = p$nogo, posterior_t = params(post_t), + posterior_c = params(post_c)) +} diff --git a/R/decide_continuous2.R b/R/decide_continuous2.R new file mode 100644 index 0000000..8fb9866 --- /dev/null +++ b/R/decide_continuous2.R @@ -0,0 +1,65 @@ +#' Region probabilities for observed data of two continuous endpoints +#' +#' @param design An object of class \code{"qdm_design_continuous2"}. +#' @param data_t,data_c Observed data of the treatment and control groups; +#' \code{data_c} is \code{NULL} for a design without a concurrent control +#' group. +#' +#' @return A list with elements \code{prob_go}, \code{prob_nogo} (one number, +#' or one per endpoint for the marginal rules), \code{prob_regions} (the +#' probabilities of all regions, \code{R1} to \code{R9} or \code{R1} to +#' \code{R4}), \code{posterior_t} and \code{posterior_c} (named vectors of +#' the parameters \code{mu1}, \code{mu2}, \code{kappa}, \code{nu}, +#' \code{L11}, \code{L12} and \code{L22}; for a fixed control, +#' \code{posterior_c} is the fixed values named \code{value1} and +#' \code{value2}). With \code{method = "MC"}, all probabilities are +#' estimated from the same draws. +#' @noRd +decide_continuous2 <- function(design, data_t, data_c) { + if (!inherits(data_t, "qdm_data_continuous2")) { + stop("'data_t' must be created by data_continuous2().", call. = FALSE) + } + post_t <- posterior_continuous2(design$prior_t, data_t$n, data_t$mean, + data_t$cov, external = design$external_t) + if (design$control == "concurrent") { + if (!inherits(data_c, "qdm_data_continuous2")) { + stop(paste("'data_c' must be created by data_continuous2() for a", + "design with a concurrent control group."), call. = FALSE) + } + post_c <- control_posterior_continuous2(design, post_t, data_c$n, + data_c$mean, data_c$cov) + } else { + if (!is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + post_c <- control_posterior_continuous2(design, post_t) + } + crit <- design$criterion + dist_c <- NULL + if (!is.null(post_c)) { + check_df_mm(post_t$nu - 1, post_c$nu - 1, design$method, + "method = \"MC\"") + dist_c <- mean_dist_continuous2(post_c, crit$type, crit$m_c) + } + n_regions <- if (crit$type == "posterior") 9L else 4L + sets <- region_sets(crit) + dist_t <- mean_dist_continuous2(post_t, crit$type, crit$m_t) + p <- region_prob_continuous2(crit, dist_t, dist_c, + c(as.list(seq_len(n_regions)), sets$go, + sets$nogo), design$method, design$nMC, + fixed = design$fixed_c) + n_go <- length(sets$go) + params <- function(post) { + if (is.null(post)) { + return(c(value1 = design$fixed_c[1L], value2 = design$fixed_c[2L])) + } + c(mu1 = post$mu[1L, 1L], mu2 = post$mu[1L, 2L], kappa = post$kappa, + nu = post$nu, post$Lambda[1L, ]) + } + list(prob_go = p[1L, n_regions + seq_len(n_go)], + prob_nogo = p[1L, n_regions + n_go + seq_len(n_go)], + prob_regions = stats::setNames(p[1L, seq_len(n_regions)], + paste0("R", seq_len(n_regions))), + posterior_t = params(post_t), posterior_c = params(post_c)) +} diff --git a/R/decide_tte.R b/R/decide_tte.R new file mode 100644 index 0000000..6382ee5 --- /dev/null +++ b/R/decide_tte.R @@ -0,0 +1,47 @@ +#' Posterior distributions and region probabilities for observed +#' time-to-event data +#' +#' @param design An object of class \code{"qdm_design_tte"}. +#' @param data_t,data_c Observed data of the treatment and control groups; +#' \code{data_c} is \code{NULL} for a design without a concurrent control +#' group. +#' +#' @return A list with elements \code{prob_go}, \code{prob_nogo}, +#' \code{posterior_t} and \code{posterior_c} (named vectors of the shape +#' and rate of the Gamma distribution of the hazard; for a fixed control, +#' \code{posterior_c} is the fixed value named \code{value}). +#' @noRd +decide_tte <- function(design, data_t, data_c) { + if (!inherits(data_t, "qdm_data_tte")) { + stop("'data_t' must be created by data_tte().", call. = FALSE) + } + if (design$control == "concurrent") { + if (!inherits(data_c, "qdm_data_tte")) { + stop(paste("'data_c' must be created by data_tte() for a design", + "with a concurrent control group."), call. = FALSE) + } + post_c <- posterior_tte(design$prior_c, data_c$events, data_c$exposure, + external = design$external_c) + } else { + if (!is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + post_c <- if (design$control == "fixed") { + NULL + } else { + posterior_tte(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + } + } + post_t <- posterior_tte(design$prior_t, data_t$events, data_t$exposure, + external = design$external_t) + p <- region_prob_tte(design, post_t, post_c) + list(prob_go = p$go, prob_nogo = p$nogo, + posterior_t = c(shape = post_t$shape, rate = post_t$rate), + posterior_c = if (is.null(post_c)) { + c(value = design$fixed_c) + } else { + c(shape = post_c$shape, rate = post_c$rate) + }) +} diff --git a/R/decision_colors.R b/R/decision_colors.R new file mode 100644 index 0000000..d391d6b --- /dev/null +++ b/R/decision_colors.R @@ -0,0 +1,21 @@ +#' Colors of the decisions in a plot +#' +#' Validates the color arguments of a \code{plot()} method and names them by +#' decision. +#' +#' @param ... Colors given as \code{col_go}, \code{col_nogo}, +#' \code{col_gray} and \code{col_miss} (any subset, in any order). +#' +#' @return A named character vector with the names \code{"Go"}, +#' \code{"NoGo"}, \code{"Gray"} and \code{"Miss"} for the arguments given. +#' @noRd +decision_colors <- function(...) { + cols <- list(...) + decisions <- c(col_go = "Go", col_nogo = "NoGo", col_gray = "Gray", + col_miss = "Miss") + for (nm in names(cols)) { + check_color(cols[[nm]], nm) + } + stats::setNames(unlist(cols, use.names = FALSE), + unname(decisions[names(cols)])) +} diff --git a/R/decision_label.R b/R/decision_label.R new file mode 100644 index 0000000..cf6bd8f --- /dev/null +++ b/R/decision_label.R @@ -0,0 +1,12 @@ +#' Decision from the Go and NoGo criteria +#' +#' @param met_go,met_nogo Logical vectors: whether the Go and NoGo criteria +#' are met. +#' +#' @return A character vector of \code{"Go"}, \code{"NoGo"}, \code{"Gray"} +#' (neither criterion met) or \code{"Miss"} (both criteria met). +#' @noRd +decision_label <- function(met_go, met_nogo) { + ifelse(met_go, ifelse(met_nogo, "Miss", "Go"), + ifelse(met_nogo, "NoGo", "Gray")) +} diff --git a/R/design_binary.R b/R/design_binary.R new file mode 100644 index 0000000..724a63b --- /dev/null +++ b/R/design_binary.R @@ -0,0 +1,128 @@ +#' Design with one binary endpoint +#' +#' Specifies a proof-of-concept study with one binary endpoint: the sample +#' sizes, the prior distributions, the external data, the form of the control +#' group and the decision criterion. The design is used by +#' \code{\link{qdm_decide}}, \code{\link{qdm_oc}} and +#' \code{\link{qdm_calibrate}}. +#' +#' The response rates \eqn{\pi_t} and \eqn{\pi_c} of the treatment and control +#' groups have Beta prior distributions, and the treatment effect is +#' \eqn{\theta = \pi_t - \pi_c}. The control group takes one of four forms. +#' \describe{ +#' \item{Concurrent control}{\code{n_c} is at least 1. External control data +#' can be added through \code{external_c}.} +#' \item{External control only}{\code{n_c = 0} and \code{external_c} is +#' given. The distribution of \eqn{\pi_c} is the posterior distribution +#' given the external control data.} +#' \item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +#' given. The distribution of \eqn{\pi_c} is the posterior distribution +#' given the hypothetical control data. The hypothetical control +#' \eqn{\pi_c \sim \textrm{Beta}(\alpha_t + z, \beta_t + n_t - z)} of +#' Kang et al. (2026, Section 4.1.4) is obtained with \code{prior_c} equal +#' to \code{prior_t} and \code{hypothetical(data_binary(n_t, z))}.} +#' \item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +#' control response rate is a known value \eqn{\pi_c}, as in a single-arm +#' study compared with a benchmark. The posterior probabilities are +#' \eqn{\Pr(\pi_t > \theta_{TV} + \pi_c \mid D)} and +#' \eqn{\Pr(\pi_t \le \theta_{MAV} + \pi_c \mid D)}, computed from the +#' Beta posterior distribution of \eqn{\pi_t}. For the posterior +#' predictive criterion the future effect is \eqn{Y_t / m_t - \pi_c}, +#' where \eqn{Y_t} follows the Beta-binomial posterior predictive +#' distribution (a future effect that differs from the null value by less +#' than \eqn{10^{-10}} is treated as equal to it); \code{m_c} is not used. +#' \code{prior_c} is not used and must be \code{NULL}.} +#' } +#' External treatment data (\code{external_t}) can be used with any form of +#' the control group. External data enter through a power prior: with +#' external data of \eqn{n_e} subjects and \eqn{y_e} responders and weight +#' \eqn{a_0}, the posterior distribution of the response rate is +#' \eqn{\textrm{Beta}(\alpha + a_0 y_e + y, \beta + a_0 (n_e - y_e) + n - y)}. +#' +#' @param n_t Number of subjects in the treatment group (a whole number of at +#' least 1). +#' @param n_c Number of subjects in the concurrent control group (a whole +#' number of at least 0). +#' @param prior_t,prior_c Beta prior distributions of the response rates of +#' the treatment and control groups, created by \code{\link{prior_beta}}. +#' \code{prior_c} must be \code{NULL} (the default) for a fixed control and +#' is required otherwise. +#' @param criterion Decision criterion for one endpoint, created by +#' \code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}. +#' @param external_t,external_c External data of the treatment and control +#' groups, created by \code{\link{borrow}} with \code{\link{data_binary}}, +#' or \code{NULL} (no external data). +#' @param hypothetical_c Hypothetical control, created by +#' \code{\link{hypothetical}} with \code{\link{data_binary}}, or +#' \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param fixed_c Fixed control response rate, a number from 0 to 1, or +#' \code{NULL}. It can be used only when \code{n_c = 0}. +#' +#' @return An object of class \code{c("qdm_design_binary", "qdm_design")}, a +#' list with the arguments and the element \code{control} +#' (\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +#' \code{"fixed"}). +#' +#' @references +#' Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +#' decision-making framework in cell and gene therapy development for rare +#' diseases. \emph{Journal of Biopharmaceutical Statistics}. +#' \doi{10.1080/10543406.2026.2655410} +#' +#' @family designs +#' @examples +#' # Concurrent control with external control data +#' design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8), +#' external_c = borrow(data_binary(n = 20, y = 8), a0 = 0.5) +#' ) +#' +#' # Uncontrolled study with a hypothetical control +#' design_binary( +#' n_t = 12, n_c = 0, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_predictive(theta_null = 0, m_t = 50, +#' gamma_go = 0.9, gamma_nogo = 0.7), +#' hypothetical_c = hypothetical(data = data_binary(n = 12, y = 4)) +#' ) +#' +#' # Single-arm study compared with a fixed control response rate of 0.2 +#' design_binary( +#' n_t = 20, n_c = 0, prior_t = prior_beta(1, 1), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.05, +#' gamma_go = 0.8, gamma_nogo = 0.8), +#' fixed_c = 0.2 +#' ) +#' @export +design_binary <- function(n_t, n_c, prior_t, prior_c = NULL, criterion, + external_t = NULL, external_c = NULL, + hypothetical_c = NULL, fixed_c = NULL) { + check_numeric(n_t, "n_t", lower = 1, integer = TRUE) + check_numeric(n_c, "n_c", lower = 0, integer = TRUE) + check_prior_beta(prior_t, "prior_t") + if (!inherits(criterion, "qdm_criterion") || criterion$n_endpoints != 1L) { + stop(paste("'criterion' must be created by criterion_posterior() or", + "criterion_predictive() for one endpoint."), call. = FALSE) + } + check_external_binary(external_t, "external_t") + check_external_binary(external_c, "external_c") + if (!is.null(hypothetical_c) && + (!inherits(hypothetical_c, "qdm_hypothetical") || + !inherits(hypothetical_c$data, "qdm_data_binary"))) { + stop(paste("'hypothetical_c' must be NULL or created by hypothetical()", + "with data_binary()."), call. = FALSE) + } + fixed_c <- check_fixed_c(fixed_c, 1L, probability = TRUE) + control <- control_form(n_c, external_c, hypothetical_c, fixed_c) + check_prior_control(prior_c, control, check_prior_beta) + structure(list(endpoint = "binary", n_t = as.integer(round(n_t)), + n_c = as.integer(round(n_c)), prior_t = prior_t, + prior_c = prior_c, criterion = criterion, + external_t = external_t, external_c = external_c, + hypothetical_c = hypothetical_c, fixed_c = fixed_c, + control = control), + class = c("qdm_design_binary", "qdm_design")) +} diff --git a/R/design_binary2.R b/R/design_binary2.R new file mode 100644 index 0000000..4d85a33 --- /dev/null +++ b/R/design_binary2.R @@ -0,0 +1,135 @@ +#' Design with two binary endpoints +#' +#' Specifies a proof-of-concept study with two binary endpoints: the sample +#' sizes, the Dirichlet prior distributions, the external data, the form of +#' the control group, the decision criterion for two endpoints and the +#' computation settings. The design is used by \code{\link{qdm_decide}}, +#' \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +#' +#' The responses of a subject on the two endpoints fall into one of the four +#' cells \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"} (first digit: +#' endpoint 1), whose probabilities have Dirichlet prior distributions in each +#' group (Yamaguchi et al., submitted, Appendix A.1). The treatment effects +#' are the differences of the marginal response rates, +#' \eqn{\theta_k = \pi_{tk} - \pi_{ck}} with \eqn{\pi_1 = p_{10} + p_{11}} and +#' \eqn{\pi_2 = p_{01} + p_{11}}. External data with counts \eqn{x_e} enter +#' through a power prior with weight \eqn{a_0}, which adds \eqn{a_0 x_e} to the +#' Dirichlet parameters. The control group takes one of four forms, as in +#' \code{\link{design_binary}}: a concurrent control group (\code{n_c} of at +#' least 1), external control data only (\code{n_c = 0} and +#' \code{external_c}), a hypothetical control (\code{n_c = 0} and +#' \code{hypothetical_c} created from \code{\link{data_binary2}}, whose counts +#' are added to \code{prior_c}; the hypothetical control distribution +#' Dir(beta) of Yamaguchi et al., Appendix A.1.6, is obtained with +#' \code{prior_c = prior_dirichlet(beta - counts)}), or a fixed control +#' (\code{n_c = 0} and \code{fixed_c}, the known response rates of the two +#' endpoints in the control group; \code{prior_c} must then be \code{NULL}). +#' With a fixed control, the posterior probabilities are estimated from draws +#' of the treatment distribution only, and the future effects of the +#' predictive criterion are \eqn{S_{tk} / m_t - \pi_{ck}} (a future effect +#' that differs from the null value by less than \eqn{10^{-10}} is treated as +#' equal to it; \code{m_c} is not used). +#' +#' The posterior probabilities of the regions (posterior criteria) are +#' estimated by Monte Carlo simulation with \code{nMC} draws from the +#' Dirichlet posterior distributions. The posterior predictive probabilities +#' (predictive criteria) are computed exactly: the future effects depend only +#' on the numbers of responders on each endpoint, whose joint distribution in +#' each group is obtained from the Dirichlet-multinomial distribution, and a +#' future effect equal to a null value is not counted as larger. +#' +#' For \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}, with +#' \code{enumerate = TRUE} all outcomes of the study are enumerated: there are +#' \code{choose(n + 3, 3)} outcomes in a group of \code{n} subjects (286 for +#' \code{n = 10}), and the probabilities of the regions are computed for +#' every pair of treatment and control outcomes, with the same Monte Carlo +#' draws for all pairs. For a posterior criterion the computing time is +#' proportional to the number of pairs times \code{nMC}, and enumeration is +#' limited to 1e7 pairs (for example, 24 subjects in each group). With +#' \code{enumerate = FALSE}, \code{nsim} studies are simulated under each +#' scenario, which is faster for large sample sizes. +#' +#' @param n_t Number of subjects in the treatment group (a whole number of at +#' least 1). +#' @param n_c Number of subjects in the concurrent control group (a whole +#' number of at least 0). +#' @param prior_t,prior_c Dirichlet prior distributions of the four cell +#' probabilities of the treatment and control groups, created by +#' \code{\link{prior_dirichlet}}. \code{prior_c} must be \code{NULL} (the +#' default) for a fixed control and is required otherwise. +#' @param criterion Decision criterion for two endpoints, created by +#' \code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}. +#' @param external_t,external_c External data of the treatment and control +#' groups, created by \code{\link{borrow}} with +#' \code{\link{data_binary2}}, or \code{NULL} (no external data). +#' @param hypothetical_c Hypothetical control, created by +#' \code{\link{hypothetical}} with \code{\link{data_binary2}}, or +#' \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param fixed_c Fixed control response rates of endpoints 1 and 2, a numeric +#' vector of length 2 with values from 0 to 1, or \code{NULL}. It can be +#' used only when \code{n_c = 0}. +#' @param nMC Number of Monte Carlo draws for posterior probabilities. +#' @param enumerate Logical; if \code{TRUE} (the default), the operating +#' characteristics are computed by enumerating all outcomes, otherwise by +#' simulation. +#' +#' @return An object of class \code{c("qdm_design_binary2", "qdm_design")}, +#' a list with the arguments and the element \code{control} +#' (\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +#' \code{"fixed"}). +#' +#' @references +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' @family designs +#' @examples +#' # Case study 1 of Yamaguchi et al. (submitted), with a small nMC for speed +#' des <- design_binary2( +#' n_t = 10, n_c = 10, +#' prior_t = prior_dirichlet(rep(0.25, 4)), +#' prior_c = prior_dirichlet(rep(0.25, 4)), +#' criterion = criterion_posterior(theta_tv = c(0.15, 0.15), +#' theta_mav = c(0.10, 0.10), +#' gamma_go = 0.263, gamma_nogo = 0.347), +#' nMC = 2000 +#' ) +#' des +#' qdm_decide(des, data_t = data_binary2(c(3, 2, 2, 3)), +#' data_c = data_binary2(c(6, 2, 1, 1)), seed = 1) +#' @export +design_binary2 <- function(n_t, n_c, prior_t, prior_c = NULL, criterion, + external_t = NULL, external_c = NULL, + hypothetical_c = NULL, fixed_c = NULL, + nMC = 10000L, enumerate = TRUE) { + check_numeric(n_t, "n_t", lower = 1, integer = TRUE) + check_numeric(n_c, "n_c", lower = 0, integer = TRUE) + check_prior_dirichlet(prior_t, "prior_t") + if (!inherits(criterion, "qdm_criterion") || criterion$n_endpoints != 2L) { + stop(paste("'criterion' must be created by criterion_posterior() or", + "criterion_predictive() for two endpoints."), call. = FALSE) + } + check_external_binary2(external_t, "external_t") + check_external_binary2(external_c, "external_c") + if (!is.null(hypothetical_c) && + (!inherits(hypothetical_c, "qdm_hypothetical") || + !inherits(hypothetical_c$data, "qdm_data_binary2"))) { + stop(paste("'hypothetical_c' must be NULL or created by hypothetical()", + "with data_binary2()."), call. = FALSE) + } + fixed_c <- check_fixed_c(fixed_c, 2L, probability = TRUE) + control <- control_form(n_c, external_c, hypothetical_c, fixed_c) + check_prior_control(prior_c, control, check_prior_dirichlet) + check_numeric(nMC, "nMC", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + check_flag(enumerate, "enumerate") + structure(list(endpoint = "binary2", n_t = as.integer(round(n_t)), + n_c = as.integer(round(n_c)), prior_t = prior_t, + prior_c = prior_c, criterion = criterion, + external_t = external_t, external_c = external_c, + hypothetical_c = hypothetical_c, fixed_c = fixed_c, + control = control, nMC = as.integer(round(nMC)), + enumerate = enumerate), + class = c("qdm_design_binary2", "qdm_design")) +} diff --git a/R/design_continuous.R b/R/design_continuous.R new file mode 100644 index 0000000..432f115 --- /dev/null +++ b/R/design_continuous.R @@ -0,0 +1,198 @@ +#' Design with one continuous endpoint +#' +#' Specifies a proof-of-concept study with one normally distributed endpoint: +#' the sample sizes, the prior distributions, the external data, the form of +#' the control group, the decision criterion and the method used to compute +#' the probabilities. The design is used by \code{\link{qdm_decide}}, +#' \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +#' +#' The outcomes of group \eqn{k} (\eqn{k = t, c}) follow +#' \eqn{N(\mu_k, \sigma_k^2)}, and the treatment effect is +#' \eqn{\theta = \mu_t - \mu_c}. With the Normal-Inverse-chi-squared prior +#' (\code{\link{prior_nix}}), the posterior distribution of +#' \eqn{(\mu_k, \sigma_k^2)} is Normal-Inverse-chi-squared with parameters +#' \eqn{(\mu_{nk}, \kappa_{nk}, \nu_{nk}, \sigma_{nk}^2)}, and the posterior +#' distribution of the mean is +#' \eqn{t_{\nu_{nk}}(\mu_{nk}, \sigma_{nk}^2 / \kappa_{nk})}. With the vague +#' prior (\code{\link{prior_vague}}) and \eqn{n_k} subjects with sample mean +#' \eqn{\bar y_k} and standard deviation \eqn{s_k}, it is +#' \eqn{t_{n_k - 1}(\bar y_k, s_k^2 / n_k)}. +#' +#' External data enter through a power prior with weight \eqn{a_0}: data with +#' \eqn{n_e} subjects, mean \eqn{\bar y_e} and standard deviation \eqn{s_e} +#' are combined with the prior as if they were \eqn{a_0 n_e} subjects with the +#' same mean and the sum of squares \eqn{a_0 (n_e - 1) s_e^2}. The posterior +#' distribution then has a closed form (Huang et al., submitted). With the +#' vague prior and external data, the posterior distribution of the mean has +#' \eqn{a_0 n_e + n_k - 1} degrees of freedom. +#' +#' The control group takes one of four forms. +#' \describe{ +#' \item{Concurrent control}{\code{n_c} is at least 2. External control +#' data can be added through \code{external_c}.} +#' \item{External control only}{\code{n_c = 0} and \code{external_c} is +#' given. The distribution of \eqn{\mu_c} is the posterior distribution +#' given the external control data. With the vague prior, \eqn{a_0 n_e} +#' must be greater than 1.} +#' \item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +#' given by \code{hypothetical(mean = mu0c, r = r)}. Following Kang et al. +#' (2026, Section 4.2.4), the control mean has the same t distribution as +#' the posterior distribution of the treatment mean, with location +#' \eqn{\mu_{0c}} and squared scale multiplied by \eqn{r}: +#' \eqn{\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 / \kappa_{nt})}. +#' \code{prior_c} is not used and must be \code{NULL}.} +#' \item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +#' control mean is a known value \eqn{\mu_c}, as in a single-arm study +#' compared with a benchmark. The probabilities of the Go and NoGo regions +#' are computed exactly from the t distribution of the treatment mean +#' (posterior) or of the mean of \eqn{m_t} future subjects (posterior +#' predictive), shifted by \eqn{\mu_c}; \code{method}, \code{nMC} and +#' \code{m_c} are not used. \code{prior_c} is not used and must be +#' \code{NULL}.} +#' } +#' +#' For the posterior predictive criterion (\code{\link{criterion_predictive}}), +#' the future effect is the difference between the sample means of \eqn{m_t} +#' and \eqn{m_c} future subjects. The posterior predictive distribution of the +#' mean of \eqn{m} future subjects of a group is +#' \eqn{t_{\nu_{n}}(\mu_{n}, \sigma_{n}^2 (1 / \kappa_{n} + 1 / m))}; for a +#' hypothetical control it is +#' \eqn{t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 (1 / \kappa_{nt} + 1 / m_c))}. +#' +#' The probabilities of the Go and NoGo regions are probabilities of the +#' difference of two t variables, computed by \code{\link{ptdiff}} with the +#' chosen \code{method}. With \code{method = "MC"}, the probabilities of the +#' two regions are estimated from the same \code{nMC} draws. +#' +#' @param n_t Number of subjects in the treatment group (a whole number of at +#' least 2). +#' @param n_c Number of subjects in the concurrent control group: 0 (no +#' concurrent control group) or a whole number of at least 2. +#' @param prior_t,prior_c Prior distributions of the mean and variance of the +#' treatment and control groups, created by \code{\link{prior_nix}} or +#' \code{\link{prior_vague}}. \code{prior_c} must be \code{NULL} (the +#' default) for a hypothetical or fixed control and is required otherwise. +#' @param criterion Decision criterion for one endpoint, created by +#' \code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}. +#' @param external_t,external_c External data of the treatment and control +#' groups, created by \code{\link{borrow}} with +#' \code{\link{data_continuous}}, or \code{NULL} (no external data). +#' @param hypothetical_c Hypothetical control, created by +#' \code{\link{hypothetical}} with \code{mean} (of length 1) and \code{r}, +#' or \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param fixed_c Fixed control mean, a number, or \code{NULL}. It can be used +#' only when \code{n_c = 0}. +#' @param method Method used to compute the probabilities: \code{"NI"} +#' (numerical integration, the default), \code{"MM"} (moment-matching +#' approximation, which requires the distributions of both group means to +#' have more than 4 degrees of freedom) or \code{"MC"} (Monte Carlo +#' simulation). See \code{\link{ptdiff}}. Numerical integration is exact +#' up to a small numerical error but is the slowest of the deterministic +#' methods: for operating characteristics, which need the probabilities for +#' many simulated studies, \code{"MM"} is faster by about two orders of +#' magnitude and is suited to exploring designs, and \code{"NI"} can be +#' used to confirm the chosen design. The computing time of \code{"MC"} is +#' proportional to \code{nMC}. +#' @param nMC Number of Monte Carlo draws for \code{method = "MC"}. +#' +#' @return An object of class \code{c("qdm_design_continuous", "qdm_design")}, +#' a list with the arguments and the element \code{control} +#' (\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +#' \code{"fixed"}). +#' +#' @references +#' Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +#' decision-making framework in cell and gene therapy development for rare +#' diseases. \emph{Journal of Biopharmaceutical Statistics}. +#' \doi{10.1080/10543406.2026.2655410} +#' +#' Huang, Y., Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +#' Conjugate representation of power priors for efficient Bayesian analysis +#' of normal data. +#' +#' @family designs +#' @examples +#' # Concurrent control with external treatment and control data +#' design_continuous( +#' n_t = 12, n_c = 12, +#' prior_t = prior_vague(), prior_c = prior_vague(), +#' criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, +#' gamma_go = 0.6, gamma_nogo = 0.7), +#' external_t = borrow(data_continuous(n = 6, mean = 20, sd = 30), a0 = 0.5), +#' external_c = borrow(data_continuous(n = 30, mean = -12, sd = 20), +#' a0 = 0.4) +#' ) +#' +#' # Uncontrolled study with a hypothetical control +#' design_continuous( +#' n_t = 12, n_c = 0, prior_t = prior_vague(), +#' criterion = criterion_predictive(theta_null = 0, m_t = 50, +#' gamma_go = 0.9, gamma_nogo = 0.7), +#' hypothetical_c = hypothetical(mean = -10, r = 1), +#' method = "MM" +#' ) +#' +#' # Single-arm study compared with a fixed control mean of -10 +#' design_continuous( +#' n_t = 12, n_c = 0, prior_t = prior_vague(), +#' criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, +#' gamma_go = 0.6, gamma_nogo = 0.7), +#' fixed_c = -10 +#' ) +#' @export +design_continuous <- function(n_t, n_c, prior_t, prior_c = NULL, criterion, + external_t = NULL, external_c = NULL, + hypothetical_c = NULL, fixed_c = NULL, + method = c("NI", "MM", "MC"), nMC = 10000L) { + check_numeric(n_t, "n_t", lower = 2, integer = TRUE) + check_numeric(n_c, "n_c", lower = 0, integer = TRUE) + if (round(n_c) == 1) { + stop("'n_c' must be 0 or a whole number of at least 2.", call. = FALSE) + } + check_prior_continuous(prior_t, "prior_t") + if (!inherits(criterion, "qdm_criterion") || criterion$n_endpoints != 1L) { + stop(paste("'criterion' must be created by criterion_posterior() or", + "criterion_predictive() for one endpoint."), call. = FALSE) + } + check_external_continuous(external_t, "external_t") + check_external_continuous(external_c, "external_c") + if (!is.null(hypothetical_c) && + (!inherits(hypothetical_c, "qdm_hypothetical") || + hypothetical_c$type != "location" || + length(hypothetical_c$mean) != 1L)) { + stop(paste("'hypothetical_c' must be NULL or created by hypothetical()", + "with 'mean' of length 1 and 'r'."), call. = FALSE) + } + fixed_c <- check_fixed_c(fixed_c, 1L, probability = FALSE) + control <- control_form(n_c, external_c, hypothetical_c, fixed_c) + check_prior_control(prior_c, control, check_prior_continuous, + unused = c("hypothetical", "fixed")) + method <- match.arg(method) + check_numeric(nMC, "nMC", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + des <- structure(list(endpoint = "continuous", + n_t = as.integer(round(n_t)), + n_c = as.integer(round(n_c)), prior_t = prior_t, + prior_c = prior_c, criterion = criterion, + external_t = external_t, external_c = external_c, + hypothetical_c = hypothetical_c, fixed_c = fixed_c, + control = control, method = method, + nMC = as.integer(round(nMC))), + class = c("qdm_design_continuous", "qdm_design")) + if (control == "fixed") { + # The probabilities are computed exactly, whatever the method + return(des) + } + # Degrees of freedom of the distributions of the group means for the + # sample sizes of the design (they do not depend on the data values) + post_t <- posterior_continuous(prior_t, des$n_t, external = external_t) + post_c <- control_posterior_continuous(des, post_t, des$n_c) + if (post_c$nu <= 0) { + stop(paste("With prior_vague() for the control group and external", + "control data only, 'a0' times the number of external", + "subjects must be greater than 1, so that the distribution", + "of the control mean is proper."), call. = FALSE) + } + check_df_mm(post_t$nu, post_c$nu, method) + des +} diff --git a/R/design_continuous2.R b/R/design_continuous2.R new file mode 100644 index 0000000..5ba4f77 --- /dev/null +++ b/R/design_continuous2.R @@ -0,0 +1,182 @@ +#' Design with two continuous endpoints +#' +#' Specifies a proof-of-concept study with two continuous endpoints: the +#' sample sizes, the prior distributions, the external data, the form of the +#' control group, the decision criterion for two endpoints and the method +#' used to compute the probabilities. The design is used by +#' \code{\link{qdm_decide}}, \code{\link{qdm_oc}} and +#' \code{\link{qdm_calibrate}}. +#' +#' The responses of a subject on the two endpoints have a bivariate normal +#' distribution with mean vector \eqn{\mu_k} and covariance matrix +#' \eqn{\Sigma_k} in group \eqn{k} (Yamaguchi et al., submitted, Appendix +#' A.2). The prior distribution of \eqn{(\mu_k, \Sigma_k)} is +#' Normal-Inverse-Wishart (\code{\link{prior_niw}}) or vague +#' (\code{\link{prior_vague}}, the density \eqn{|\Sigma_k|^{-3/2}}). External +#' data enter through a power prior with weight \eqn{a_0}, which has the +#' conjugate form, and the posterior parameters are updated with the external +#' data and then with the current data. The vague prior corresponds to +#' \eqn{\kappa_0 = 0}, \eqn{\nu_0 = -1} and \eqn{\Lambda_0 = 0}, so the +#' posterior distribution of the mean is +#' \eqn{t_{n - 2}(\bar y, S / (n (n - 2)))} without external data, where +#' \eqn{S} is the matrix of sums of squares and cross-products, \eqn{n - 1} +#' times the sample covariance matrix (Yamaguchi et al., submitted, +#' equation A.9). +#' +#' The treatment effects are the differences of the means, +#' \eqn{\theta_k = \mu_{tk} - \mu_{ck}}. The mean of each group has a +#' bivariate t distribution with \eqn{\nu_n - 1} degrees of freedom, +#' location \eqn{\mu_n} and scale matrix +#' \eqn{\Lambda_n / (\kappa_n (\nu_n - 1))}. For a predictive criterion, +#' the mean of \eqn{m} future subjects has the same distribution with the +#' scale matrix \eqn{(1 / \kappa_n + 1 / m) \Lambda_n / (\nu_n - 1)}, +#' because the future subjects share the same mean and covariance matrix +#' (version 0.1.0 and Yamaguchi et al. used the scale matrix +#' \eqn{(1 + \kappa_n) \Lambda_n / (\kappa_n (\nu_n - 1) m)}, which treats +#' them as independent draws from the predictive distribution of one +#' subject). A hypothetical control (\code{hypothetical(mean = c(m1, m2), +#' r = r)}) gives the control mean the distribution of the treatment mean +#' with location \code{mean} and the scale matrix multiplied by \code{r} +#' (Yamaguchi et al., Section A.2.6, with the hyperparameters of the +#' treatment group). With external control data only (\code{n_c = 0} and +#' \code{external_c}) and the vague prior, \eqn{a_0 n_e} must be greater +#' than 2. A fixed control (\code{n_c = 0} and \code{fixed_c}, the known +#' control means of the two endpoints) shifts the distribution of the +#' treatment mean, so the effect has a bivariate t distribution and the +#' probabilities of the regions are computed exactly from its distribution +#' function; \code{method}, \code{nMC} and \code{m_c} are then not used, +#' and \code{prior_c} must be \code{NULL}. +#' +#' The probabilities of the regions are computed by one of two methods: +#' \describe{ +#' \item{\code{"MM"}}{moment-matching approximation: the effect is +#' approximated by a bivariate t distribution with the same mean, +#' covariance matrix and radial fourth moment (Yamaguchi, Homma, Takeda +#' and Maruo, submitted, Theorem 3), whose rectangle +#' probabilities are computed by numerical integration for real degrees +#' of freedom. It requires more than 4 degrees of freedom for both +#' groups and is the fastest method.} +#' \item{\code{"MC"}}{Monte Carlo simulation with \code{nMC} draws from +#' each distribution; the probabilities of all regions are estimated +#' from the same draws. The computing time is proportional to +#' \code{nMC}, so \code{"MM"} is much faster for operating +#' characteristics, which need the probabilities for many simulated +#' studies.} +#' } +#' +#' The operating characteristics are computed by simulating the sample means +#' and the sums of squares and cross-products of \code{nsim} studies (see +#' \code{\link{qdm_oc}}). +#' +#' @param n_t Number of subjects in the treatment group (a whole number of at +#' least 3). +#' @param n_c Number of subjects in the concurrent control group: 0 or a +#' whole number of at least 3. +#' @param prior_t,prior_c Prior distributions of the treatment and control +#' groups, created by \code{\link{prior_niw}} or \code{\link{prior_vague}}. +#' For a hypothetical or fixed control, \code{prior_c} must be \code{NULL} +#' (the default). +#' @param criterion Decision criterion for two endpoints, created by +#' \code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}. +#' @param external_t,external_c External data of the treatment and control +#' groups, created by \code{\link{borrow}} with +#' \code{\link{data_continuous2}}, or \code{NULL} (no external data). +#' @param hypothetical_c Hypothetical control, created by +#' \code{\link{hypothetical}} with \code{mean} of length 2 and \code{r}, +#' or \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param fixed_c Fixed control means of endpoints 1 and 2, a numeric vector +#' of length 2, or \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param method Method used to compute the probabilities: \code{"MM"} +#' (default) or \code{"MC"}. +#' @param nMC Number of Monte Carlo draws for \code{method = "MC"}. +#' +#' @return An object of class \code{c("qdm_design_continuous2", +#' "qdm_design")}, a list with the arguments and the element +#' \code{control} (\code{"concurrent"}, \code{"external"}, +#' \code{"hypothetical"} or \code{"fixed"}). +#' +#' @references +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +#' Moment-matching approximation for t-differences in clinical trials with +#' continuous endpoints. +#' +#' @family designs +#' @examples +#' # Case study 2 of Yamaguchi et al. (submitted) +#' L0 <- matrix(c(80^2, 15, 15, 6^2), 2, 2) +#' des <- design_continuous2( +#' n_t = 30, n_c = 30, +#' prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), +#' prior_c = prior_niw(mu0 = c(-10, -1), kappa0 = 0.1, nu0 = 4, +#' Lambda0 = L0), +#' criterion = criterion_posterior(theta_tv = c(10, 2), +#' theta_mav = c(5, 1), +#' gamma_go = 0.296, gamma_nogo = 0.244) +#' ) +#' des +#' qdm_decide(des, +#' data_t = data_continuous2(30, c(5, 2), +#' matrix(c(6400, 190, 190, 36), 2, 2)), +#' data_c = data_continuous2(30, c(-10, -1), +#' matrix(c(5600, 150, 150, 42), 2, 2))) +#' @export +design_continuous2 <- function(n_t, n_c, prior_t, prior_c = NULL, criterion, + external_t = NULL, external_c = NULL, + hypothetical_c = NULL, fixed_c = NULL, + method = c("MM", "MC"), nMC = 10000L) { + check_numeric(n_t, "n_t", lower = 3, integer = TRUE) + check_numeric(n_c, "n_c", lower = 0, integer = TRUE) + if (round(n_c) %in% c(1, 2)) { + stop("'n_c' must be 0 or a whole number of at least 3.", call. = FALSE) + } + check_prior_continuous2(prior_t, "prior_t") + if (!inherits(criterion, "qdm_criterion") || criterion$n_endpoints != 2L) { + stop(paste("'criterion' must be created by criterion_posterior() or", + "criterion_predictive() for two endpoints."), call. = FALSE) + } + check_external_continuous2(external_t, "external_t") + check_external_continuous2(external_c, "external_c") + if (!is.null(hypothetical_c) && + (!inherits(hypothetical_c, "qdm_hypothetical") || + hypothetical_c$type != "location" || + length(hypothetical_c$mean) != 2L)) { + stop(paste("'hypothetical_c' must be NULL or created by hypothetical()", + "with 'mean' of length 2 and 'r'."), call. = FALSE) + } + fixed_c <- check_fixed_c(fixed_c, 2L, probability = FALSE) + control <- control_form(n_c, external_c, hypothetical_c, fixed_c) + check_prior_control(prior_c, control, check_prior_continuous2, + unused = c("hypothetical", "fixed")) + method <- match.arg(method) + check_numeric(nMC, "nMC", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + des <- structure(list(endpoint = "continuous2", + n_t = as.integer(round(n_t)), + n_c = as.integer(round(n_c)), prior_t = prior_t, + prior_c = prior_c, criterion = criterion, + external_t = external_t, external_c = external_c, + hypothetical_c = hypothetical_c, fixed_c = fixed_c, + control = control, method = method, + nMC = as.integer(round(nMC))), + class = c("qdm_design_continuous2", "qdm_design")) + if (control == "fixed") { + # The probabilities are computed exactly, whatever the method + return(des) + } + # Degrees of freedom of the distributions of the group means for the + # sample sizes of the design (they do not depend on the data values) + post_t <- posterior_continuous2(prior_t, des$n_t, external = external_t) + post_c <- control_posterior_continuous2(des, post_t, des$n_c) + if (post_c$nu <= 1) { + stop(paste("With prior_vague() for the control group and external", + "control data only, 'a0' times the number of external", + "subjects must be greater than 2, so that the distribution", + "of the control mean is proper."), call. = FALSE) + } + check_df_mm(post_t$nu - 1, post_c$nu - 1, method, "method = \"MC\"") + des +} diff --git a/R/design_tte.R b/R/design_tte.R new file mode 100644 index 0000000..67fa7c1 --- /dev/null +++ b/R/design_tte.R @@ -0,0 +1,182 @@ +#' Design with one time-to-event endpoint +#' +#' Specifies a proof-of-concept study with one time-to-event endpoint +#' evaluated by the milestone survival probability: the sample sizes, the +#' prior distributions, the external data, the form of the control group, +#' the decision criterion, the milestone time and the conduct of the study. +#' The design is used by \code{\link{qdm_decide}}, \code{\link{qdm_oc}}, +#' \code{\link{qdm_calibrate}} and \code{\link{qdm_boundary}}. +#' +#' The event times of group \eqn{k} (\eqn{k = t, c}) are exponential with +#' hazard \eqn{\lambda_k}, which has a Gamma prior distribution +#' (\code{\link{prior_gamma}}). The data of a group are summarized by the +#' number of events \eqn{d} and the total observed time \eqn{E} +#' (\code{\link{data_tte}}), and the posterior distribution of the hazard is +#' Gamma with shape \eqn{a + d} and rate \eqn{b + E}. External data enter +#' through a power prior with weight \eqn{a_0}, which adds \eqn{a_0 d_e} to the +#' shape and \eqn{a_0 E_e} to the rate. The treatment effect is the +#' difference of the milestone survival probabilities at time +#' \eqn{t_0 = } \code{milestone}, +#' \eqn{\theta = S_t(t_0) - S_c(t_0)} with \eqn{S_k(t_0) = \exp(-\lambda_k t_0)}. +#' +#' The control group takes one of four forms. +#' \describe{ +#' \item{Concurrent control}{\code{n_c} is at least 1. External control +#' data can be added through \code{external_c}.} +#' \item{External control only}{\code{n_c = 0} and \code{external_c} is +#' given. The distribution of \eqn{\lambda_c} is the posterior +#' distribution given the external control data.} +#' \item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +#' given by \code{hypothetical(data_tte(events, exposure))}, whose events +#' and total observed time are added to \code{prior_c}.} +#' \item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +#' control milestone survival probability is a known value, as in a +#' single-arm study compared with a benchmark (\code{fixed_c = 0} makes +#' the effect the treatment milestone survival itself). \code{prior_c} +#' is not used and must be \code{NULL}.} +#' } +#' +#' Posterior probabilities of the Go and NoGo regions are computed exactly +#' for a fixed control (from the Gamma distribution of \eqn{\lambda_t}) and by +#' numerical integration otherwise (see \code{\link{psurvdiff}}). +#' +#' For the posterior predictive criterion (\code{\link{criterion_predictive}}), +#' a future study with \code{m_t} treatment and \code{m_c} control subjects +#' (no control group for a fixed control) is conducted as specified by +#' \code{conduct_future}. The milestone survival of each group in the future +#' study is estimated by \eqn{\exp(-t_0 (a + d) / (b + E))}, the value at the +#' posterior mean of the hazard given the future data alone with the prior +#' \eqn{(a, b)} of the group (\code{prior_t} or \code{prior_c}); with a weak +#' prior this is close to the maximum likelihood estimate and remains +#' defined when the future study has no events. The future effect is the +#' difference of the two estimates (or the treatment estimate minus the +#' fixed value). The predictive probabilities are estimated by simulating +#' \code{nMC} future studies, each with hazards drawn from the posterior +#' distributions given the proof-of-concept data (see +#' \code{\link{conduct_tte}} for the simulation of a study). They are +#' therefore Monte Carlo estimates, and their computing time is proportional +#' to \code{nMC} times the number of future subjects. +#' +#' The operating characteristics (\code{\link{qdm_oc}}, +#' \code{\link{qdm_calibrate}}) are computed by simulating \code{nsim} +#' studies conducted as specified by \code{conduct}, with exponential event +#' times whose hazards are given by the median survival times of the +#' scenarios. With a predictive criterion, every simulated study requires +#' \code{nMC} simulated future studies, so small values of \code{nsim} and +#' \code{nMC} are advisable for exploration. +#' +#' @param n_t Number of subjects in the treatment group (a whole number of at +#' least 1). +#' @param n_c Number of subjects in the concurrent control group (a whole +#' number of at least 0). +#' @param prior_t,prior_c Gamma prior distributions of the hazards of the +#' treatment and control groups, created by \code{\link{prior_gamma}}. +#' \code{prior_c} must be \code{NULL} (the default) for a fixed control and +#' is required otherwise. +#' @param criterion Decision criterion for one endpoint, created by +#' \code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}, +#' with thresholds on the scale of the milestone survival difference (or +#' of the milestone survival itself with \code{fixed_c = 0}). +#' @param milestone Milestone time \eqn{t_0} (positive), in the same unit as +#' the total observed time of the data. +#' @param conduct Conduct of the study, created by \code{\link{conduct_tte}}, +#' used to simulate studies for the operating characteristics; \code{NULL} +#' (the default) if they are not needed. With an analysis at an event +#' (\code{cut_events}), the number of events must not exceed the number of +#' subjects (\code{n_t} plus \code{n_c}). +#' @param external_t,external_c External data of the treatment and control +#' groups, created by \code{\link{borrow}} with \code{\link{data_tte}}, or +#' \code{NULL} (no external data). +#' @param hypothetical_c Hypothetical control, created by +#' \code{\link{hypothetical}} with \code{\link{data_tte}}, or \code{NULL}. +#' It can be used only when \code{n_c = 0}. +#' @param fixed_c Fixed control milestone survival probability, a number from +#' 0 to 1, or \code{NULL}. It can be used only when \code{n_c = 0}. +#' @param conduct_future Conduct of the future study for a predictive +#' criterion, created by \code{\link{conduct_tte}}; by default the same as +#' \code{conduct}. Required for a predictive criterion. With an analysis +#' at an event, the number of events must not exceed the number of future +#' subjects. +#' @param nMC Number of simulated future studies for posterior predictive +#' probabilities. +#' +#' @return An object of class \code{c("qdm_design_tte", "qdm_design")}, a +#' list with the arguments and the element \code{control} +#' (\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +#' \code{"fixed"}). +#' +#' @family designs +#' @examples +#' # Single-arm study compared with a fixed control 3-month survival of 0.72 +#' des <- design_tte( +#' n_t = 30, n_c = 0, prior_t = prior_gamma(0.1, 1), +#' criterion = criterion_posterior(theta_tv = 0.15, theta_mav = 0, +#' gamma_go = 0.6, gamma_nogo = 0.8), +#' milestone = 3, +#' conduct = conduct_tte(accrual_time = c(0, 5, 10, 15), +#' accrual_rate = c(0.4, 2, 4.5), +#' dropout_hazard = 0.00226, cut_time = 15.44), +#' fixed_c = 0.72 +#' ) +#' des +#' qdm_decide(des, data_t = data_tte(events = 6, exposure = 150)) +#' +#' # Concurrent control +#' design_tte( +#' n_t = 30, n_c = 30, prior_t = prior_gamma(0.1, 1), +#' prior_c = prior_gamma(0.1, 1), +#' criterion = criterion_posterior(theta_tv = 0.15, theta_mav = 0, +#' gamma_go = 0.6, gamma_nogo = 0.8), +#' milestone = 3, +#' conduct = conduct_tte(accrual_time = c(0, 12), cut_events = 25) +#' ) +#' @export +design_tte <- function(n_t, n_c, prior_t, prior_c = NULL, criterion, + milestone, conduct = NULL, external_t = NULL, + external_c = NULL, hypothetical_c = NULL, + fixed_c = NULL, conduct_future = conduct, + nMC = 10000L) { + check_numeric(n_t, "n_t", lower = 1, integer = TRUE) + check_numeric(n_c, "n_c", lower = 0, integer = TRUE) + check_prior_gamma(prior_t, "prior_t") + if (!inherits(criterion, "qdm_criterion") || criterion$n_endpoints != 1L) { + stop(paste("'criterion' must be created by criterion_posterior() or", + "criterion_predictive() for one endpoint."), call. = FALSE) + } + check_numeric(milestone, "milestone", lower = 0, lower_open = TRUE) + check_external_tte(external_t, "external_t") + check_external_tte(external_c, "external_c") + if (!is.null(hypothetical_c) && + (!inherits(hypothetical_c, "qdm_hypothetical") || + !inherits(hypothetical_c$data, "qdm_data_tte"))) { + stop(paste("'hypothetical_c' must be NULL or created by hypothetical()", + "with data_tte()."), call. = FALSE) + } + fixed_c <- check_fixed_c(fixed_c, 1L, probability = TRUE) + control <- control_form(n_c, external_c, hypothetical_c, fixed_c) + check_prior_control(prior_c, control, check_prior_gamma) + n_t <- as.integer(round(n_t)) + n_c <- as.integer(round(n_c)) + check_conduct(conduct, "conduct", n_t + n_c, allow_null = TRUE) + if (criterion$type == "predictive") { + if (is.null(conduct_future)) { + stop(paste("A predictive criterion needs 'conduct_future' (or", + "'conduct'), the conduct of the future study."), + call. = FALSE) + } + n_future <- criterion$m_t + if (control == "fixed") 0L else criterion$m_c + check_conduct(conduct_future, "conduct_future", n_future) + } else { + conduct_future <- NULL + } + check_numeric(nMC, "nMC", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + structure(list(endpoint = "tte", n_t = n_t, n_c = n_c, prior_t = prior_t, + prior_c = prior_c, criterion = criterion, + milestone = milestone, conduct = conduct, + external_t = external_t, external_c = external_c, + hypothetical_c = hypothetical_c, fixed_c = fixed_c, + control = control, conduct_future = conduct_future, + nMC = as.integer(round(nMC))), + class = c("qdm_design_tte", "qdm_design")) +} diff --git a/R/dmultinom_counts.R b/R/dmultinom_counts.R new file mode 100644 index 0000000..e52f293 --- /dev/null +++ b/R/dmultinom_counts.R @@ -0,0 +1,20 @@ +#' Multinomial probabilities of count vectors +#' +#' @param x Integer matrix of counts with one row per outcome; all rows have +#' the same total. +#' @param p Numeric vector of cell probabilities (summing to 1); a vector of +#' missing values gives missing probabilities. +#' +#' @return A numeric vector with one probability per row of \code{x}. Cells +#' with probability 0 contribute a factor 1 if their count is 0 and make the +#' probability 0 otherwise. +#' @noRd +dmultinom_counts <- function(x, p) { + if (anyNA(p)) { + return(rep(NA_real_, nrow(x))) + } + n <- sum(x[1L, ]) + terms <- x * rep(log(p), each = nrow(x)) + terms[x == 0L] <- 0 + exp(lgamma(n + 1) - rowSums(lgamma(x + 1)) + rowSums(terms)) +} diff --git a/R/draws_continuous2.R b/R/draws_continuous2.R new file mode 100644 index 0000000..49d6166 --- /dev/null +++ b/R/draws_continuous2.R @@ -0,0 +1,25 @@ +#' Standard random numbers for the simulation of studies with two continuous +#' endpoints +#' +#' Draws the random numbers from which the sufficient statistics of +#' \code{nsim} studies are computed under any scenario (see +#' \code{stats_continuous2()}), so that all scenarios use the same random +#' numbers. They are drawn in the order \code{z1}, \code{z2}, \code{x1}, +#' \code{x2} and \code{z12}. +#' +#' @param nsim Number of simulated studies. +#' @param n Number of subjects (at least 3). +#' +#' @return A list with elements \code{z1}, \code{z2}, \code{z12} (standard +#' normal), \code{x1} (chi-squared with \code{n - 1} degrees of freedom) +#' and \code{x2} (chi-squared with \code{n - 2} degrees of freedom), each +#' of length \code{nsim}. +#' @noRd +draws_continuous2 <- function(nsim, n) { + z1 <- stats::rnorm(nsim) + z2 <- stats::rnorm(nsim) + x1 <- stats::rchisq(nsim, n - 1) + x2 <- stats::rchisq(nsim, n - 2) + z12 <- stats::rnorm(nsim) + list(z1 = z1, z2 = z2, x1 = x1, x2 = x2, z12 = z12) +} diff --git a/R/event_labels.R b/R/event_labels.R new file mode 100644 index 0000000..ea1799c --- /dev/null +++ b/R/event_labels.R @@ -0,0 +1,31 @@ +#' Labels of the Go and NoGo events of a criterion +#' +#' @param criterion An object of class \code{"qdm_criterion"}. +#' @param digits Number of significant digits for numeric values. +#' +#' @return A list with character vectors \code{go} and \code{nogo}, such as +#' \code{"P(theta > 0.2 | data)"}; for two endpoints with a marginal rule, +#' each has one label per endpoint. +#' @noRd +event_labels <- function(criterion, digits = 4L) { + num <- function(x) vapply(x, format_num, character(1), digits = digits) + if (criterion$n_endpoints == 2L && criterion$rule == "joint") { + go <- sprintf("P(regions {%s} | data)", + paste(criterion$go_regions, collapse = ", ")) + nogo <- sprintf("P(regions {%s} | data)", + paste(criterion$nogo_regions, collapse = ", ")) + } else { + # One endpoint: "theta"; two endpoints (marginal rules): "theta1" and + # "theta2" + sym <- if (criterion$n_endpoints == 2L) c("theta1", "theta2") else "theta" + if (criterion$type == "posterior") { + go <- sprintf("P(%s > %s | data)", sym, num(criterion$theta_tv)) + nogo <- sprintf("P(%s <= %s | data)", sym, num(criterion$theta_mav)) + } else { + null <- num(criterion$theta_null) + go <- sprintf("P(future %s > %s | data)", sym, null) + nogo <- sprintf("P(future %s <= %s | data)", sym, null) + } + } + list(go = unname(go), nogo = unname(nogo)) +} diff --git a/R/format.qdm_borrow.R b/R/format.qdm_borrow.R new file mode 100644 index 0000000..f15814e --- /dev/null +++ b/R/format.qdm_borrow.R @@ -0,0 +1,16 @@ +#' Format an external data specification +#' +#' @param x An object of class \code{"qdm_borrow"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character string describing the external data and the power prior +#' weight. +#' +#' @examples +#' format(borrow(data_binary(n = 20, y = 8), a0 = 0.5)) +#' @export +format.qdm_borrow <- function(x, digits = 4L, ...) { + sprintf("%s, a0 = %s", format(x$data, digits = digits), + format(x$a0, digits = digits)) +} diff --git a/R/format.qdm_calibration.R b/R/format.qdm_calibration.R new file mode 100644 index 0000000..cb21253 --- /dev/null +++ b/R/format.qdm_calibration.R @@ -0,0 +1,37 @@ +#' Format a calibration +#' +#' @param x An object of class \code{"qdm_calibration"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character vector with one element per line of the description +#' (without the table of decision probabilities). +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' format(qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), +#' data.frame(pi_t = 0.7, pi_c = 0.4), +#' target_go = 0.05, target_nogo = 0.2)) +#' @export +format.qdm_calibration <- function(x, digits = 4L, ...) { + describe <- function(name, gamma, prob, event, scenario, target) { + if (is.na(gamma)) { + sprintf(" %s: no value in the grid meets the target %s", name, + format_num(target, digits)) + } else { + sprintf(" %s = %s: P(%s criterion met | %s) = %s (target %s)", name, + format_num(gamma, digits), event, scenario, + format_num(prob, digits), format_num(target, digits)) + } + } + c(sprintf("Calibration of the decision thresholds (%s)", x$method), + describe("gamma_go ", x$gamma_go, x$prob_go, "Go", "scenario_go", + x$target_go), + describe("gamma_nogo", x$gamma_nogo, x$prob_nogo, "NoGo", + "scenario_nogo", x$target_nogo)) +} diff --git a/R/format.qdm_conduct.R b/R/format.qdm_conduct.R new file mode 100644 index 0000000..f063f5a --- /dev/null +++ b/R/format.qdm_conduct.R @@ -0,0 +1,34 @@ +#' Format the conduct of a study +#' +#' @param x An object of class \code{"qdm_conduct"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character vector with one element per line of the description. +#' +#' @examples +#' format(conduct_tte(accrual_time = c(0, 12), cut_events = 20)) +#' @export +format.qdm_conduct <- function(x, digits = 4L, ...) { + num <- function(v) format_num(v, digits) + enroll <- if (length(x$accrual_rate) == 1L) { + sprintf("Enrollment: uniform from 0 to %s", num(x$accrual_time[2L])) + } else { + sprintf("Enrollment: piecewise uniform on (%s) with rates (%s)", + num(x$accrual_time), num(x$accrual_rate)) + } + dropout <- if (all(x$dropout_hazard == 0)) { + "Dropout: none" + } else if (length(x$dropout_hazard) == 1L) { + sprintf("Dropout: hazard %s", num(x$dropout_hazard)) + } else { + sprintf("Dropout: hazards (%s) from times (%s)", num(x$dropout_hazard), + num(x$dropout_time)) + } + analysis <- if (is.null(x$cut_time)) { + sprintf("Analysis: at event %d", x$cut_events) + } else { + sprintf("Analysis: at time %s", num(x$cut_time)) + } + c(enroll, dropout, analysis) +} diff --git a/R/format.qdm_criterion.R b/R/format.qdm_criterion.R new file mode 100644 index 0000000..c6266bd --- /dev/null +++ b/R/format.qdm_criterion.R @@ -0,0 +1,44 @@ +#' Format a decision criterion +#' +#' @param x An object of class \code{"qdm_criterion"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character vector with one element per line of the description. +#' +#' @examples +#' format(criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8)) +#' @export +format.qdm_criterion <- function(x, digits = 4L, ...) { + labels <- event_labels(x, digits) + marginal <- x$n_endpoints == 2L && x$rule != "joint" + join <- if (x$rule == "or") " or " else " and " + criteria <- function(lab, gamma) { + paste(sprintf("%s >= %s", lab, + vapply(gamma, format_num, character(1), digits = digits)), + collapse = join) + } + extra <- character(0) + if (x$type == "posterior") { + header <- "Posterior probability criterion" + if (x$n_endpoints == 2L && !marginal) { + extra <- sprintf(" TV = (%s), MAV = (%s)", + format_num(x$theta_tv, digits), + format_num(x$theta_mav, digits)) + } + } else { + header <- sprintf( + "Posterior predictive probability criterion (m_t = %d, m_c = %d)", + x$m_t, x$m_c + ) + if (x$n_endpoints == 2L && !marginal) { + extra <- sprintf(" NULL = (%s)", format_num(x$theta_null, digits)) + } + } + if (marginal) { + header <- sprintf("%s, marginal rule \"%s\"", header, x$rule) + } + c(header, paste0(" Go: ", criteria(labels$go, x$gamma_go)), + paste0(" NoGo: ", criteria(labels$nogo, x$gamma_nogo)), extra) +} diff --git a/R/format.qdm_data.R b/R/format.qdm_data.R new file mode 100644 index 0000000..17736eb --- /dev/null +++ b/R/format.qdm_data.R @@ -0,0 +1,33 @@ +#' Format a data specification +#' +#' @param x An object of class \code{"qdm_data"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character string describing the data. +#' +#' @examples +#' format(data_binary(n = 12, y = 7)) +#' @export +format.qdm_data <- function(x, digits = 4L, ...) { + switch( + class(x)[1L], + qdm_data_binary = sprintf("binary, n = %d, y = %d", x$n, x$y), + qdm_data_continuous = sprintf("continuous, n = %d, mean = %s, sd = %s", + x$n, format(x$mean, digits = digits), + format(x$sd, digits = digits)), + qdm_data_binary2 = sprintf( + "two binary endpoints, n = %d, counts (00, 01, 10, 11) = (%s)", + x$n, paste(x$counts, collapse = ", ") + ), + qdm_data_continuous2 = sprintf( + "two continuous endpoints, n = %d, mean = (%s), cov = (%s; %s)", + x$n, format_num(x$mean, digits), + format_num(x$cov[1L, ], digits), + format_num(x$cov[2L, ], digits) + ), + qdm_data_tte = sprintf("time-to-event, events = %d, exposure = %s", + x$events, format(x$exposure, digits = digits)), + stop("Unknown data class.", call. = FALSE) + ) +} diff --git a/R/format.qdm_decision.R b/R/format.qdm_decision.R new file mode 100644 index 0000000..099bedd --- /dev/null +++ b/R/format.qdm_decision.R @@ -0,0 +1,48 @@ +#' Format a decision +#' +#' @param x An object of class \code{"qdm_decision"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character vector with one element per line of the description. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' format(qdm_decide(des, data_binary(12, 9), data_binary(12, 4))) +#' @export +format.qdm_decision <- function(x, digits = 4L, ...) { + crit <- x$design$criterion + labels <- event_labels(crit, digits) + met <- function(m) if (m) "met" else "not met" + num <- function(v) format_num(v, digits) + describe <- function(name, lab, prob, gamma, met_all) { + if (length(prob) == 1L) { + return(sprintf(" %s %s = %s (threshold %s, %s)", name, lab, num(prob), + num(gamma), met(met_all))) + } + c(sprintf(" %s %s (rule \"%s\")", name, met(met_all), crit$rule), + sprintf(" %s = %s (threshold %s, %s)", lab, vapply(prob, num, ""), + vapply(gamma, num, ""), + vapply(meets_threshold(prob, gamma), met, ""))) + } + out <- c(sprintf("Decision: %s", x$decision), + describe("Go: ", labels$go, x$prob_go, crit$gamma_go, x$met_go), + describe("NoGo:", labels$nogo, x$prob_nogo, crit$gamma_nogo, + x$met_nogo)) + if (!is.null(x$prob_regions)) { + out <- c(out, sprintf("Region probabilities: %s", + paste(names(x$prob_regions), + vapply(x$prob_regions, num, ""), + sep = " = ", collapse = ", "))) + } + c(out, "Posterior distributions", + sprintf(" Treatment: %s", format_posterior(x$design, x$posterior_t, + digits)), + sprintf(" Control: %s", format_posterior(x$design, x$posterior_c, + digits))) +} diff --git a/R/format.qdm_design.R b/R/format.qdm_design.R new file mode 100644 index 0000000..218230a --- /dev/null +++ b/R/format.qdm_design.R @@ -0,0 +1,90 @@ +#' Format a design +#' +#' @param x An object of class \code{"qdm_design"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character vector with one element per line of the description. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' format(des) +#' @export +format.qdm_design <- function(x, digits = 4L, ...) { + endpoint <- switch(x$endpoint, + binary = "one binary endpoint", + continuous = "one continuous endpoint", + binary2 = "two binary endpoints", + continuous2 = "two continuous endpoints", + tte = sprintf(paste("one time-to-event endpoint", + "(milestone survival at t = %s)"), + format_num(x$milestone, digits)), + stop("Unknown design.", call. = FALSE)) + control <- switch(x$control, + concurrent = sprintf("concurrent, n = %d", x$n_c), + external = "external data only", + hypothetical = "hypothetical", + fixed = sprintf("fixed value %s", + if (length(x$fixed_c) == 1L) { + format_num(x$fixed_c, digits) + } else { + sprintf("(%s)", + format_num(x$fixed_c, digits)) + })) + out <- c(sprintf("Design: %s", endpoint), + sprintf(" Treatment: n = %d, prior %s", x$n_t, + format(x$prior_t, digits = digits))) + if (!is.null(x$external_t)) { + out <- c(out, sprintf(" External data: %s", + format(x$external_t, digits = digits))) + } + out <- c(out, if (is.null(x$prior_c)) { + sprintf(" Control: %s", control) + } else { + sprintf(" Control: %s, prior %s", control, + format(x$prior_c, digits = digits)) + }) + if (!is.null(x$external_c)) { + out <- c(out, sprintf(" External data: %s", + format(x$external_c, digits = digits))) + } + if (!is.null(x$hypothetical_c)) { + out <- c(out, sprintf(" Hypothetical control: %s", + format(x$hypothetical_c, digits = digits))) + } + out <- c(out, format(x$criterion, digits = digits)) + fixed <- x$control == "fixed" + if (x$endpoint %in% c("continuous", "continuous2")) { + out <- c(out, sprintf("Probabilities: %s", + method_label(x$method, x$nMC, fixed))) + } + if (x$endpoint == "binary2") { + out <- c(out, + sprintf("Probabilities: %s", + if (x$criterion$type == "posterior") { + method_label("MC", x$nMC) + } else { + "exact computation" + }), + sprintf("Operating characteristics: %s", + if (x$enumerate) "enumeration of all outcomes" else + "simulation")) + } + if (x$endpoint == "tte") { + out <- c(out, sprintf("Probabilities: %s", tte_method_label(x))) + if (!is.null(x$conduct)) { + out <- c(out, "Conduct of the study (operating characteristics):", + paste0(" ", format(x$conduct, digits = digits))) + } + if (x$criterion$type == "predictive") { + out <- c(out, "Conduct of the future study:", + paste0(" ", format(x$conduct_future, digits = digits))) + } + } + out +} diff --git a/R/format.qdm_hypothetical.R b/R/format.qdm_hypothetical.R new file mode 100644 index 0000000..84c14ef --- /dev/null +++ b/R/format.qdm_hypothetical.R @@ -0,0 +1,20 @@ +#' Format a hypothetical control specification +#' +#' @param x An object of class \code{"qdm_hypothetical"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character string describing the hypothetical control. +#' +#' @examples +#' format(hypothetical(mean = 1, r = 1)) +#' @export +format.qdm_hypothetical <- function(x, digits = 4L, ...) { + if (x$type == "data") { + sprintf("data (%s)", format(x$data, digits = digits)) + } else { + sprintf("mean = (%s), r = %s", + format_num(x$mean, digits), + format(x$r, digits = digits)) + } +} diff --git a/R/format.qdm_prior.R b/R/format.qdm_prior.R new file mode 100644 index 0000000..2ea2fc2 --- /dev/null +++ b/R/format.qdm_prior.R @@ -0,0 +1,40 @@ +#' Format a prior specification +#' +#' @param x An object of class \code{"qdm_prior"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return A character string describing the prior distribution. +#' +#' @examples +#' format(prior_beta(0.5, 0.5)) +#' @export +format.qdm_prior <- function(x, digits = 4L, ...) { + switch( + class(x)[1L], + qdm_prior_beta = sprintf("Beta(a = %s, b = %s)", + format(x$a, digits = digits), + format(x$b, digits = digits)), + qdm_prior_dirichlet = sprintf( + "Dirichlet(alpha = (%s))", + format_num(x$alpha, digits) + ), + qdm_prior_nix = sprintf( + "N-Inv-Chisq(mu0 = %s, kappa0 = %s, nu0 = %s, sigma0 = %s)", + format(x$mu0, digits = digits), format(x$kappa0, digits = digits), + format(x$nu0, digits = digits), format(x$sigma0, digits = digits) + ), + qdm_prior_niw = sprintf( + "N-Inv-Wishart(mu0 = (%s), kappa0 = %s, nu0 = %s, Lambda0 = (%s; %s))", + format_num(x$mu0, digits), + format(x$kappa0, digits = digits), format(x$nu0, digits = digits), + format_num(x$Lambda0[1L, ], digits), + format_num(x$Lambda0[2L, ], digits) + ), + qdm_prior_vague = "Vague", + qdm_prior_gamma = sprintf("Gamma(shape = %s, rate = %s)", + format(x$shape, digits = digits), + format(x$rate, digits = digits)), + stop("Unknown prior class.", call. = FALSE) + ) +} diff --git a/R/format_num.R b/R/format_num.R new file mode 100644 index 0000000..f1366fe --- /dev/null +++ b/R/format_num.R @@ -0,0 +1,10 @@ +#' Format numbers as a comma-separated string +#' +#' @param x A numeric vector. +#' @param digits Number of significant digits. +#' +#' @return A single character string. +#' @noRd +format_num <- function(x, digits = 4L) { + paste(format(x, digits = digits, trim = TRUE), collapse = ", ") +} diff --git a/R/format_posterior.R b/R/format_posterior.R new file mode 100644 index 0000000..2f0b299 --- /dev/null +++ b/R/format_posterior.R @@ -0,0 +1,47 @@ +#' Format the parameters of a posterior distribution +#' +#' @param design An object of class \code{"qdm_design"}. +#' @param post Named numeric vector of posterior parameters, or the fixed +#' control value(s) named \code{value} (one endpoint) or \code{value1} and +#' \code{value2} (two endpoints). +#' @param digits Number of significant digits. +#' +#' @return A character string such as \code{"Beta(a = 7.5, b = 5.5)"} for a +#' binary endpoint, or the t distribution of the mean, such as +#' \code{"mean ~ t(df = 11, location = 18, scale = 7.217)"}, for a +#' continuous endpoint, or \code{"Dirichlet(alpha = (2.25, 1.25, 3.25, +#' 4.25))"} for two binary endpoints, or +#' \code{"hazard ~ Gamma(shape = 5.1, rate = 41)"} for a time-to-event +#' endpoint, or \code{"fixed value 0.2"} for a fixed control. +#' @noRd +format_posterior <- function(design, post, digits = 4L) { + if (startsWith(names(post)[1L], "value")) { + return(if (length(post) == 1L) { + sprintf("fixed value %s", format_num(post, digits)) + } else { + sprintf("fixed values (%s)", format_num(post, digits)) + }) + } + switch(design$endpoint, + binary = sprintf("Beta(a = %s, b = %s)", + format_num(post[["a"]], digits), + format_num(post[["b"]], digits)), + continuous = sprintf( + "mean ~ t(df = %s, location = %s, scale = %s)", + format_num(post[["nu"]], digits), format_num(post[["mu"]], digits), + format_num(post[["sigma"]] / sqrt(post[["kappa"]]), digits) + ), + binary2 = sprintf("Dirichlet(alpha = (%s))", + format_num(post, digits)), + continuous2 = { + f <- 1 / (post[["kappa"]] * (post[["nu"]] - 1)) + sprintf("mean ~ t(df = %s, location = (%s), scale = (%s; %s))", + format_num(post[["nu"]] - 1, digits), + format_num(post[c("mu1", "mu2")], digits), + format_num(f * post[c("L11", "L12")], digits), + format_num(f * post[c("L12", "L22")], digits)) + }, + tte = sprintf("hazard ~ Gamma(shape = %s, rate = %s)", + format_num(post[["shape"]], digits), + format_num(post[["rate"]], digits))) +} diff --git a/R/getgamma1bin.R b/R/getgamma1bin.R deleted file mode 100644 index 439ae2c..0000000 --- a/R/getgamma1bin.R +++ /dev/null @@ -1,523 +0,0 @@ -#' Find Optimal Go/NoGo Thresholds for a Single Binary Endpoint -#' -#' Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -#' threshold \eqn{\gamma_{\mathrm{nogo}}} for a single binary endpoint by -#' searching over a grid of candidate values. The two thresholds are -#' calibrated independently under separate scenarios: -#' \itemize{ -#' \item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -#' \code{gamma_grid} such that the marginal Go probability -#' \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} is strictly -#' less than \code{target_go} under the Go-calibration scenario -#' (\code{pi_t_go}, \code{pi_c_go}); typically the Null scenario. -#' \item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -#' \code{gamma_grid} such that the marginal NoGo probability -#' \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} is strictly -#' less than \code{target_nogo} under the NoGo-calibration -#' scenario (\code{pi_t_nogo}, \code{pi_c_nogo}); typically the -#' Alternative scenario. -#' } -#' Here \eqn{g_{\mathrm{Go}} = P(\theta > \theta_{\mathrm{TV}} \mid y_t, y_c)} -#' and \eqn{g_{\mathrm{NoGo}} = P(\theta \le \theta_{\mathrm{MAV}} \mid y_t, y_c)} -#' for \code{prob = 'posterior'}, consistent with the decision rule in -#' \code{\link{pbayesdecisionprob1bin}}. -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param theta_TV A numeric scalar in \code{(-1, 1)} giving the Target Value -#' (TV) threshold for the treatment effect. Required when -#' \code{prob = 'posterior'}; set to \code{NULL} otherwise. -#' @param theta_MAV A numeric scalar in \code{(-1, 1)} giving the Minimum -#' Acceptable Value (MAV) threshold. Must satisfy -#' \code{theta_TV > theta_MAV}. Required when -#' \code{prob = 'posterior'}; set to \code{NULL} otherwise. -#' @param theta_NULL A numeric scalar in \code{(-1, 1)} giving the null -#' hypothesis threshold used for the predictive probability. Required -#' when \code{prob = 'predictive'}; set to \code{NULL} otherwise. -#' @param pi_t_go A numeric scalar in \code{(0, 1)} giving the true treatment -#' response rate under the Go-calibration scenario (typically Null). -#' @param pi_c_go A numeric scalar in \code{(0, 1)} giving the true control -#' response rate under the Go-calibration scenario. Set to \code{NULL} -#' for \code{design = 'uncontrolled'}. -#' @param pi_t_nogo A numeric scalar in \code{(0, 1)} giving the true -#' treatment response rate under the NoGo-calibration scenario -#' (typically Alternative). -#' @param pi_c_nogo A numeric scalar in \code{(0, 1)} giving the true control -#' response rate under the NoGo-calibration scenario. Set to -#' \code{NULL} for \code{design = 'uncontrolled'}. -#' @param target_go A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the marginal Go probability under the Go-calibration scenario. -#' The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -#' satisfying \eqn{\Pr(\mathrm{Go}) < \code{target\_go}}. -#' @param target_nogo A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the marginal NoGo probability under the NoGo-calibration scenario. -#' The optimal \eqn{\gamma_{\mathrm{nogo}}} is the largest grid value -#' satisfying \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the PoC trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. -#' @param a_t A positive numeric scalar giving the first shape parameter of -#' the Beta prior for the treatment group. -#' @param a_c A positive numeric scalar giving the first shape parameter of -#' the Beta prior for the control group. -#' @param b_t A positive numeric scalar giving the second shape parameter of -#' the Beta prior for the treatment group. -#' @param b_c A positive numeric scalar giving the second shape parameter of -#' the Beta prior for the control group. -#' @param z A non-negative integer giving the hypothetical number of -#' responders in the control group. Required when -#' \code{design = 'uncontrolled'}; set to \code{NULL} otherwise. -#' @param m_t A positive integer giving the future sample size for the -#' treatment group. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} otherwise. -#' @param m_c A positive integer giving the future sample size for the -#' control group. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} otherwise. -#' @param ne_t A positive integer giving the number of patients in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param ne_c A positive integer giving the number of patients in the -#' control group of the external data set. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param ye_t A non-negative integer giving the number of responders in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param ye_c A non-negative integer giving the number of responders in the -#' control group of the external data set. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the treatment group. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the control group. Required when -#' \code{design = 'external'}; set to \code{NULL} otherwise. -#' @param gamma_grid A numeric vector of candidate threshold values in -#' \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' -#' @return A list of class \code{getgamma1bin} with the following elements: -#' \describe{ -#' \item{gamma_go}{Optimal Go threshold: the smallest value in -#' \code{gamma_grid} for which \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} -#' under the Go-calibration scenario. -#' \code{NA} if no such value exists.} -#' \item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -#' \code{gamma_grid} for which \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} -#' under the NoGo-calibration scenario. -#' \code{NA} if no such value exists.} -#' \item{PrGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} -#' at the optimal \eqn{\gamma_{\mathrm{go}}} under the Go-calibration -#' scenario. \code{NA} if \code{gamma_go} is \code{NA}.} -#' \item{PrNoGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} -#' at the optimal \eqn{\gamma_{\mathrm{nogo}}} under the NoGo-calibration -#' scenario. \code{NA} if \code{gamma_nogo} is \code{NA}.} -#' \item{target_go}{The value of \code{target_go} supplied by the user.} -#' \item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -#' \item{grid_results}{A data frame with columns \code{gamma_grid}, -#' \code{PrGo_grid} (marginal Go probability under the Go-calibration -#' scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -#' the NoGo-calibration scenario).} -#' } -#' -#' @details -#' The function uses a two-stage precompute-then-sweep strategy: -#' \enumerate{ -#' \item \strong{Precomputation}: All possible outcome pairs -#' \eqn{(y_t, y_c)} are enumerated. For each pair, -#' \code{\link{pbayespostpred1bin}} computes -#' \eqn{g_{\mathrm{Go}}} (\code{lower.tail = FALSE} at -#' \code{theta_TV}) and \eqn{g_{\mathrm{NoGo}}} (\code{lower.tail -#' = TRUE} at \code{theta_MAV}). This step is independent of -#' \eqn{\gamma}. -#' \item \strong{Gamma sweep}: Marginal probabilities are computed as -#' weighted sums of binary indicators over the grid: -#' \eqn{\Pr(\mathrm{Go})} uses \code{w_go} (weights under -#' \code{pi_t_go}, \code{pi_c_go}) and the indicator -#' \eqn{g_{\mathrm{Go}} \ge \gamma}; \eqn{\Pr(\mathrm{NoGo})} -#' uses \code{w_nogo} (weights under \code{pi_t_nogo}, -#' \code{pi_c_nogo}) and the indicator -#' \eqn{g_{\mathrm{NoGo}} \ge \gamma}. -#' } -#' Both \eqn{\Pr(\mathrm{Go})} and \eqn{\Pr(\mathrm{NoGo})} are -#' monotone non-increasing functions of \eqn{\gamma}. The optimal -#' \eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value -#' crossing below \code{target_go}. The optimal -#' \eqn{\gamma_{\mathrm{nogo}}} is also the \emph{smallest} grid value -#' crossing below \code{target_nogo}: a smaller \eqn{\gamma_{\mathrm{nogo}}} -#' makes NoGo harder to trigger (more permissive), so this is the least -#' restrictive threshold that still controls the false NoGo rate. -#' -#' @examples -#' # Example 1: Controlled design, posterior probability -#' # gamma_go : smallest gamma s.t. Pr(Go) < 0.05 under Null (pi_t = pi_c = 0.15) -#' # gamma_nogo: largest gamma s.t. Pr(NoGo) < 0.20 under Alt (pi_t = 0.35, pi_c = 0.15) -#' getgamma1bin( -#' prob = 'posterior', design = 'controlled', -#' theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, -#' pi_t_go = 0.15, pi_c_go = 0.15, -#' pi_t_nogo = 0.35, pi_c_nogo = 0.15, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = NULL, m_c = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 2: Uncontrolled design, posterior probability -#' getgamma1bin( -#' prob = 'posterior', design = 'uncontrolled', -#' theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, -#' pi_t_go = 0.15, pi_c_go = NULL, -#' pi_t_nogo = 0.35, pi_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = 3L, m_t = NULL, m_c = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 3: External design, posterior probability -#' getgamma1bin( -#' prob = 'posterior', design = 'external', -#' theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, -#' pi_t_go = 0.15, pi_c_go = 0.15, -#' pi_t_nogo = 0.35, pi_c_nogo = 0.15, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = NULL, m_c = NULL, -#' ne_t = 15L, ne_c = 15L, ye_t = 6L, ye_c = 4L, -#' alpha0e_t = 0.5, alpha0e_c = 0.5 -#' ) -#' -#' # Example 4: Controlled design, predictive probability -#' getgamma1bin( -#' prob = 'predictive', design = 'controlled', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, -#' pi_t_go = 0.15, pi_c_go = 0.15, -#' pi_t_nogo = 0.35, pi_c_nogo = 0.15, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = 30L, m_c = 30L, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 5: Uncontrolled design, predictive probability -#' getgamma1bin( -#' prob = 'predictive', design = 'uncontrolled', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, -#' pi_t_go = 0.15, pi_c_go = NULL, -#' pi_t_nogo = 0.35, pi_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = 3L, m_t = 30L, m_c = 30L, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 6: External design, predictive probability -#' getgamma1bin( -#' prob = 'predictive', design = 'external', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, -#' pi_t_go = 0.15, pi_c_go = 0.15, -#' pi_t_nogo = 0.35, pi_c_nogo = 0.15, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 12L, n_c = 12L, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = 30L, m_c = 30L, -#' ne_t = 15L, ne_c = 15L, ye_t = 6L, ye_c = 4L, -#' alpha0e_t = 0.5, alpha0e_c = 0.5 -#' ) -#' -#' @importFrom stats dbinom -#' @export -getgamma1bin <- function(prob = 'posterior', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = NULL, - pi_t_go, pi_c_go = NULL, - pi_t_nogo, pi_c_nogo = NULL, - target_go, target_nogo, - n_t, n_c, - a_t, a_c, b_t, b_c, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, - ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01)) { - - # --------------------------------------------------------------------------- - # Input validation - # --------------------------------------------------------------------------- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (prob == 'posterior') { - if (is.null(theta_TV) || is.null(theta_MAV)) { - stop("'theta_TV' and 'theta_MAV' must be non-NULL when prob = 'posterior'") - } - if (!is.numeric(theta_TV) || length(theta_TV) != 1L || is.na(theta_TV) || - theta_TV <= -1 || theta_TV >= 1) { - stop("'theta_TV' must be a single numeric value in (-1, 1)") - } - if (!is.numeric(theta_MAV) || length(theta_MAV) != 1L || is.na(theta_MAV) || - theta_MAV <= -1 || theta_MAV >= 1) { - stop("'theta_MAV' must be a single numeric value in (-1, 1)") - } - if (theta_TV <= theta_MAV) { - stop("'theta_TV' must be strictly greater than 'theta_MAV'") - } - } else { - if (is.null(theta_NULL)) { - stop("'theta_NULL' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(theta_NULL) || length(theta_NULL) != 1L || - is.na(theta_NULL) || theta_NULL <= -1 || theta_NULL >= 1) { - stop("'theta_NULL' must be a single numeric value in (-1, 1)") - } - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - for (nm in c("m_t", "m_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - } - - if (!is.numeric(pi_t_go) || length(pi_t_go) != 1L || is.na(pi_t_go) || - pi_t_go <= 0 || pi_t_go >= 1) { - stop("'pi_t_go' must be a single numeric value in (0, 1)") - } - if (!is.numeric(pi_t_nogo) || length(pi_t_nogo) != 1L || is.na(pi_t_nogo) || - pi_t_nogo <= 0 || pi_t_nogo >= 1) { - stop("'pi_t_nogo' must be a single numeric value in (0, 1)") - } - - if (design != 'uncontrolled') { - if (is.null(pi_c_go) || !is.numeric(pi_c_go) || length(pi_c_go) != 1L || - is.na(pi_c_go) || pi_c_go <= 0 || pi_c_go >= 1) { - stop("'pi_c_go' must be a single numeric value in (0, 1) for controlled or external design") - } - if (is.null(pi_c_nogo) || !is.numeric(pi_c_nogo) || length(pi_c_nogo) != 1L || - is.na(pi_c_nogo) || pi_c_nogo <= 0 || pi_c_nogo >= 1) { - stop("'pi_c_nogo' must be a single numeric value in (0, 1) for controlled or external design") - } - } - - for (nm in c("target_go", "target_nogo")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val >= 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1)")) - } - } - - for (nm in c("n_t", "n_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - - for (nm in c("a_t", "a_c", "b_t", "b_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) { - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - } - - if (design == 'uncontrolled') { - if (is.null(z)) { - stop("'z' must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(z) || length(z) != 1L || is.na(z) || - z != floor(z) || z < 0L) { - stop("'z' must be a single non-negative integer") - } - } - - if (design == 'external') { - for (nm in c("ne_t", "ne_c", "ye_t", "ye_c")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when design = 'external'")) - } - } - if (!is.numeric(ne_t) || length(ne_t) != 1L || is.na(ne_t) || - ne_t != floor(ne_t) || ne_t < 1L) { - stop("'ne_t' must be a single positive integer") - } - if (!is.numeric(ne_c) || length(ne_c) != 1L || is.na(ne_c) || - ne_c != floor(ne_c) || ne_c < 1L) { - stop("'ne_c' must be a single positive integer") - } - if (!is.numeric(ye_t) || length(ye_t) != 1L || is.na(ye_t) || - ye_t != floor(ye_t) || ye_t < 0L || ye_t > ne_t) { - stop("'ye_t' must be a non-negative integer not exceeding 'ne_t'") - } - if (!is.numeric(ye_c) || length(ye_c) != 1L || is.na(ye_c) || - ye_c != floor(ye_c) || ye_c < 0L || ye_c > ne_c) { - stop("'ye_c' must be a non-negative integer not exceeding 'ne_c'") - } - for (nm in c("alpha0e_t", "alpha0e_c")) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val <= 0 || val > 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1]")) - } - } - } - - if (!is.numeric(gamma_grid) || length(gamma_grid) < 1L || - any(is.na(gamma_grid)) || any(gamma_grid <= 0) || any(gamma_grid >= 1)) { - stop("'gamma_grid' must be a numeric vector with all values in (0, 1)") - } - gamma_grid <- sort(unique(gamma_grid)) - - # --------------------------------------------------------------------------- - # Stage 1: Precompute g(y_t, y_c) for all outcome combinations (gamma-free) - # --------------------------------------------------------------------------- - theta0_go <- if (prob == 'posterior') theta_TV else theta_NULL - theta0_nogo <- if (prob == 'posterior') theta_MAV else theta_NULL - - if (design == 'uncontrolled') { - all_y_t <- 0L:n_t - - gPost_Go <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0_go, - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = NULL, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = z, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = FALSE - ) - - gPost_NoGo <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0_nogo, - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = NULL, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = z, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = TRUE - ) - - # Weights for Go calibration (typically Null scenario) - w_go <- dbinom(all_y_t, n_t, pi_t_go) - # Weights for NoGo calibration (typically Alternative scenario) - w_nogo <- dbinom(all_y_t, n_t, pi_t_nogo) - - } else { - grid <- expand.grid(y_t = 0L:n_t, y_c = 0L:n_c) - all_y_t <- grid$y_t - all_y_c <- grid$y_c - - gPost_Go <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0_go, - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = all_y_c, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = NULL, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = FALSE - ) - - gPost_NoGo <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0_nogo, - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = all_y_c, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = NULL, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = TRUE - ) - - # Weights for Go calibration (typically Null scenario) - w_go <- dbinom(all_y_t, n_t, pi_t_go) * dbinom(all_y_c, n_c, pi_c_go) - # Weights for NoGo calibration (typically Alternative scenario) - w_nogo <- dbinom(all_y_t, n_t, pi_t_nogo) * dbinom(all_y_c, n_c, pi_c_nogo) - } - - # --------------------------------------------------------------------------- - # Stage 2: Sweep gamma_grid using vectorised outer comparison - # --------------------------------------------------------------------------- - # Marginal Go criterion: g_Go >= gamma (lower.tail = FALSE -> P(theta > TV)) - # Marginal NoGo criterion: g_NoGo >= gamma (lower.tail = TRUE -> P(theta <= MAV)) - # Both Pr(Go) and Pr(NoGo) are monotone non-increasing in gamma. - go_ind <- outer(gPost_Go, gamma_grid, ">=") # n_outcomes x n_gamma - nogo_ind <- outer(gPost_NoGo, gamma_grid, ">=") # n_outcomes x n_gamma - - PrGo_grid <- colSums(w_go * go_ind) - PrNoGo_grid <- colSums(w_nogo * nogo_ind) - - # --------------------------------------------------------------------------- - # Stage 3: Select optimal gamma values - # --------------------------------------------------------------------------- - # gamma_go : smallest gamma with Pr(Go) < target_go - # -> Pr(Go) is non-increasing; take the first (smallest) gamma crossing below target - # gamma_nogo: smallest gamma with Pr(NoGo) < target_nogo - # -> Pr(NoGo) is non-increasing; a smaller gamma_nogo means NoGo is harder to trigger, - # so the smallest gamma satisfying the constraint is the most permissive threshold - # that still controls false NoGo rate below target_nogo - go_mask <- PrGo_grid < target_go - nogo_mask <- PrNoGo_grid < target_nogo - - idx_go <- which(go_mask) - if (length(idx_go) == 0L) { - gamma_go <- NA_real_ - PrGo_opt <- NA_real_ - } else { - opt1 <- min(idx_go) - gamma_go <- gamma_grid[opt1] - PrGo_opt <- PrGo_grid[opt1] - } - - idx_nogo <- which(nogo_mask) - if (length(idx_nogo) == 0L) { - gamma_nogo <- NA_real_ - PrNoGo_opt <- NA_real_ - } else { - opt2 <- min(idx_nogo) # smallest gamma with Pr(NoGo) < target_nogo - gamma_nogo <- gamma_grid[opt2] - PrNoGo_opt <- PrNoGo_grid[opt2] - } - - # --------------------------------------------------------------------------- - # Build and return result - # --------------------------------------------------------------------------- - result <- list( - gamma_go = gamma_go, - gamma_nogo = gamma_nogo, - PrGo_opt = PrGo_opt, - PrNoGo_opt = PrNoGo_opt, - target_go = target_go, - target_nogo = target_nogo, - grid_results = data.frame( - gamma_grid = gamma_grid, - PrGo_grid = PrGo_grid, - PrNoGo_grid = PrNoGo_grid - ) - ) - - class(result) <- 'getgamma1bin' - return(result) -} diff --git a/R/getgamma1cont.R b/R/getgamma1cont.R deleted file mode 100644 index d2ecbbc..0000000 --- a/R/getgamma1cont.R +++ /dev/null @@ -1,699 +0,0 @@ -#' Find Optimal Go/NoGo Thresholds for a Single Continuous Endpoint -#' -#' Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -#' threshold \eqn{\gamma_{\mathrm{nogo}}} for a single continuous endpoint by -#' searching over a grid of candidate values. The two thresholds are -#' calibrated independently under separate scenarios: -#' \itemize{ -#' \item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -#' \code{gamma_grid} such that the marginal Go probability -#' \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} is strictly -#' less than \code{target_go} under the Go-calibration scenario -#' (\code{mu_t_go}, \code{mu_c_go}, \code{sigma_t_go}, -#' \code{sigma_c_go}); typically the Null scenario. -#' \item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -#' \code{gamma_grid} such that the marginal NoGo probability -#' \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} is -#' strictly less than \code{target_nogo} under the NoGo-calibration -#' scenario (\code{mu_t_nogo}, \code{mu_c_nogo}, \code{sigma_t_nogo}, -#' \code{sigma_c_nogo}); typically the Alternative scenario. -#' } -#' Here \eqn{g_{\mathrm{Go}} = P(\theta > \theta_{\mathrm{TV}} \mid \bar{y}_t, s_t, \bar{y}_c, s_c)} -#' and \eqn{g_{\mathrm{NoGo}} = P(\theta \le \theta_{\mathrm{MAV}} \mid \bar{y}_t, s_t, \bar{y}_c, s_c)} -#' for \code{prob = 'posterior'}, consistent with the decision rule in -#' \code{\link{pbayesdecisionprob1cont}}. -#' -#' @param nsim A positive integer giving the number of Monte Carlo simulation -#' replicates used to approximate the operating characteristics. -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param prior A character string specifying the prior distribution. -#' Must be \code{'vague'} or \code{'N-Inv-Chisq'}. -#' @param CalcMethod A character string specifying the computation method -#' for \code{\link{pbayespostpred1cont}}. -#' Must be \code{'NI'}, \code{'MC'}, or \code{'MM'}. -#' @param theta_TV A numeric scalar giving the Target Value (TV) threshold -#' for the treatment effect. Required when \code{prob = 'posterior'}; -#' set to \code{NULL} otherwise. -#' @param theta_MAV A numeric scalar giving the Minimum Acceptable Value (MAV) -#' threshold. Must satisfy \code{theta_TV > theta_MAV}. Required when -#' \code{prob = 'posterior'}; set to \code{NULL} otherwise. -#' @param theta_NULL A numeric scalar giving the null hypothesis threshold -#' for the predictive probability. Required when -#' \code{prob = 'predictive'}; set to \code{NULL} otherwise. -#' @param nMC A positive integer giving the number of inner Monte Carlo draws -#' passed to \code{\link{pbayespostpred1cont}}. Required when -#' \code{CalcMethod = 'MC'}; set to \code{NULL} otherwise. -#' @param mu_t_go A numeric scalar giving the true mean for the treatment group -#' under the Go-calibration scenario (typically Null). -#' @param mu_c_go A numeric scalar giving the true mean for the control group -#' under the Go-calibration scenario. Set to \code{NULL} for -#' \code{design = 'uncontrolled'}. -#' @param sigma_t_go A positive numeric scalar giving the true standard -#' deviation for the treatment group under the Go-calibration scenario. -#' @param sigma_c_go A positive numeric scalar giving the true standard -#' deviation for the control group under the Go-calibration scenario. -#' Set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param mu_t_nogo A numeric scalar giving the true mean for the treatment -#' group under the NoGo-calibration scenario (typically Alternative). -#' @param mu_c_nogo A numeric scalar giving the true mean for the control -#' group under the NoGo-calibration scenario. Set to \code{NULL} for -#' \code{design = 'uncontrolled'}. -#' @param sigma_t_nogo A positive numeric scalar giving the true standard -#' deviation for the treatment group under the NoGo-calibration scenario. -#' @param sigma_c_nogo A positive numeric scalar giving the true standard -#' deviation for the control group under the NoGo-calibration scenario. -#' Set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param target_go A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the marginal Go probability under the Go-calibration scenario. -#' The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -#' satisfying \eqn{\Pr(\mathrm{Go}) < \code{target\_go}}. -#' @param target_nogo A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the marginal NoGo probability under the NoGo-calibration scenario. -#' The optimal \eqn{\gamma_{\mathrm{nogo}}} is the smallest grid value -#' satisfying \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the PoC trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. Required for -#' \code{design = 'controlled'} or \code{'external'}; set to -#' \code{NULL} for \code{design = 'uncontrolled'}. -#' @param m_t A positive integer giving the future sample size for the -#' treatment group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param m_c A positive integer giving the future sample size for the -#' control group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param kappa0_t A positive numeric scalar giving the prior precision -#' parameter for the treatment group under the N-Inv-Chi-squared prior. -#' Required when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise. -#' @param kappa0_c A positive numeric scalar giving the prior precision -#' parameter for the control group. Required when -#' \code{prior = 'N-Inv-Chisq'} and \code{design != 'uncontrolled'}; -#' set to \code{NULL} otherwise. -#' @param nu0_t A positive numeric scalar giving the prior degrees of freedom -#' for the treatment group under the N-Inv-Chi-squared prior. Required -#' when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise. -#' @param nu0_c A positive numeric scalar giving the prior degrees of freedom -#' for the control group. Required when \code{prior = 'N-Inv-Chisq'} -#' and \code{design != 'uncontrolled'}; set to \code{NULL} otherwise. -#' @param mu0_t A numeric scalar giving the prior mean for the treatment group -#' under the N-Inv-Chi-squared prior. Required when -#' \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise. -#' @param mu0_c A numeric scalar giving the prior mean for the control group -#' (or the fixed hypothetical control mean for uncontrolled design). -#' Required when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} -#' otherwise. -#' @param sigma0_t A positive numeric scalar giving the prior scale parameter -#' for the treatment group under the N-Inv-Chi-squared prior. Required -#' when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise. -#' @param sigma0_c A positive numeric scalar giving the prior scale parameter -#' for the control group. Required when \code{prior = 'N-Inv-Chisq'} -#' and \code{design != 'uncontrolled'}; set to \code{NULL} otherwise. -#' @param r A positive numeric scalar giving the variance ratio -#' \eqn{\sigma_c^2 / \sigma_t^2} used for uncontrolled design. -#' Required when \code{design = 'uncontrolled'}; set to \code{NULL} -#' otherwise. -#' @param ne_t A positive integer giving the number of patients in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'} and external treatment data are -#' available; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the number of patients in the -#' control group of the external data set. Required when -#' \code{design = 'external'} and external control data are available; -#' otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external treatment group data. Required when -#' \code{design = 'external'} and \code{ne_t} is non-NULL; set to -#' \code{NULL} otherwise. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external control group data. Required when -#' \code{design = 'external'} and \code{ne_c} is non-NULL; set to -#' \code{NULL} otherwise. -#' @param bar_ye_t A numeric scalar giving the sample mean of the external -#' treatment group data. Required when \code{ne_t} is non-NULL; set to -#' \code{NULL} otherwise. -#' @param bar_ye_c A numeric scalar giving the sample mean of the external -#' control group data. Required when \code{ne_c} is non-NULL; set to -#' \code{NULL} otherwise. -#' @param se_t A positive numeric scalar giving the sample standard deviation -#' of the external treatment group data. Required when \code{ne_t} is -#' non-NULL; set to \code{NULL} otherwise. -#' @param se_c A positive numeric scalar giving the sample standard deviation -#' of the external control group data. Required when \code{ne_c} is -#' non-NULL; set to \code{NULL} otherwise. -#' @param gamma_grid A numeric vector of candidate threshold values in -#' \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' @param seed A numeric scalar for reproducible random number generation. -#' The Go-calibration simulation uses \code{seed} and the -#' NoGo-calibration simulation uses \code{seed + 1} to ensure -#' independence between the two scenarios. -#' -#' @return A list of class \code{getgamma1cont} with the following elements: -#' \describe{ -#' \item{gamma_go}{Optimal Go threshold: the smallest value in -#' \code{gamma_grid} for which \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} -#' under the Go-calibration scenario. -#' \code{NA} if no such value exists.} -#' \item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -#' \code{gamma_grid} for which \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} -#' under the NoGo-calibration scenario. -#' \code{NA} if no such value exists.} -#' \item{PrGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} -#' at the optimal \eqn{\gamma_{\mathrm{go}}} under the Go-calibration -#' scenario. \code{NA} if \code{gamma_go} is \code{NA}.} -#' \item{PrNoGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} -#' at the optimal \eqn{\gamma_{\mathrm{nogo}}} under the NoGo-calibration -#' scenario. \code{NA} if \code{gamma_nogo} is \code{NA}.} -#' \item{target_go}{The value of \code{target_go} supplied by the user.} -#' \item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -#' \item{grid_results}{A data frame with columns \code{gamma_grid}, -#' \code{PrGo_grid} (marginal Go probability under the Go-calibration -#' scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -#' the NoGo-calibration scenario).} -#' } -#' -#' @details -#' The function uses a two-stage simulate-then-sweep strategy: -#' \enumerate{ -#' \item \strong{Simulation}: \code{nsim} datasets are generated -#' independently for each calibration scenario. For the -#' Go-calibration scenario, standardised residuals are shifted by -#' \code{mu_t_go} and \code{mu_c_go}; for the NoGo-calibration -#' scenario, by \code{mu_t_nogo} and \code{mu_c_nogo}. -#' \code{\link{pbayespostpred1cont}} is called once per scenario to -#' obtain \eqn{g_{\mathrm{Go}}} (\code{lower.tail = FALSE} at -#' \code{theta_TV}) and \eqn{g_{\mathrm{NoGo}}} (\code{lower.tail -#' = TRUE} at \code{theta_MAV}). -#' \item \strong{Gamma sweep}: Marginal probabilities are estimated as the -#' proportion of simulated datasets satisfying the respective -#' indicator: \eqn{g_{\mathrm{Go}} \ge \gamma} for -#' \code{PrGo_grid}, and \eqn{g_{\mathrm{NoGo}} \ge \gamma} for -#' \code{PrNoGo_grid}. Both are monotone non-increasing in -#' \eqn{\gamma}. -#' } -#' The optimal \eqn{\gamma_{\mathrm{go}}} and \eqn{\gamma_{\mathrm{nogo}}} -#' are each the \emph{smallest} grid value crossing below the respective -#' target probability. -#' -#' @examples -#' # Example 1: Controlled design, vague prior, posterior probability -#' # gamma_go : smallest gamma s.t. Pr(Go) < 0.05 under Null (mu_t = mu_c = 1.0) -#' # gamma_nogo: smallest gamma s.t. Pr(NoGo) < 0.20 under Alt (mu_t = 2.5, mu_c = 1.0) -#' getgamma1cont( -#' nsim = 1000L, prob = 'posterior', design = 'controlled', -#' prior = 'vague', CalcMethod = 'MM', -#' theta_TV = 1.5, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, -#' mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 2.0, sigma_c_go = 2.0, -#' mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 2.0, sigma_c_nogo = 2.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 1L -#' ) -#' -#' # Example 2: Uncontrolled design, N-Inv-Chisq prior, posterior probability -#' getgamma1cont( -#' nsim = 1000L, prob = 'posterior', design = 'uncontrolled', -#' prior = 'N-Inv-Chisq', CalcMethod = 'NI', -#' theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, -#' mu_t_go = 1.5, mu_c_go = NULL, sigma_t_go = 1.5, sigma_c_go = NULL, -#' mu_t_nogo = 3.0, mu_c_nogo = NULL, sigma_t_nogo = 1.5, sigma_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 20L, n_c = NULL, m_t = NULL, m_c = NULL, -#' kappa0_t = 2, kappa0_c = NULL, nu0_t = 5, nu0_c = NULL, -#' mu0_t = 3.0, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = NULL, -#' r = 1.0, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 2L -#' ) -#' -#' # Example 3: External design, vague prior, posterior probability -#' getgamma1cont( -#' nsim = 1000L, prob = 'posterior', design = 'external', -#' prior = 'vague', CalcMethod = 'MM', -#' theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, -#' mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 1.5, sigma_c_go = 1.5, -#' mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' r = NULL, ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = 0.0, se_t = NULL, se_c = 1.5, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 4L -#' ) -#' -#' # Example 4: Controlled design, vague prior, predictive probability -#' getgamma1cont( -#' nsim = 1000L, prob = 'predictive', design = 'controlled', -#' prior = 'vague', CalcMethod = 'MM', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, -#' mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 2.0, sigma_c_go = 2.0, -#' mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 2.0, sigma_c_nogo = 2.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 15L, n_c = 15L, m_t = 50L, m_c = 50L, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 3L -#' ) -#' -#' # Example 5: Uncontrolled design, vague prior, predictive probability -#' getgamma1cont( -#' nsim = 1000L, prob = 'predictive', design = 'uncontrolled', -#' prior = 'vague', CalcMethod = 'MM', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, -#' mu_t_go = 1.0, mu_c_go = NULL, sigma_t_go = 2.0, sigma_c_go = NULL, -#' mu_t_nogo = 2.5, mu_c_nogo = NULL, sigma_t_nogo = 2.0, sigma_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 15L, n_c = NULL, m_t = 50L, m_c = 50L, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = 0.0, sigma0_t = NULL, sigma0_c = NULL, -#' r = 1.0, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 5L -#' ) -#' -#' # Example 6: External design, vague prior, predictive probability -#' getgamma1cont( -#' nsim = 1000L, prob = 'predictive', design = 'external', -#' prior = 'vague', CalcMethod = 'MM', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, -#' mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 1.5, sigma_c_go = 1.5, -#' mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 15L, n_c = 15L, m_t = 50L, m_c = 50L, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' r = NULL, ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = 0.0, se_t = NULL, se_c = 1.5, -#' gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 6L -#' ) -#' -#' @importFrom stats rnorm -#' @export -getgamma1cont <- function(nsim, - prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'NI', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = NULL, - nMC = NULL, - mu_t_go, mu_c_go = NULL, - sigma_t_go, sigma_c_go = NULL, - mu_t_nogo, mu_c_nogo = NULL, - sigma_t_nogo, sigma_c_nogo = NULL, - target_go, target_nogo, - n_t, n_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, - nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, - sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), - seed) { - - # --------------------------------------------------------------------------- - # Input validation - # --------------------------------------------------------------------------- - if (!is.numeric(nsim) || length(nsim) != 1L || is.na(nsim) || - nsim != floor(nsim) || nsim < 1L) { - stop("'nsim' must be a single positive integer") - } - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c('vague', 'N-Inv-Chisq')) { - stop("'prior' must be either 'vague' or 'N-Inv-Chisq'") - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c('NI', 'MC', 'MM')) { - stop("'CalcMethod' must be 'NI', 'MC', or 'MM'") - } - - if (CalcMethod == 'MC') { - if (is.null(nMC) || !is.numeric(nMC) || length(nMC) != 1L || - is.na(nMC) || nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer when CalcMethod = 'MC'") - } - } - - if (prob == 'posterior') { - if (is.null(theta_TV) || is.null(theta_MAV)) { - stop("'theta_TV' and 'theta_MAV' must be non-NULL when prob = 'posterior'") - } - if (!is.numeric(theta_TV) || length(theta_TV) != 1L || is.na(theta_TV)) { - stop("'theta_TV' must be a single numeric value") - } - if (!is.numeric(theta_MAV) || length(theta_MAV) != 1L || is.na(theta_MAV)) { - stop("'theta_MAV' must be a single numeric value") - } - if (theta_TV <= theta_MAV) { - stop("'theta_TV' must be strictly greater than 'theta_MAV'") - } - } else { - if (is.null(theta_NULL)) { - stop("'theta_NULL' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(theta_NULL) || length(theta_NULL) != 1L || - is.na(theta_NULL)) { - stop("'theta_NULL' must be a single numeric value") - } - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - for (nm in c("m_t", "m_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - } - - # Validate Go-calibration scenario parameters - if (!is.numeric(mu_t_go) || length(mu_t_go) != 1L || is.na(mu_t_go)) { - stop("'mu_t_go' must be a single numeric value") - } - if (!is.numeric(sigma_t_go) || length(sigma_t_go) != 1L || - is.na(sigma_t_go) || sigma_t_go <= 0) { - stop("'sigma_t_go' must be a single positive numeric value") - } - - # Validate NoGo-calibration scenario parameters - if (!is.numeric(mu_t_nogo) || length(mu_t_nogo) != 1L || is.na(mu_t_nogo)) { - stop("'mu_t_nogo' must be a single numeric value") - } - if (!is.numeric(sigma_t_nogo) || length(sigma_t_nogo) != 1L || - is.na(sigma_t_nogo) || sigma_t_nogo <= 0) { - stop("'sigma_t_nogo' must be a single positive numeric value") - } - - if (design != 'uncontrolled') { - if (is.null(mu_c_go) || !is.numeric(mu_c_go) || length(mu_c_go) != 1L || - is.na(mu_c_go)) { - stop("'mu_c_go' must be a single numeric value for controlled or external design") - } - if (is.null(sigma_c_go) || !is.numeric(sigma_c_go) || - length(sigma_c_go) != 1L || is.na(sigma_c_go) || sigma_c_go <= 0) { - stop("'sigma_c_go' must be a single positive numeric value for controlled or external design") - } - if (is.null(mu_c_nogo) || !is.numeric(mu_c_nogo) || length(mu_c_nogo) != 1L || - is.na(mu_c_nogo)) { - stop("'mu_c_nogo' must be a single numeric value for controlled or external design") - } - if (is.null(sigma_c_nogo) || !is.numeric(sigma_c_nogo) || - length(sigma_c_nogo) != 1L || is.na(sigma_c_nogo) || sigma_c_nogo <= 0) { - stop("'sigma_c_nogo' must be a single positive numeric value for controlled or external design") - } - } - - for (nm in c("target_go", "target_nogo")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val >= 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1)")) - } - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) { - stop("'n_t' must be a single positive integer") - } - - if (design != 'uncontrolled') { - if (is.null(n_c) || !is.numeric(n_c) || length(n_c) != 1L || - is.na(n_c) || n_c != floor(n_c) || n_c < 1L) { - stop("'n_c' must be a single positive integer for controlled or external design") - } - } - - if (prior == 'N-Inv-Chisq') { - for (nm in c("kappa0_t", "nu0_t", "mu0_t", "sigma0_t")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prior = 'N-Inv-Chisq'")) - } - } - if (!is.numeric(kappa0_t) || length(kappa0_t) != 1L || is.na(kappa0_t) || - kappa0_t <= 0) { - stop("'kappa0_t' must be a single positive numeric value") - } - if (!is.numeric(nu0_t) || length(nu0_t) != 1L || is.na(nu0_t) || - nu0_t <= 0) { - stop("'nu0_t' must be a single positive numeric value") - } - if (!is.numeric(mu0_t) || length(mu0_t) != 1L || is.na(mu0_t)) { - stop("'mu0_t' must be a single numeric value") - } - if (!is.numeric(sigma0_t) || length(sigma0_t) != 1L || is.na(sigma0_t) || - sigma0_t <= 0) { - stop("'sigma0_t' must be a single positive numeric value") - } - if (design != 'uncontrolled') { - for (nm in c("kappa0_c", "nu0_c", "mu0_c", "sigma0_c")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prior = 'N-Inv-Chisq' and design != 'uncontrolled'")) - } - } - if (!is.numeric(kappa0_c) || length(kappa0_c) != 1L || is.na(kappa0_c) || - kappa0_c <= 0) { - stop("'kappa0_c' must be a single positive numeric value") - } - if (!is.numeric(nu0_c) || length(nu0_c) != 1L || is.na(nu0_c) || - nu0_c <= 0) { - stop("'nu0_c' must be a single positive numeric value") - } - if (!is.numeric(mu0_c) || length(mu0_c) != 1L || is.na(mu0_c)) { - stop("'mu0_c' must be a single numeric value") - } - if (!is.numeric(sigma0_c) || length(sigma0_c) != 1L || is.na(sigma0_c) || - sigma0_c <= 0) { - stop("'sigma0_c' must be a single positive numeric value") - } - } else { - if (is.null(mu0_c) || !is.numeric(mu0_c) || length(mu0_c) != 1L || - is.na(mu0_c)) { - stop("'mu0_c' must be a single numeric value when design = 'uncontrolled'") - } - } - } - - if (design == 'uncontrolled') { - if (is.null(r) || !is.numeric(r) || length(r) != 1L || is.na(r) || - r <= 0) { - stop("'r' must be a single positive numeric value when design = 'uncontrolled'") - } - } - - if (design == 'external') { - has_ext_t <- !is.null(ne_t) && !is.null(alpha0e_t) && !is.null(bar_ye_t) && - !is.null(se_t) - has_ext_c <- !is.null(ne_c) && !is.null(alpha0e_c) && !is.null(bar_ye_c) && - !is.null(se_c) - if (!has_ext_t && !has_ext_c) { - stop("For design = 'external', at least one of (ne_t, alpha0e_t, bar_ye_t, se_t) or (ne_c, alpha0e_c, bar_ye_c, se_c) must be fully specified") - } - if (!is.null(ne_t)) { - if (!is.numeric(ne_t) || length(ne_t) != 1L || is.na(ne_t) || - ne_t != floor(ne_t) || ne_t < 1L) { - stop("'ne_t' must be a single positive integer") - } - if (!is.numeric(alpha0e_t) || length(alpha0e_t) != 1L || - is.na(alpha0e_t) || alpha0e_t <= 0 || alpha0e_t > 1) { - stop("'alpha0e_t' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_t) || length(bar_ye_t) != 1L || is.na(bar_ye_t)) { - stop("'bar_ye_t' must be a single numeric value") - } - if (!is.numeric(se_t) || length(se_t) != 1L || is.na(se_t) || se_t <= 0) { - stop("'se_t' must be a single positive numeric value") - } - } - if (!is.null(ne_c)) { - if (!is.numeric(ne_c) || length(ne_c) != 1L || is.na(ne_c) || - ne_c != floor(ne_c) || ne_c < 1L) { - stop("'ne_c' must be a single positive integer") - } - if (!is.numeric(alpha0e_c) || length(alpha0e_c) != 1L || - is.na(alpha0e_c) || alpha0e_c <= 0 || alpha0e_c > 1) { - stop("'alpha0e_c' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_c) || length(bar_ye_c) != 1L || is.na(bar_ye_c)) { - stop("'bar_ye_c' must be a single numeric value") - } - if (!is.numeric(se_c) || length(se_c) != 1L || is.na(se_c) || se_c <= 0) { - stop("'se_c' must be a single positive numeric value") - } - } - } - - if (!is.numeric(gamma_grid) || length(gamma_grid) < 1L || - any(is.na(gamma_grid)) || any(gamma_grid <= 0) || any(gamma_grid >= 1)) { - stop("'gamma_grid' must be a numeric vector with all values in (0, 1)") - } - gamma_grid <- sort(unique(gamma_grid)) - - if (!is.numeric(seed) || length(seed) != 1L || is.na(seed)) { - stop("'seed' must be a single numeric value") - } - - # --------------------------------------------------------------------------- - # Internal helper: simulate nsim datasets and return g_Go and g_NoGo vectors - # --------------------------------------------------------------------------- - .simulate_g <- function(mu_t_s, sigma_t_s, mu_c_s, sigma_c_s, seed_val) { - set.seed(seed_val) - - Z_t <- matrix(rnorm(nsim * n_t, mean = 0, sd = sigma_t_s), nrow = nsim) - Z_t_rowmean <- rowSums(Z_t) / n_t - bar_y_t_sim <- Z_t_rowmean + mu_t_s - s_t_sim <- sqrt(rowSums((Z_t - Z_t_rowmean) ^ 2) / (n_t - 1)) - - if (design %in% c('controlled', 'external')) { - Z_c <- matrix(rnorm(nsim * n_c, mean = 0, sd = sigma_c_s), nrow = nsim) - Z_c_rowmean <- rowSums(Z_c) / n_c - bar_y_c_sim <- Z_c_rowmean + mu_c_s - s_c_sim <- sqrt(rowSums((Z_c - Z_c_rowmean) ^ 2) / (n_c - 1)) - } else { - bar_y_c_sim <- NULL - s_c_sim <- NULL - } - - theta0_go <- if (prob == 'posterior') theta_TV else theta_NULL - theta0_nogo <- if (prob == 'posterior') theta_MAV else theta_NULL - - g_Go <- pbayespostpred1cont( - prob = prob, design = design, prior = prior, CalcMethod = CalcMethod, - theta0 = theta0_go, nMC = nMC, - n_t = n_t, n_c = n_c, m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, kappa0_c = kappa0_c, - nu0_t = nu0_t, nu0_c = nu0_c, - mu0_t = mu0_t, mu0_c = mu0_c, - sigma0_t = sigma0_t, sigma0_c = sigma0_c, - bar_y_t = bar_y_t_sim, bar_y_c = bar_y_c_sim, - s_t = s_t_sim, s_c = s_c_sim, - r = r, - ne_t = ne_t, ne_c = ne_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, - se_t = se_t, se_c = se_c, - lower.tail = FALSE - ) - - g_NoGo <- pbayespostpred1cont( - prob = prob, design = design, prior = prior, CalcMethod = CalcMethod, - theta0 = theta0_nogo, nMC = nMC, - n_t = n_t, n_c = n_c, m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, kappa0_c = kappa0_c, - nu0_t = nu0_t, nu0_c = nu0_c, - mu0_t = mu0_t, mu0_c = mu0_c, - sigma0_t = sigma0_t, sigma0_c = sigma0_c, - bar_y_t = bar_y_t_sim, bar_y_c = bar_y_c_sim, - s_t = s_t_sim, s_c = s_c_sim, - r = r, - ne_t = ne_t, ne_c = ne_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, - se_t = se_t, se_c = se_c, - lower.tail = TRUE - ) - - list(g_Go = g_Go, g_NoGo = g_NoGo) - } - - # --------------------------------------------------------------------------- - # Stage 1: Simulate nsim datasets for each calibration scenario independently - # --------------------------------------------------------------------------- - # Go-calibration scenario (typically Null): use seed - sim_go <- .simulate_g(mu_t_go, sigma_t_go, mu_c_go, sigma_c_go, - seed_val = seed) - # NoGo-calibration scenario (typically Alternative): use seed + 1 - sim_nogo <- .simulate_g(mu_t_nogo, sigma_t_nogo, mu_c_nogo, sigma_c_nogo, - seed_val = seed + 1L) - - gPost_Go <- sim_go$g_Go - gPost_NoGo <- sim_nogo$g_NoGo - - # --------------------------------------------------------------------------- - # Stage 2: Sweep gamma_grid using vectorised outer comparison - # --------------------------------------------------------------------------- - # Marginal Go criterion: g_Go >= gamma (lower.tail = FALSE -> P(theta > TV)) - # Marginal NoGo criterion: g_NoGo >= gamma (lower.tail = TRUE -> P(theta <= MAV)) - # Both Pr(Go) and Pr(NoGo) are monotone non-increasing in gamma. - go_ind <- outer(gPost_Go, gamma_grid, ">=") # nsim x n_gamma - nogo_ind <- outer(gPost_NoGo, gamma_grid, ">=") # nsim x n_gamma - - PrGo_grid <- colMeans(go_ind) - PrNoGo_grid <- colMeans(nogo_ind) - - # --------------------------------------------------------------------------- - # Stage 3: Select optimal gamma values - # --------------------------------------------------------------------------- - # gamma_go : smallest gamma with Pr(Go) < target_go - # gamma_nogo: smallest gamma with Pr(NoGo) < target_nogo - go_mask <- PrGo_grid < target_go - nogo_mask <- PrNoGo_grid < target_nogo - - idx_go <- which(go_mask) - if (length(idx_go) == 0L) { - gamma_go <- NA_real_ - PrGo_opt <- NA_real_ - } else { - opt1 <- min(idx_go) - gamma_go <- gamma_grid[opt1] - PrGo_opt <- PrGo_grid[opt1] - } - - idx_nogo <- which(nogo_mask) - if (length(idx_nogo) == 0L) { - gamma_nogo <- NA_real_ - PrNoGo_opt <- NA_real_ - } else { - opt2 <- min(idx_nogo) - gamma_nogo <- gamma_grid[opt2] - PrNoGo_opt <- PrNoGo_grid[opt2] - } - - # --------------------------------------------------------------------------- - # Build and return result - # --------------------------------------------------------------------------- - result <- list( - gamma_go = gamma_go, - gamma_nogo = gamma_nogo, - PrGo_opt = PrGo_opt, - PrNoGo_opt = PrNoGo_opt, - target_go = target_go, - target_nogo = target_nogo, - grid_results = data.frame( - gamma_grid = gamma_grid, - PrGo_grid = PrGo_grid, - PrNoGo_grid = PrNoGo_grid - ) - ) - - class(result) <- 'getgamma1cont' - return(result) -} diff --git a/R/getgamma2bin.R b/R/getgamma2bin.R deleted file mode 100644 index 99ab400..0000000 --- a/R/getgamma2bin.R +++ /dev/null @@ -1,748 +0,0 @@ -#' Find Optimal Go/NoGo Thresholds for Two Binary Endpoints -#' -#' Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -#' threshold \eqn{\gamma_{\mathrm{nogo}}} for two binary endpoints by -#' searching over a two-dimensional grid of candidate value pairs. The two -#' thresholds are calibrated independently under separate scenarios: -#' \itemize{ -#' \item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -#' \code{gamma_go_grid} such that the worst-case marginal Go -#' probability over all \eqn{\gamma_{\mathrm{nogo}}} in -#' \code{gamma_nogo_grid} is strictly less than \code{target_go} -#' under the Go-calibration scenario (\code{pi_t1_go}, -#' \code{pi_t2_go}, \code{rho_t_go}, \code{pi_c1_go}, -#' \code{pi_c2_go}, \code{rho_c_go}); typically the Null scenario. -#' \item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -#' \code{gamma_nogo_grid} such that the worst-case marginal NoGo -#' probability over all \eqn{\gamma_{\mathrm{go}}} in -#' \code{gamma_go_grid} is strictly less than \code{target_nogo} -#' under the NoGo-calibration scenario (\code{pi_t1_nogo}, -#' \code{pi_t2_nogo}, \code{rho_t_nogo}, \code{pi_c1_nogo}, -#' \code{pi_c2_nogo}, \code{rho_c_nogo}); typically the Alternative -#' scenario. -#' } -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param GoRegions An integer vector of region indices (subset of -#' \code{1:9} for \code{prob = 'posterior'} or \code{1:4} for -#' \code{prob = 'predictive'}) that constitute the Go region. -#' @param NoGoRegions An integer vector of region indices that constitute -#' the NoGo region. Must be disjoint from \code{GoRegions}. -#' @param pi_t1_go A numeric scalar in \code{(0, 1)} giving the true -#' treatment response probability for Endpoint 1 under the -#' Go-calibration scenario (typically Null). -#' @param pi_t2_go A numeric scalar in \code{(0, 1)} giving the true -#' treatment response probability for Endpoint 2 under the -#' Go-calibration scenario. -#' @param rho_t_go A numeric scalar giving the within-group correlation in -#' the treatment group under the Go-calibration scenario. -#' @param pi_c1_go A numeric scalar in \code{(0, 1)} giving the true -#' control response probability for Endpoint 1 under the -#' Go-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param pi_c2_go A numeric scalar in \code{(0, 1)} giving the true -#' control response probability for Endpoint 2 under the -#' Go-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param rho_c_go A numeric scalar giving the within-group correlation in -#' the control group under the Go-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param pi_t1_nogo A numeric scalar in \code{(0, 1)} giving the true -#' treatment response probability for Endpoint 1 under the -#' NoGo-calibration scenario (typically Alternative). -#' @param pi_t2_nogo A numeric scalar in \code{(0, 1)} giving the true -#' treatment response probability for Endpoint 2 under the -#' NoGo-calibration scenario. -#' @param rho_t_nogo A numeric scalar giving the within-group correlation in -#' the treatment group under the NoGo-calibration scenario. -#' @param pi_c1_nogo A numeric scalar in \code{(0, 1)} giving the true -#' control response probability for Endpoint 1 under the -#' NoGo-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param pi_c2_nogo A numeric scalar in \code{(0, 1)} giving the true -#' control response probability for Endpoint 2 under the -#' NoGo-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param rho_c_nogo A numeric scalar giving the within-group correlation in -#' the control group under the NoGo-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param target_go A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the worst-case marginal Go probability under the Go-calibration -#' scenario. The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest -#' grid value satisfying the constraint. -#' @param target_nogo A numeric scalar in \code{(0, 1)} giving the upper -#' bound on the worst-case marginal NoGo probability under the -#' NoGo-calibration scenario. The optimal \eqn{\gamma_{\mathrm{nogo}}} -#' is the smallest grid value satisfying the constraint. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the PoC trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. -#' @param a_t_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the (0,0) response pattern in the treatment group. -#' @param a_t_01 A positive numeric scalar; see \code{a_t_00}. -#' @param a_t_10 A positive numeric scalar; see \code{a_t_00}. -#' @param a_t_11 A positive numeric scalar; see \code{a_t_00}. -#' @param a_c_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the (0,0) response pattern in the control group. -#' @param a_c_01 A positive numeric scalar; see \code{a_c_00}. -#' @param a_c_10 A positive numeric scalar; see \code{a_c_00}. -#' @param a_c_11 A positive numeric scalar; see \code{a_c_00}. -#' @param theta_TV1 A numeric scalar giving the TV threshold for -#' Endpoint 1. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_MAV1 A numeric scalar giving the MAV threshold for -#' Endpoint 1. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_TV2 A numeric scalar giving the TV threshold for -#' Endpoint 2. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_MAV2 A numeric scalar giving the MAV threshold for -#' Endpoint 2. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; -#' otherwise set to \code{NULL}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; -#' otherwise set to \code{NULL}. -#' @param m_t A positive integer giving the future sample size for the -#' treatment group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param m_c A positive integer giving the future sample size for the -#' control group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param z00 A non-negative integer giving the hypothetical control count -#' for pattern (0,0). Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z01 A non-negative integer; see \code{z00}. -#' @param z10 A non-negative integer; see \code{z00}. -#' @param z11 A non-negative integer; see \code{z00}. -#' @param xe_t_00 A non-negative integer giving the external treatment group -#' count for pattern (0,0). Required when -#' \code{design = 'external'} and external treatment data are used; -#' otherwise \code{NULL}. -#' @param xe_t_01 A non-negative integer; see \code{xe_t_00}. -#' @param xe_t_10 A non-negative integer; see \code{xe_t_00}. -#' @param xe_t_11 A non-negative integer; see \code{xe_t_00}. -#' @param xe_c_00 A non-negative integer giving the external control group -#' count for pattern (0,0). Required when -#' \code{design = 'external'} and external control data are used; -#' otherwise \code{NULL}. -#' @param xe_c_01 A non-negative integer; see \code{xe_c_00}. -#' @param xe_c_10 A non-negative integer; see \code{xe_c_00}. -#' @param xe_c_11 A non-negative integer; see \code{xe_c_00}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external treatment group data. Required when external -#' treatment data are used; otherwise \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external control group data. Required when external -#' control data are used; otherwise \code{NULL}. -#' @param nMC A positive integer giving the number of Dirichlet draws used -#' to evaluate region probabilities for each count combination in -#' Stage 1. Default is \code{1000L}. -#' @param gamma_go_grid A numeric vector of candidate Go threshold values -#' in \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' @param gamma_nogo_grid A numeric vector of candidate NoGo threshold -#' values in \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' -#' @return A list of class \code{getgamma2bin} with the following elements: -#' \describe{ -#' \item{gamma_go}{Optimal Go threshold: the smallest value in -#' \code{gamma_go_grid} for which the marginal -#' \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} under the -#' Go-calibration scenario. \code{NA} if no such value exists.} -#' \item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -#' \code{gamma_nogo_grid} for which the marginal -#' \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} under the -#' NoGo-calibration scenario. \code{NA} if no such value exists.} -#' \item{PrGo_opt}{Marginal \eqn{\Pr(\mathrm{Go})} at -#' \code{gamma_go} under the Go-calibration scenario. -#' \code{NA} if \code{gamma_go} is \code{NA}.} -#' \item{PrNoGo_opt}{Marginal \eqn{\Pr(\mathrm{NoGo})} at -#' \code{gamma_nogo} under the NoGo-calibration scenario. -#' \code{NA} if \code{gamma_nogo} is \code{NA}.} -#' \item{target_go}{The value of \code{target_go} supplied by the user.} -#' \item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -#' \item{grid_results}{A data frame with columns \code{gamma_grid}, -#' \code{PrGo_grid} (marginal Go probability under the Go-calibration -#' scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -#' the NoGo-calibration scenario).} -#' } -#' -#' @details -#' The function uses the same two-stage precompute-then-sweep strategy as -#' \code{\link{pbayesdecisionprob2bin}}. -#' -#' \strong{Stage 1 (precomputation)}: \code{\link{pbayespostpred2bin}} is -#' called for every possible multinomial outcome combination \eqn{(x_t, x_c)} -#' enumerated by \code{\link{allmultinom}}. The resulting region probability -#' vector is summed over \code{GoRegions} and \code{NoGoRegions} to obtain -#' \eqn{\hat{g}_{Go,ij}} and \eqn{\hat{g}_{NoGo,ij}}. These are independent -#' of the calibration scenario; only the multinomial weights differ. -#' -#' \strong{Stage 2 (gamma sweep)}: For each pair -#' \eqn{(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})} in the -#' two-dimensional grid, operating characteristics are computed separately -#' under each calibration scenario using the respective multinomial weights: -#' \deqn{\Pr(\mathrm{Go}) = \sum_{i,j} w_{ij}^{(\mathrm{go})} -#' \mathbf{1}\!\left[\hat{g}_{Go,ij} \ge \gamma_{\mathrm{go}},\; -#' \hat{g}_{NoGo,ij} < \gamma_{\mathrm{nogo}}\right]} -#' \deqn{\Pr(\mathrm{NoGo}) = \sum_{i,j} w_{ij}^{(\mathrm{nogo})} -#' \mathbf{1}\!\left[\hat{g}_{NoGo,ij} \ge \gamma_{\mathrm{nogo}},\; -#' \hat{g}_{Go,ij} < \gamma_{\mathrm{go}}\right]} -#' -#' \strong{Stage 3 (optimal threshold selection)}: For each candidate -#' \eqn{\gamma_{\mathrm{go}}}, the worst-case \eqn{\Pr(\mathrm{Go})} over all -#' \eqn{\gamma_{\mathrm{nogo}}} in \code{gamma_nogo_grid} is computed; the -#' optimal \eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value for -#' which this worst-case probability is less than \code{target_go}. -#' Analogously, the optimal \eqn{\gamma_{\mathrm{nogo}}} is the -#' \emph{smallest} grid value for which the worst-case \eqn{\Pr(\mathrm{NoGo})} -#' is less than \code{target_nogo}. -#' -#' @examples -#' # Example 1: Controlled design, posterior probability -#' # gamma_go : smallest gamma_go s.t. max_{gamma_nogo} Pr(Go) < 0.05 under Null -#' # gamma_nogo: smallest gamma_nogo s.t. max_{gamma_go} Pr(NoGo) < 0.20 under Alt -#' \donttest{ -#' getgamma2bin( -#' prob = 'posterior', design = 'controlled', -#' GoRegions = 1L, NoGoRegions = 9L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' # Example 2: Uncontrolled design, posterior probability -#' \donttest{ -#' getgamma2bin( -#' prob = 'posterior', design = 'uncontrolled', -#' GoRegions = 1L, NoGoRegions = 9L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' z00 = 3L, z01 = 2L, z10 = 3L, z11 = 2L, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' # Example 3: External design, posterior probability -#' \donttest{ -#' getgamma2bin( -#' prob = 'posterior', design = 'external', -#' GoRegions = 1L, NoGoRegions = 9L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = 3L, xe_c_01 = 2L, xe_c_10 = 3L, xe_c_11 = 2L, -#' alpha0e_t = NULL, alpha0e_c = 0.5, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' # Example 4: Controlled design, predictive probability -#' \donttest{ -#' getgamma2bin( -#' prob = 'predictive', design = 'controlled', -#' GoRegions = 1L, NoGoRegions = 4L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' m_t = 5L, m_c = 5L, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' # Example 5: Uncontrolled design, predictive probability -#' \donttest{ -#' getgamma2bin( -#' prob = 'predictive', design = 'uncontrolled', -#' GoRegions = 1L, NoGoRegions = 4L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' m_t = 5L, m_c = 5L, -#' z00 = 3L, z01 = 2L, z10 = 3L, z11 = 2L, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' # Example 6: External design, predictive probability -#' \donttest{ -#' getgamma2bin( -#' prob = 'predictive', design = 'external', -#' GoRegions = 1L, NoGoRegions = 4L, -#' pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, -#' pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, -#' pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, -#' pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 7L, n_c = 7L, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' m_t = 5L, m_c = 5L, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = 3L, xe_t_01 = 2L, xe_t_10 = 3L, xe_t_11 = 2L, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = 0.5, alpha0e_c = NULL, -#' nMC = 100L, -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -#' ) -#' } -#' -#' @importFrom stats dmultinom -#' @export -getgamma2bin <- function(prob = 'posterior', design = 'controlled', - GoRegions, NoGoRegions, - pi_t1_go, pi_t2_go, rho_t_go, - pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, - pi_t1_nogo, pi_t2_nogo, rho_t_nogo, - pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, - target_go, target_nogo, - n_t, n_c, - a_t_00, a_t_01, a_t_10, a_t_11, - a_c_00, a_c_01, a_c_10, a_c_11, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, - xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, - xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 1000L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01)) { - - # --------------------------------------------------------------------------- - # Input validation - # --------------------------------------------------------------------------- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - max_region <- if (prob == 'posterior') 9L else 4L - if (!is.integer(GoRegions) || length(GoRegions) < 1L || - any(is.na(GoRegions)) || any(GoRegions < 1L) || any(GoRegions > max_region)) { - stop(sprintf("'GoRegions' must be an integer vector with all values in 1:%d", max_region)) - } - if (!is.integer(NoGoRegions) || length(NoGoRegions) < 1L || - any(is.na(NoGoRegions)) || any(NoGoRegions < 1L) || - any(NoGoRegions > max_region)) { - stop(sprintf("'NoGoRegions' must be an integer vector with all values in 1:%d", max_region)) - } - if (length(intersect(GoRegions, NoGoRegions)) > 0L) { - stop("'GoRegions' and 'NoGoRegions' must be disjoint") - } - - # Validate Go-calibration scenario parameters - if (!is.numeric(pi_t1_go) || length(pi_t1_go) != 1L || is.na(pi_t1_go) || - pi_t1_go <= 0 || pi_t1_go >= 1) { - stop("'pi_t1_go' must be a single numeric value in (0, 1)") - } - if (!is.numeric(pi_t2_go) || length(pi_t2_go) != 1L || is.na(pi_t2_go) || - pi_t2_go <= 0 || pi_t2_go >= 1) { - stop("'pi_t2_go' must be a single numeric value in (0, 1)") - } - if (!is.numeric(rho_t_go) || length(rho_t_go) != 1L || is.na(rho_t_go)) { - stop("'rho_t_go' must be a single numeric value") - } - - # Validate NoGo-calibration scenario parameters - if (!is.numeric(pi_t1_nogo) || length(pi_t1_nogo) != 1L || is.na(pi_t1_nogo) || - pi_t1_nogo <= 0 || pi_t1_nogo >= 1) { - stop("'pi_t1_nogo' must be a single numeric value in (0, 1)") - } - if (!is.numeric(pi_t2_nogo) || length(pi_t2_nogo) != 1L || is.na(pi_t2_nogo) || - pi_t2_nogo <= 0 || pi_t2_nogo >= 1) { - stop("'pi_t2_nogo' must be a single numeric value in (0, 1)") - } - if (!is.numeric(rho_t_nogo) || length(rho_t_nogo) != 1L || is.na(rho_t_nogo)) { - stop("'rho_t_nogo' must be a single numeric value") - } - - if (design != 'uncontrolled') { - if (is.null(pi_c1_go) || !is.numeric(pi_c1_go) || length(pi_c1_go) != 1L || - is.na(pi_c1_go) || pi_c1_go <= 0 || pi_c1_go >= 1) { - stop("'pi_c1_go' must be a single numeric value in (0, 1) for controlled or external design") - } - if (is.null(pi_c2_go) || !is.numeric(pi_c2_go) || length(pi_c2_go) != 1L || - is.na(pi_c2_go) || pi_c2_go <= 0 || pi_c2_go >= 1) { - stop("'pi_c2_go' must be a single numeric value in (0, 1) for controlled or external design") - } - if (is.null(rho_c_go) || !is.numeric(rho_c_go) || length(rho_c_go) != 1L || - is.na(rho_c_go)) { - stop("'rho_c_go' must be a single numeric value for controlled or external design") - } - if (is.null(pi_c1_nogo) || !is.numeric(pi_c1_nogo) || length(pi_c1_nogo) != 1L || - is.na(pi_c1_nogo) || pi_c1_nogo <= 0 || pi_c1_nogo >= 1) { - stop("'pi_c1_nogo' must be a single numeric value in (0, 1) for controlled or external design") - } - if (is.null(pi_c2_nogo) || !is.numeric(pi_c2_nogo) || length(pi_c2_nogo) != 1L || - is.na(pi_c2_nogo) || pi_c2_nogo <= 0 || pi_c2_nogo >= 1) { - stop("'pi_c2_nogo' must be a single numeric value in (0, 1) for controlled or external design") - } - if (is.null(rho_c_nogo) || !is.numeric(rho_c_nogo) || length(rho_c_nogo) != 1L || - is.na(rho_c_nogo)) { - stop("'rho_c_nogo' must be a single numeric value for controlled or external design") - } - } - - for (nm in c("target_go", "target_nogo")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val >= 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1)")) - } - } - - for (nm in c("n_t", "n_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - - for (nm in c("a_t_00", "a_t_01", "a_t_10", "a_t_11", - "a_c_00", "a_c_01", "a_c_10", "a_c_11")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) { - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - } - - if (prob == 'posterior') { - for (nm in c("theta_TV1", "theta_MAV1", "theta_TV2", "theta_MAV2")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'posterior'")) - } - } - if (theta_TV1 <= theta_MAV1) { - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - } - if (theta_TV2 <= theta_MAV2) { - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } - } else { - for (nm in c("theta_NULL1", "theta_NULL2")) { - if (is.null(get(nm))) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'predictive'")) - } - } - if (is.null(m_t) || !is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer when prob = 'predictive'") - } - if (is.null(m_c) || !is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer when prob = 'predictive'") - } - } - - if (design == 'uncontrolled') { - for (nm in c("z00", "z01", "z10", "z11")) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a non-negative integer when design = 'uncontrolled'")) - } - } - } - - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer") - } - - for (gname in c("gamma_go_grid", "gamma_nogo_grid")) { - gval <- get(gname) - if (!is.numeric(gval) || length(gval) < 1L || - any(is.na(gval)) || any(gval <= 0) || any(gval >= 1)) { - stop(paste0("'", gname, "' must be a numeric vector with all values in (0, 1)")) - } - } - gamma_go_grid <- sort(unique(gamma_go_grid)) - gamma_nogo_grid <- sort(unique(gamma_nogo_grid)) - if (!identical(gamma_go_grid, gamma_nogo_grid)) { - stop("'gamma_go_grid' and 'gamma_nogo_grid' must be identical vectors") - } - gamma_grid <- gamma_go_grid - ng <- length(gamma_grid) - - # --------------------------------------------------------------------------- - # Stage 1: Enumerate all count combinations, compute PrGo_hat and - # PrNoGo_hat per combination via pbayespostpred2bin - # --------------------------------------------------------------------------- - counts_t <- allmultinom(n_t) # (n_row_t x 4) integer matrix - n_row_t <- nrow(counts_t) - - if (design == 'uncontrolled') { - # Control distribution is fixed (determined by z00..z11); only - # treatment outcomes vary. - counts_c <- matrix(0L, nrow = 1L, ncol = 4L) - n_row_c <- 1L - } else { - counts_c <- allmultinom(n_c) - n_row_c <- nrow(counts_c) - } - - # Multinomial probability weights for Go-calibration scenario - p_t_go <- getjointbin(pi1 = pi_t1_go, pi2 = pi_t2_go, rho = rho_t_go) - log_w_t_go <- apply(counts_t, 1L, function(x) { - dmultinom(x, size = n_t, prob = p_t_go, log = TRUE) - }) - - # Multinomial probability weights for NoGo-calibration scenario - p_t_nogo <- getjointbin(pi1 = pi_t1_nogo, pi2 = pi_t2_nogo, rho = rho_t_nogo) - log_w_t_nogo <- apply(counts_t, 1L, function(x) { - dmultinom(x, size = n_t, prob = p_t_nogo, log = TRUE) - }) - - if (design != 'uncontrolled') { - p_c_go <- getjointbin(pi1 = pi_c1_go, pi2 = pi_c2_go, rho = rho_c_go) - log_w_c_go <- apply(counts_c, 1L, function(x) { - dmultinom(x, size = n_c, prob = p_c_go, log = TRUE) - }) - p_c_nogo <- getjointbin(pi1 = pi_c1_nogo, pi2 = pi_c2_nogo, rho = rho_c_nogo) - log_w_c_nogo <- apply(counts_c, 1L, function(x) { - dmultinom(x, size = n_c, prob = p_c_nogo, log = TRUE) - }) - # w_mat_go[i,j] = P_go(X_t = counts_t[i,]) * P_go(X_c = counts_c[j,]) - # w_mat_nogo[i,j] = P_nogo(X_t = counts_t[i,]) * P_nogo(X_c = counts_c[j,]) - w_mat_go <- exp(outer(log_w_t_go, log_w_c_go, `+`)) - w_mat_nogo <- exp(outer(log_w_t_nogo, log_w_c_nogo, `+`)) - } else { - w_mat_go <- matrix(exp(log_w_t_go), nrow = n_row_t, ncol = 1L) - w_mat_nogo <- matrix(exp(log_w_t_nogo), nrow = n_row_t, ncol = 1L) - } - - # Preallocate region probability storage: PrGo_hat[i,j] and PrNoGo_hat[i,j] - # These are functions of data only (independent of calibration scenario weights) - PrGo_hat <- matrix(0, nrow = n_row_t, ncol = n_row_c) - PrNoGo_hat <- matrix(0, nrow = n_row_t, ncol = n_row_c) - - for (i in seq_len(n_row_t)) { - x_t_i <- as.integer(counts_t[i, ]) - - if (design == 'uncontrolled') { - Pr_R <- pbayespostpred2bin( - prob = prob, design = design, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - x_t_00 = x_t_i[1L], x_t_01 = x_t_i[2L], - x_t_10 = x_t_i[3L], x_t_11 = x_t_i[4L], - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = a_t_00, a_t_01 = a_t_01, a_t_10 = a_t_10, a_t_11 = a_t_11, - a_c_00 = a_c_00, a_c_01 = a_c_01, a_c_10 = a_c_10, a_c_11 = a_c_11, - m_t = m_t, m_c = m_c, - z00 = z00, z01 = z01, z10 = z10, z11 = z11, - xe_t_00 = xe_t_00, xe_t_01 = xe_t_01, - xe_t_10 = xe_t_10, xe_t_11 = xe_t_11, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = alpha0e_t, alpha0e_c = NULL, - nMC = nMC - ) - PrGo_hat[i, 1L] <- sum(Pr_R[GoRegions]) - PrNoGo_hat[i, 1L] <- sum(Pr_R[NoGoRegions]) - - } else { - - for (j in seq_len(n_row_c)) { - x_c_j <- as.integer(counts_c[j, ]) - - Pr_R <- pbayespostpred2bin( - prob = prob, design = design, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - x_t_00 = x_t_i[1L], x_t_01 = x_t_i[2L], - x_t_10 = x_t_i[3L], x_t_11 = x_t_i[4L], - x_c_00 = x_c_j[1L], x_c_01 = x_c_j[2L], - x_c_10 = x_c_j[3L], x_c_11 = x_c_j[4L], - a_t_00 = a_t_00, a_t_01 = a_t_01, a_t_10 = a_t_10, a_t_11 = a_t_11, - a_c_00 = a_c_00, a_c_01 = a_c_01, a_c_10 = a_c_10, a_c_11 = a_c_11, - m_t = m_t, m_c = m_c, - z00 = z00, z01 = z01, z10 = z10, z11 = z11, - xe_t_00 = xe_t_00, xe_t_01 = xe_t_01, - xe_t_10 = xe_t_10, xe_t_11 = xe_t_11, - xe_c_00 = xe_c_00, xe_c_01 = xe_c_01, - xe_c_10 = xe_c_10, xe_c_11 = xe_c_11, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - nMC = nMC - ) - PrGo_hat[i, j] <- sum(Pr_R[GoRegions]) - PrNoGo_hat[i, j] <- sum(Pr_R[NoGoRegions]) - } - } - } - - # --------------------------------------------------------------------------- - # Stage 2: Marginal sweep over gamma_go_grid and gamma_nogo_grid - # - # Go and NoGo probabilities are computed marginally (independently): - # Pr(Go) = sum w_go[i,j] * I(PrGo_hat[i,j] >= g1) - # Pr(NoGo) = sum w_nogo[i,j] * I(PrNoGo_hat[i,j] >= g2) - # --------------------------------------------------------------------------- - PrGo_grid <- numeric(ng) - PrNoGo_grid <- numeric(ng) - - for (k in seq_len(ng)) { - g <- gamma_grid[k] - go_mask <- (PrGo_hat >= g) - go_mask[is.na(go_mask)] <- FALSE - PrGo_grid[k] <- sum(w_mat_go[go_mask]) - } - - for (k in seq_len(ng)) { - g <- gamma_grid[k] - nogo_mask <- (PrNoGo_hat >= g) - nogo_mask[is.na(nogo_mask)] <- FALSE - PrNoGo_grid[k] <- sum(w_mat_nogo[nogo_mask]) - } - - # --------------------------------------------------------------------------- - # Stage 3: Select optimal (gamma_go, gamma_nogo) - # - # gamma_go : smallest value in gamma_go_grid s.t. Pr(Go) < target_go - # gamma_nogo: smallest value in gamma_nogo_grid s.t. Pr(NoGo) < target_nogo - # Both curves are non-increasing in their respective gamma. - # --------------------------------------------------------------------------- - idx_go <- which(PrGo_grid < target_go) - if (length(idx_go) == 0L) { - gamma_go <- NA_real_ - PrGo_opt <- NA_real_ - } else { - opt1 <- min(idx_go) - gamma_go <- gamma_grid[opt1] - PrGo_opt <- PrGo_grid[opt1] - } - - idx_nogo <- which(PrNoGo_grid < target_nogo) - if (length(idx_nogo) == 0L) { - gamma_nogo <- NA_real_ - PrNoGo_opt <- NA_real_ - } else { - opt2 <- min(idx_nogo) - gamma_nogo <- gamma_grid[opt2] - PrNoGo_opt <- PrNoGo_grid[opt2] - } - - # --------------------------------------------------------------------------- - # Build and return result - # --------------------------------------------------------------------------- - result <- list( - gamma_go = gamma_go, - gamma_nogo = gamma_nogo, - PrGo_opt = PrGo_opt, - PrNoGo_opt = PrNoGo_opt, - target_go = target_go, - target_nogo = target_nogo, - grid_results = data.frame( - gamma_grid = gamma_grid, - PrGo_grid = PrGo_grid, - PrNoGo_grid = PrNoGo_grid - ) - ) - - class(result) <- 'getgamma2bin' - return(result) -} diff --git a/R/getgamma2cont.R b/R/getgamma2cont.R deleted file mode 100644 index 041a7cc..0000000 --- a/R/getgamma2cont.R +++ /dev/null @@ -1,762 +0,0 @@ -#' Find Optimal Go/NoGo Thresholds for Two Continuous Endpoints -#' -#' Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -#' threshold \eqn{\gamma_{\mathrm{nogo}}} for two continuous endpoints by -#' searching independently over candidate threshold grids. The two -#' thresholds are calibrated marginally under separate scenarios: -#' \itemize{ -#' \item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -#' \code{gamma_go_grid} such that the marginal Go probability is -#' strictly less than \code{target_go} under the Go-calibration -#' scenario (\code{mu_t_go}, \code{Sigma_t_go}, \code{mu_c_go}, -#' \code{Sigma_c_go}); typically the Null scenario. -#' \item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -#' \code{gamma_nogo_grid} such that the marginal NoGo probability is -#' strictly less than \code{target_nogo} under the NoGo-calibration -#' scenario (\code{mu_t_nogo}, \code{Sigma_t_nogo}, \code{mu_c_nogo}, -#' \code{Sigma_c_nogo}); typically the Alternative scenario. -#' } -#' -#' @param nsim A positive integer giving the number of Monte Carlo -#' datasets to simulate per calibration scenario. Default is -#' \code{10000L}. -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param prior A character string specifying the prior distribution. -#' Must be \code{'vague'} or \code{'N-Inv-Wishart'}. -#' @param GoRegions An integer vector of region indices (subset of -#' \code{1:9}) that constitute the Go region. The 9 regions are -#' defined by the cross-classification of the two treatment effects -#' \eqn{(\theta_1, \theta_2)} relative to \code{(TV1, MAV1)} and -#' \code{(TV2, MAV2)}: region \eqn{k = (z_1 - 1) \times 3 + z_2} -#' where \eqn{z_i = 1} if \eqn{\theta_i > TV_i}, \eqn{z_i = 2} if -#' \eqn{MAV_i < \theta_i \le TV_i}, \eqn{z_i = 3} if -#' \eqn{\theta_i \le MAV_i}. -#' @param NoGoRegions An integer vector of region indices (subset of -#' \code{1:9}) that constitute the NoGo region. -#' Must be disjoint from \code{GoRegions}. -#' @param mu_t_go A length-2 numeric vector giving the true bivariate mean -#' for the treatment group under the Go-calibration scenario -#' (typically Null). -#' @param Sigma_t_go A 2x2 positive-definite numeric matrix giving the -#' true within-group covariance in the treatment group under the -#' Go-calibration scenario. -#' @param mu_c_go A length-2 numeric vector giving the true bivariate mean -#' for the control group under the Go-calibration scenario. Required -#' for \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param Sigma_c_go A 2x2 positive-definite numeric matrix giving the -#' true within-group covariance in the control group under the -#' Go-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param mu_t_nogo A length-2 numeric vector giving the true bivariate mean -#' for the treatment group under the NoGo-calibration scenario -#' (typically Alternative). -#' @param Sigma_t_nogo A 2x2 positive-definite numeric matrix giving the -#' true within-group covariance in the treatment group under the -#' NoGo-calibration scenario. -#' @param mu_c_nogo A length-2 numeric vector giving the true bivariate mean -#' for the control group under the NoGo-calibration scenario. Required -#' for \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param Sigma_c_nogo A 2x2 positive-definite numeric matrix giving the -#' true within-group covariance in the control group under the -#' NoGo-calibration scenario. Required for -#' \code{design = 'controlled'} or \code{'external'}; -#' set to \code{NULL} for \code{design = 'uncontrolled'}. -#' @param target_go A numeric scalar in \code{(0, 1)} giving the upper bound -#' on the marginal Go probability under the Go-calibration scenario. -#' The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -#' satisfying the constraint. -#' @param target_nogo A numeric scalar in \code{(0, 1)} giving the upper -#' bound on the marginal NoGo probability under the NoGo-calibration -#' scenario. The optimal \eqn{\gamma_{\mathrm{nogo}}} is the smallest -#' grid value satisfying the constraint. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the PoC trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. Set to \code{NULL} for -#' \code{design = 'uncontrolled'}. -#' @param theta_TV1 A numeric scalar giving the TV threshold for -#' Endpoint 1. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_MAV1 A numeric scalar giving the MAV threshold for -#' Endpoint 1. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_TV2 A numeric scalar giving the TV threshold for -#' Endpoint 2. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_MAV2 A numeric scalar giving the MAV threshold for -#' Endpoint 2. Required when \code{prob = 'posterior'}; -#' otherwise set to \code{NULL}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; -#' otherwise set to \code{NULL}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; -#' otherwise set to \code{NULL}. -#' @param m_t A positive integer giving the future sample size for the -#' treatment group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param m_c A positive integer giving the future sample size for the -#' control group. Required when \code{prob = 'predictive'}; -#' set to \code{NULL} otherwise. -#' @param kappa0_t Positive numeric scalar. NIW prior hyperparameter -#' \eqn{\kappa_{01}} for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}. -#' @param nu0_t Positive numeric scalar. NIW prior degrees of freedom -#' \eqn{\nu_{01}} for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}. -#' @param mu0_t Length-2 numeric vector. NIW prior mean \eqn{\mu_{01}} -#' for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}. -#' @param Lambda0_t A 2x2 positive-definite numeric matrix. NIW prior -#' scale matrix \eqn{\Lambda_{01}} for the treatment group. Required -#' when \code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}. -#' @param kappa0_c Positive numeric scalar; see \code{kappa0_t}. -#' For the control group. -#' @param nu0_c Positive numeric scalar; see \code{nu0_t}. -#' For the control group. -#' @param mu0_c Length-2 numeric vector; see \code{mu0_t}. For the control -#' group. May be required for the vague prior uncontrolled design; -#' see \code{\link{pbayesdecisionprob2cont}}. -#' @param Lambda0_c A 2x2 matrix; see \code{Lambda0_t}. -#' For the control group. -#' @param r A positive numeric scalar giving the power prior weight for -#' the control group when \code{design = 'uncontrolled'} and -#' \code{prior = 'vague'}. Otherwise \code{NULL}. -#' @param ne_t A positive integer giving the external treatment sample size. -#' Required when \code{design = 'external'} and external treatment -#' data are used; otherwise \code{NULL}. -#' @param ne_c A positive integer giving the external control sample size. -#' Required when \code{design = 'external'} and external control -#' data are used; otherwise \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external treatment data. Required when external -#' treatment data are used; otherwise \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for external control data. Required when external control -#' data are used; otherwise \code{NULL}. -#' @param bar_ye_t A length-2 numeric vector. External treatment sample -#' mean. Required when external treatment data are used; -#' otherwise \code{NULL}. -#' @param bar_ye_c A length-2 numeric vector. External control sample mean. -#' Required when external control data are used; otherwise \code{NULL}. -#' @param se_t A 2x2 numeric matrix. External treatment sum-of-squares -#' matrix. Required when external treatment data are used; -#' otherwise \code{NULL}. -#' @param se_c A 2x2 numeric matrix. External control sum-of-squares -#' matrix. Required when external control data are used; -#' otherwise \code{NULL}. -#' @param nMC A positive integer giving the number of Monte Carlo draws -#' passed to \code{\link{pbayespostpred2cont}}. Required when -#' \code{CalcMethod = 'MC'}. May be set to \code{NULL} when -#' \code{CalcMethod = 'MM'} and \eqn{\nu_k > 4}; if -#' \code{CalcMethod = 'MM'} but \eqn{\nu_k \le 4} causes a fallback -#' to MC, \code{nMC} must be a positive integer. -#' Default is \code{NULL}. -#' @param CalcMethod A character string specifying the computation method -#' passed to \code{\link{pbayespostpred2cont}}. Must be -#' \code{'MC'} (default) or \code{'MM'}. -#' @param gamma_go_grid A numeric vector of candidate Go threshold values -#' in \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' @param gamma_nogo_grid A numeric vector of candidate NoGo threshold -#' values in \code{(0, 1)} to search over. Defaults to -#' \code{seq(0.01, 0.99, by = 0.01)}. -#' @param seed A numeric scalar for reproducible random number generation. -#' The Go-calibration simulation uses \code{seed} and the -#' NoGo-calibration simulation uses \code{seed + 1} to ensure -#' independence between the two scenarios. -#' -#' @return A list of class \code{getgamma2cont} with the following elements: -#' \describe{ -#' \item{gamma_go}{Optimal Go threshold: the smallest value in -#' \code{gamma_go_grid} for which the marginal -#' \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} under the -#' Go-calibration scenario. \code{NA} if no such value exists.} -#' \item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -#' \code{gamma_nogo_grid} for which the marginal -#' \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} under the -#' NoGo-calibration scenario. \code{NA} if no such value exists.} -#' \item{PrGo_opt}{Marginal \eqn{\Pr(\mathrm{Go})} at -#' \code{gamma_go} under the Go-calibration scenario. -#' \code{NA} if \code{gamma_go} is \code{NA}.} -#' \item{PrNoGo_opt}{Marginal \eqn{\Pr(\mathrm{NoGo})} at -#' \code{gamma_nogo} under the NoGo-calibration scenario. -#' \code{NA} if \code{gamma_nogo} is \code{NA}.} -#' \item{target_go}{The value of \code{target_go} supplied by the user.} -#' \item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -#' \item{grid_results}{A data frame with columns \code{gamma_grid}, -#' \code{PrGo_grid} (marginal Go probability under the Go-calibration -#' scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -#' the NoGo-calibration scenario).} -#' } -#' -#' @details -#' The function uses a two-stage simulate-then-sweep strategy: -#' -#' \strong{Stage 1 (simulation and precomputation)}: \code{nsim} bivariate -#' datasets are generated independently for each calibration scenario. -#' For the Go-calibration scenario, datasets are drawn from -#' \eqn{N_2(\mu_{t,\mathrm{go}}, \Sigma_{t,\mathrm{go}})} (and -#' \eqn{N_2(\mu_{c,\mathrm{go}}, \Sigma_{c,\mathrm{go}})} for -#' controlled/external designs); for the NoGo-calibration scenario, -#' the corresponding \code{_nogo} parameters are used. -#' \code{\link{pbayespostpred2cont}} is called once per scenario in -#' vectorised mode to return an \eqn{nsim \times 9} matrix of region -#' probabilities. The probabilities are summed over \code{GoRegions} -#' (for the Go scenario) and \code{NoGoRegions} (for the NoGo scenario) -#' to obtain \eqn{\hat{g}_{Go,i}} and \eqn{\hat{g}_{NoGo,i}}, -#' independent of the decision thresholds. -#' -#' \strong{Stage 2 (gamma sweep)}: For each pair -#' \eqn{(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})} in the -#' two-dimensional grid, operating characteristics are computed separately -#' under each calibration scenario: -#' \deqn{\Pr(\mathrm{Go}) = \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} -#' \mathbf{1}\!\left[\hat{g}_{Go,i} \ge \gamma_{\mathrm{go}},\; -#' \hat{g}_{NoGo,i} < \gamma_{\mathrm{nogo}}\right]} -#' \deqn{\Pr(\mathrm{NoGo}) = \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} -#' \mathbf{1}\!\left[\hat{g}_{NoGo,i} \ge \gamma_{\mathrm{nogo}},\; -#' \hat{g}_{Go,i} < \gamma_{\mathrm{go}}\right]} -#' -#' \strong{Stage 3 (optimal threshold selection)}: For each candidate -#' \eqn{\gamma_{\mathrm{go}}}, the worst-case \eqn{\Pr(\mathrm{Go})} over -#' all \eqn{\gamma_{\mathrm{nogo}}} in \code{gamma_nogo_grid} is computed; -#' the optimal \eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value -#' for which this worst-case probability is less than \code{target_go}. -#' Analogously, the optimal \eqn{\gamma_{\mathrm{nogo}}} is the -#' \emph{smallest} grid value for which the worst-case -#' \eqn{\Pr(\mathrm{NoGo})} is less than \code{target_nogo}. -#' -#' @examples -#' # Example 1: Controlled design, posterior probability, vague prior -#' # gamma_go : smallest gamma_go s.t. max_{gamma_nogo} Pr(Go) < 0.05 under Null -#' # gamma_nogo: smallest gamma_nogo s.t. max_{gamma_go} Pr(NoGo) < 0.20 under Alt -#' \donttest{ -#' Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'posterior', design = 'controlled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 9L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, -#' mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma_null, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, -#' mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma_alt, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = 30L, -#' theta_TV1 = 10.0, theta_MAV1 = 5.0, -#' theta_TV2 = 2.0, theta_MAV2 = 1.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' # Example 2: Uncontrolled design, posterior probability, vague prior -#' \donttest{ -#' Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'posterior', design = 'uncontrolled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 9L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, -#' mu_c_go = NULL, Sigma_c_go = NULL, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, -#' mu_c_nogo = NULL, Sigma_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = NULL, -#' theta_TV1 = 10.0, theta_MAV1 = 5.0, -#' theta_TV2 = 2.0, theta_MAV2 = 1.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(-10.0, -1.0), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = NULL, CalcMethod = 'MM', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' # Example 3: External design (control only), posterior probability, NIW prior -#' \donttest{ -#' Sigma <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Lambda <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' se_c <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'posterior', design = 'external', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 9L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma, -#' mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma, -#' mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = 30L, -#' theta_TV1 = 10.0, theta_MAV1 = 5.0, -#' theta_TV2 = 2.0, theta_MAV2 = 1.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = 0.1, nu0_t = 4.0, mu0_t = c(0.0, 1.0), Lambda0_t = Lambda, -#' kappa0_c = 0.1, nu0_c = 4.0, mu0_c = c(-10.0, -1.0), Lambda0_c = Lambda, -#' r = NULL, -#' ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(-10.0, -1.0), se_t = NULL, se_c = se_c, -#' nMC = 500L, CalcMethod = 'MC', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' # Example 4: Controlled design, predictive probability, vague prior -#' \donttest{ -#' Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'predictive', design = 'controlled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 4L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, -#' mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma_null, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, -#' mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma_alt, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = 30L, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 5.0, theta_NULL2 = 1.0, -#' m_t = 100L, m_c = 100L, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' # Example 5: Uncontrolled design, predictive probability, vague prior -#' \donttest{ -#' Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'predictive', design = 'uncontrolled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 4L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, -#' mu_c_go = NULL, Sigma_c_go = NULL, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, -#' mu_c_nogo = NULL, Sigma_c_nogo = NULL, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = NULL, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 5.0, theta_NULL2 = 1.0, -#' m_t = 100L, m_c = 100L, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(-10.0, -1.0), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' # Example 6: External design (control only), predictive probability, NIW prior -#' \donttest{ -#' Sigma <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' Lambda <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' se_c <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -#' getgamma2cont( -#' nsim = 1000L, prob = 'predictive', design = 'external', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 4L, -#' mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma, -#' mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma, -#' mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma, -#' mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma, -#' target_go = 0.05, target_nogo = 0.20, -#' n_t = 30L, n_c = 30L, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 5.0, theta_NULL2 = 1.0, -#' m_t = 100L, m_c = 100L, -#' kappa0_t = 0.1, nu0_t = 4.0, mu0_t = c(0.0, 1.0), Lambda0_t = Lambda, -#' kappa0_c = 0.1, nu0_c = 4.0, mu0_c = c(-10.0, -1.0), Lambda0_c = Lambda, -#' r = NULL, -#' ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(-10.0, -1.0), se_t = NULL, se_c = se_c, -#' nMC = 500L, CalcMethod = 'MC', -#' gamma_go_grid = seq(0.01, 0.99, by = 0.01), -#' gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), -#' seed = 1L -#' ) -#' } -#' -#' @importFrom stats rnorm -#' @export -getgamma2cont <- function(nsim = 10000L, - prob = 'posterior', - design = 'controlled', - prior = 'vague', - GoRegions, NoGoRegions, - mu_t_go, Sigma_t_go, - mu_c_go = NULL, Sigma_c_go = NULL, - mu_t_nogo, Sigma_t_nogo, - mu_c_nogo = NULL, Sigma_c_nogo = NULL, - target_go, target_nogo, - n_t, n_c = NULL, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, - mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, - mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - nMC = NULL, - CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed) { - - # --------------------------------------------------------------------------- - # Input validation - # --------------------------------------------------------------------------- - if (!is.numeric(nsim) || length(nsim) != 1L || is.na(nsim) || - nsim != floor(nsim) || nsim < 1L) { - stop("'nsim' must be a single positive integer") - } - nsim <- as.integer(nsim) - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c('vague', 'N-Inv-Wishart')) { - stop("'prior' must be 'vague' or 'N-Inv-Wishart'") - } - - if (!is.integer(GoRegions) || length(GoRegions) < 1L || - any(is.na(GoRegions)) || any(GoRegions < 1L) || any(GoRegions > 9L)) { - stop("'GoRegions' must be an integer vector with all values in 1:9") - } - if (!is.integer(NoGoRegions) || length(NoGoRegions) < 1L || - any(is.na(NoGoRegions)) || any(NoGoRegions < 1L) || - any(NoGoRegions > 9L)) { - stop("'NoGoRegions' must be an integer vector with all values in 1:9") - } - if (length(intersect(GoRegions, NoGoRegions)) > 0L) { - stop("'GoRegions' and 'NoGoRegions' must be disjoint") - } - - # Validate Go-calibration scenario parameters - if (!is.numeric(mu_t_go) || length(mu_t_go) != 2L || any(is.na(mu_t_go))) { - stop("'mu_t_go' must be a length-2 numeric vector") - } - if (!is.matrix(Sigma_t_go) || !all(dim(Sigma_t_go) == c(2L, 2L)) || - !is.numeric(Sigma_t_go) || any(is.na(Sigma_t_go))) { - stop("'Sigma_t_go' must be a 2x2 numeric matrix") - } - - # Validate NoGo-calibration scenario parameters - if (!is.numeric(mu_t_nogo) || length(mu_t_nogo) != 2L || any(is.na(mu_t_nogo))) { - stop("'mu_t_nogo' must be a length-2 numeric vector") - } - if (!is.matrix(Sigma_t_nogo) || !all(dim(Sigma_t_nogo) == c(2L, 2L)) || - !is.numeric(Sigma_t_nogo) || any(is.na(Sigma_t_nogo))) { - stop("'Sigma_t_nogo' must be a 2x2 numeric matrix") - } - - if (design != 'uncontrolled') { - if (is.null(mu_c_go) || !is.numeric(mu_c_go) || length(mu_c_go) != 2L || - any(is.na(mu_c_go))) { - stop("'mu_c_go' must be a length-2 numeric vector for controlled or external design") - } - if (is.null(Sigma_c_go) || !is.matrix(Sigma_c_go) || - !all(dim(Sigma_c_go) == c(2L, 2L)) || !is.numeric(Sigma_c_go) || - any(is.na(Sigma_c_go))) { - stop("'Sigma_c_go' must be a 2x2 numeric matrix for controlled or external design") - } - if (is.null(mu_c_nogo) || !is.numeric(mu_c_nogo) || length(mu_c_nogo) != 2L || - any(is.na(mu_c_nogo))) { - stop("'mu_c_nogo' must be a length-2 numeric vector for controlled or external design") - } - if (is.null(Sigma_c_nogo) || !is.matrix(Sigma_c_nogo) || - !all(dim(Sigma_c_nogo) == c(2L, 2L)) || !is.numeric(Sigma_c_nogo) || - any(is.na(Sigma_c_nogo))) { - stop("'Sigma_c_nogo' must be a 2x2 numeric matrix for controlled or external design") - } - } - - for (nm in c("target_go", "target_nogo")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val >= 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1)")) - } - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) { - stop("'n_t' must be a single positive integer") - } - if (design != 'uncontrolled') { - if (is.null(n_c) || !is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) { - stop("'n_c' must be a single positive integer for controlled or external design") - } - } - - if (prob == 'posterior') { - for (nm in c("theta_TV1", "theta_MAV1", "theta_TV2", "theta_MAV2")) { - if (is.null(get(nm))) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'posterior'")) - } - } - if (theta_TV1 <= theta_MAV1) { - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - } - if (theta_TV2 <= theta_MAV2) { - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } - } else { - for (nm in c("theta_NULL1", "theta_NULL2")) { - if (is.null(get(nm))) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'predictive'")) - } - } - if (is.null(m_t) || !is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer when prob = 'predictive'") - } - if (is.null(m_c) || !is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer when prob = 'predictive'") - } - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c('MC', 'MM')) { - stop("'CalcMethod' must be either 'MC' or 'MM'") - } - if (CalcMethod == 'MC') { - if (is.null(nMC) || !is.numeric(nMC) || length(nMC) != 1L || - is.na(nMC) || nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer when CalcMethod = 'MC'") - } - } - - for (gname in c("gamma_go_grid", "gamma_nogo_grid")) { - gval <- get(gname) - if (!is.numeric(gval) || length(gval) < 1L || - any(is.na(gval)) || any(gval <= 0) || any(gval >= 1)) { - stop(paste0("'", gname, "' must be a numeric vector with all values in (0, 1)")) - } - } - gamma_go_grid <- sort(unique(gamma_go_grid)) - gamma_nogo_grid <- sort(unique(gamma_nogo_grid)) - if (!identical(gamma_go_grid, gamma_nogo_grid)) { - stop("'gamma_go_grid' and 'gamma_nogo_grid' must be identical vectors") - } - gamma_grid <- gamma_go_grid - ng <- length(gamma_grid) - - if (!is.numeric(seed) || length(seed) != 1L || is.na(seed)) { - stop("'seed' must be a single numeric value") - } - - # --------------------------------------------------------------------------- - # Internal helper: simulate nsim datasets and return PrGo_vec, PrNoGo_vec - # --------------------------------------------------------------------------- - .simulate_g <- function(mu_t_s, Sigma_t_s, mu_c_s, Sigma_c_s, seed_val) { - set.seed(seed_val) - - n_t_int <- as.integer(n_t) - R_Sigma_t <- chol(Sigma_t_s) - Z_t_raw <- matrix(rnorm(nsim * n_t_int * 2L), - nrow = nsim * n_t_int, ncol = 2L) %*% R_Sigma_t - block_t <- rep(seq_len(nsim), each = n_t_int) - Z_t_colsums <- apply(Z_t_raw, 2L, function(col) tapply(col, block_t, sum)) - Z_t_colmeans_rep <- Z_t_colsums[block_t, ] / n_t_int - Z_t_centered <- Z_t_raw - Z_t_colmeans_rep - S_t_11 <- tapply(Z_t_centered[, 1L] ^ 2, block_t, sum) - S_t_12 <- tapply(Z_t_centered[, 1L] * Z_t_centered[, 2L], block_t, sum) - S_t_22 <- tapply(Z_t_centered[, 2L] ^ 2, block_t, sum) - ybar_t <- sweep(Z_t_colsums / n_t_int, 2L, mu_t_s, '+') - S_t_list <- vector('list', nsim) - for (i in seq_len(nsim)) { - S_t_list[[i]] <- matrix(c(S_t_11[i], S_t_12[i], S_t_12[i], S_t_22[i]), - nrow = 2L, ncol = 2L) - } - - if (design %in% c('controlled', 'external')) { - n_c_int <- as.integer(n_c) - R_Sigma_c <- chol(Sigma_c_s) - Z_c_raw <- matrix(rnorm(nsim * n_c_int * 2L), - nrow = nsim * n_c_int, ncol = 2L) %*% R_Sigma_c - block_c <- rep(seq_len(nsim), each = n_c_int) - Z_c_colsums <- apply(Z_c_raw, 2L, function(col) tapply(col, block_c, sum)) - Z_c_colmeans_rep <- Z_c_colsums[block_c, ] / n_c_int - Z_c_centered <- Z_c_raw - Z_c_colmeans_rep - S_c_11 <- tapply(Z_c_centered[, 1L] ^ 2, block_c, sum) - S_c_12 <- tapply(Z_c_centered[, 1L] * Z_c_centered[, 2L], block_c, sum) - S_c_22 <- tapply(Z_c_centered[, 2L] ^ 2, block_c, sum) - ybar_c <- sweep(Z_c_colsums / n_c_int, 2L, mu_c_s, '+') - S_c_list <- vector('list', nsim) - for (i in seq_len(nsim)) { - S_c_list[[i]] <- matrix(c(S_c_11[i], S_c_12[i], S_c_12[i], S_c_22[i]), - nrow = 2L, ncol = 2L) - } - } else { - ybar_c <- NULL - S_c_list <- NULL - n_c_int <- NULL - } - - # Vectorised call to pbayespostpred2cont: returns nsim x n_regions matrix - Pr_R_mat <- pbayespostpred2cont( - prob = prob, - design = design, - prior = prior, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - n_t = n_t_int, n_c = n_c_int, - ybar_t = ybar_t, S_t = S_t_list, - ybar_c = ybar_c, S_c = S_c_list, - m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, nu0_t = nu0_t, - mu0_t = mu0_t, Lambda0_t = Lambda0_t, - kappa0_c = kappa0_c, nu0_c = nu0_c, - mu0_c = mu0_c, Lambda0_c = Lambda0_c, - r = r, - ne_t = ne_t, ne_c = ne_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, - se_t = se_t, se_c = se_c, - nMC = nMC, - CalcMethod = CalcMethod - ) - - # Sum region probabilities over GoRegions and NoGoRegions - PrGo_vec <- rowSums(Pr_R_mat[, GoRegions, drop = FALSE]) - PrNoGo_vec <- rowSums(Pr_R_mat[, NoGoRegions, drop = FALSE]) - - list(PrGo_vec = PrGo_vec, PrNoGo_vec = PrNoGo_vec) - } - - # --------------------------------------------------------------------------- - # Stage 1: Simulate nsim datasets for each calibration scenario independently - # --------------------------------------------------------------------------- - # Go-calibration scenario (typically Null): use seed - sim_go <- .simulate_g(mu_t_go, Sigma_t_go, mu_c_go, Sigma_c_go, - seed_val = seed) - # NoGo-calibration scenario (typically Alternative): use seed + 1 - sim_nogo <- .simulate_g(mu_t_nogo, Sigma_t_nogo, mu_c_nogo, Sigma_c_nogo, - seed_val = seed + 1L) - - PrGo_vec_go <- sim_go$PrGo_vec - PrNoGo_vec_nogo <- sim_nogo$PrNoGo_vec - - # --------------------------------------------------------------------------- - # Stage 2: Marginal sweep over gamma_grid - # - # Go and NoGo probabilities are computed marginally (independently): - # Pr(Go) = mean( I(PrGo_vec_go >= g) ) - # Pr(NoGo) = mean( I(PrNoGo_vec_nogo >= g) ) - # --------------------------------------------------------------------------- - PrGo_grid <- numeric(ng) - PrNoGo_grid <- numeric(ng) - - for (k in seq_len(ng)) { - g <- gamma_grid[k] - PrGo_grid[k] <- mean(PrGo_vec_go >= g) - PrNoGo_grid[k] <- mean(PrNoGo_vec_nogo >= g) - } - - # --------------------------------------------------------------------------- - # Stage 3: Select optimal (gamma_go, gamma_nogo) - # - # gamma_go : smallest value in gamma_grid s.t. Pr(Go) < target_go - # gamma_nogo: smallest value in gamma_grid s.t. Pr(NoGo) < target_nogo - # Both curves are non-increasing in gamma. - # --------------------------------------------------------------------------- - idx_go <- which(PrGo_grid < target_go) - if (length(idx_go) == 0L) { - gamma_go <- NA_real_ - PrGo_opt <- NA_real_ - } else { - opt1 <- min(idx_go) - gamma_go <- gamma_grid[opt1] - PrGo_opt <- PrGo_grid[opt1] - } - - idx_nogo <- which(PrNoGo_grid < target_nogo) - if (length(idx_nogo) == 0L) { - gamma_nogo <- NA_real_ - PrNoGo_opt <- NA_real_ - } else { - opt2 <- min(idx_nogo) - gamma_nogo <- gamma_grid[opt2] - PrNoGo_opt <- PrNoGo_grid[opt2] - } - - # --------------------------------------------------------------------------- - # Build and return result - # --------------------------------------------------------------------------- - result <- list( - gamma_go = gamma_go, - gamma_nogo = gamma_nogo, - PrGo_opt = PrGo_opt, - PrNoGo_opt = PrNoGo_opt, - target_go = target_go, - target_nogo = target_nogo, - grid_results = data.frame( - gamma_grid = gamma_grid, - PrGo_grid = PrGo_grid, - PrNoGo_grid = PrNoGo_grid - ) - ) - - class(result) <- 'getgamma2cont' - return(result) -} diff --git a/R/getjointbin.R b/R/getjointbin.R deleted file mode 100644 index 98a1b0a..0000000 --- a/R/getjointbin.R +++ /dev/null @@ -1,159 +0,0 @@ -#' Compute Joint Bivariate Binary Probabilities from Marginal Rates -#' and Correlation -#' -#' Converts the parameterisation \eqn{(\pi_{j1}, \pi_{j2}, \rho_j)} into the -#' four-cell joint probability vector -#' \eqn{(p_{j,00}, p_{j,01}, p_{j,10}, p_{j,11})} for a bivariate binary -#' outcome in group \eqn{j \in \{t, c\}}. The conversion uses the standard -#' moment-matching identity for the Pearson correlation of two Bernoulli -#' variables, and checks that the requested correlation is feasible for the -#' supplied marginal rates. -#' -#' @param pi1 A single numeric value in \code{(0, 1)} giving the marginal -#' response probability for Endpoint 1 (\eqn{\pi_{j1}}) in group -#' \eqn{j}. -#' @param pi2 A single numeric value in \code{(0, 1)} giving the marginal -#' response probability for Endpoint 2 (\eqn{\pi_{j2}}) in group -#' \eqn{j}. -#' @param rho A single numeric value giving the Pearson correlation -#' (\eqn{\rho_j}) between Endpoint 1 and Endpoint 2 in group \eqn{j}. -#' Must lie within the feasible range -#' \eqn{[\rho_{\min}, \rho_{\max}]} determined by \code{pi1} and -#' \code{pi2} (see Details). Use \code{rho = 0} for independence. -#' @param tol A single positive numeric value specifying the tolerance used -#' when checking whether \code{rho} lies within its feasible range and -#' whether the resulting probabilities are non-negative. -#' Default is \code{1e-10}. -#' -#' @return A named numeric vector of length 4 with elements -#' \code{p00}, \code{p01}, \code{p10}, \code{p11}, where -#' \code{p_lm = Pr(Endpoint 1 = l, Endpoint 2 = m)} for -#' \eqn{l, m \in \{0, 1\}}. -#' All elements are non-negative and sum to 1. -#' -#' @details -#' For a bivariate binary outcome \eqn{(Y_{i1}, Y_{i2})} of patient -#' \eqn{i} (\eqn{i = 1, \ldots, n_j}) in group \eqn{j} with marginal success -#' probabilities \eqn{\pi_{j1} = \Pr(Y_{i1} = 1)} and -#' \eqn{\pi_{j2} = \Pr(Y_{i2} = 1)}, the Pearson correlation is -#' \deqn{ -#' \rho_j = \frac{p_{j,11} - \pi_{j1} \pi_{j2}} -#' {\sqrt{\pi_{j1}(1 - \pi_{j1})\, \pi_{j2}(1 - \pi_{j2})}}. -#' } -#' Solving for \eqn{p_{j,11}} gives -#' \deqn{p_{j,11} = \rho_j \sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})} -#' + \pi_{j1} \pi_{j2},} -#' from which the remaining probabilities follow: -#' \deqn{p_{j,10} = \pi_{j1} - p_{j,11}, \quad -#' p_{j,01} = \pi_{j2} - p_{j,11}, \quad -#' p_{j,00} = 1 - p_{j,10} - p_{j,01} - p_{j,11}.} -#' -#' For all four cell probabilities to lie in \code{[0, 1]}, the correlation -#' must satisfy -#' \deqn{ -#' \rho_{\min} = -#' \frac{\max(0,\; \pi_{j1} + \pi_{j2} - 1) - \pi_{j1}\pi_{j2}} -#' {\sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})}} -#' \;\le\; \rho_j \;\le\; -#' \frac{\min(\pi_{j1}, \pi_{j2}) - \pi_{j1}\pi_{j2}} -#' {\sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})}} -#' = \rho_{\max}. -#' } -#' The function raises an error if \code{rho} falls outside this range -#' (subject to \code{tol}). -#' -#' @examples -#' # Example 1: Independent endpoints (rho = 0) -#' getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.0) -#' -#' # Example 2: Positive correlation -#' getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.3) -#' -#' # Example 3: Negative correlation -#' getjointbin(pi1 = 0.3, pi2 = 0.4, rho = -0.2) -#' -#' # Example 4: Verify cell probabilities sum to 1 -#' p <- getjointbin(pi1 = 0.25, pi2 = 0.35, rho = 0.1) -#' sum(p) # Should be 1 -#' -#' # Example 5: Verify marginal recovery -#' p <- getjointbin(pi1 = 0.25, pi2 = 0.35, rho = 0.1) -#' p["p10"] + p["p11"] # Should equal pi1 = 0.25 -#' p["p01"] + p["p11"] # Should equal pi2 = 0.35 -#' -#' @export -getjointbin <- function(pi1, pi2, rho, tol = 1e-10) { - - # --- Input validation --- - if (!is.numeric(pi1) || length(pi1) != 1L || is.na(pi1) || - pi1 <= 0 || pi1 >= 1) { - stop("'pi1' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(pi2) || length(pi2) != 1L || is.na(pi2) || - pi2 <= 0 || pi2 >= 1) { - stop("'pi2' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(rho) || length(rho) != 1L || is.na(rho)) { - stop("'rho' must be a single numeric value") - } - - if (!is.numeric(tol) || length(tol) != 1L || is.na(tol) || tol <= 0) { - stop("'tol' must be a single positive numeric value") - } - - # --- Compute the standard deviation product (denominator of rho formula) --- - # denom = sqrt(pi1 * (1 - pi1) * pi2 * (1 - pi2)) - denom <- sqrt(pi1 * (1 - pi1) * pi2 * (1 - pi2)) - - # --- Compute feasible range of rho given (pi1, pi2) --- - # Lower bound: p11 >= max(0, pi1 + pi2 - 1) => rho >= rho_min - # Upper bound: p11 <= min(pi1, pi2) => rho <= rho_max - rho_min <- (max(0, pi1 + pi2 - 1) - pi1 * pi2) / denom - rho_max <- (min(pi1, pi2) - pi1 * pi2) / denom - - # --- Check feasibility of rho --- - if (rho < rho_min - tol || rho > rho_max + tol) { - stop(sprintf( - paste0("'rho' = %.6f is infeasible for pi1 = %.4f, pi2 = %.4f.\n", - " Feasible range: [%.6f, %.6f]"), - rho, pi1, pi2, rho_min, rho_max - )) - } - - # Clamp rho to the feasible range to avoid tiny numerical violations - rho <- min(max(rho, rho_min), rho_max) - - # --- Recover the four joint probabilities --- - # p11 is derived from the rho formula rearranged for p11 - p11 <- rho * denom + pi1 * pi2 - - # Clamp p11 to its valid interval [max(0, pi1+pi2-1), min(pi1, pi2)] - # to absorb any residual floating-point error - p11 <- min(max(p11, max(0, pi1 + pi2 - 1)), min(pi1, pi2)) - - p10 <- pi1 - p11 - p01 <- pi2 - p11 - p00 <- 1 - p10 - p01 - p11 - - # Assemble the probability vector (order: 00, 01, 10, 11) - p <- c(p00 = p00, p01 = p01, p10 = p10, p11 = p11) - - # --- Sanity checks on the resulting probabilities --- - if (any(p < -tol)) { - stop(sprintf( - paste0("Computed joint probabilities contain a negative value ", - "(min = %.2e). This should not occur; please check inputs."), - min(p) - )) - } - - # Replace tiny negative values caused by floating-point arithmetic with 0 - p[p < 0] <- 0 - - # Re-normalise to ensure exact summation to 1 - p <- p / sum(p) - - return(p) -} diff --git a/R/hypothetical.R b/R/hypothetical.R new file mode 100644 index 0000000..6681b8a --- /dev/null +++ b/R/hypothetical.R @@ -0,0 +1,75 @@ +#' Hypothetical control for an uncontrolled study +#' +#' Specifies the distribution of a hypothetical control group, used when the +#' proof-of-concept study has no concurrent control group (Kang et al., 2026). +#' +#' For binary and time-to-event endpoints, give \code{data}: the +#' hypothetical control data are combined with the prior of the control +#' group, for example \eqn{\pi_c \sim \textrm{Beta}(a_c + y, b_c + n - y)} +#' for one binary endpoint, or a Gamma distribution of the hazard with shape +#' \eqn{a_c + d} and rate \eqn{b_c + E} for \eqn{d} events in the total +#' observed time \eqn{E}. For continuous endpoints, give \code{mean} and \code{r}: the +#' control mean has the same t distribution as the posterior distribution of +#' the treatment mean, with location \code{mean} and squared scale multiplied +#' by \code{r}, that is +#' \eqn{\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 / \kappa_{nt})}. +#' +#' @param data Hypothetical control data created by +#' \code{\link{data_binary}}, \code{\link{data_binary2}} (binary +#' endpoints) or \code{\link{data_tte}} (time-to-event endpoint). +#' @param mean Location of the hypothetical control mean, a number for one +#' continuous endpoint or a numeric vector of length 2 for two continuous +#' endpoints. +#' @param r Positive ratio of the squared scale of the hypothetical control to +#' that of the treatment group (continuous endpoints). +#' +#' @return An object of class \code{"qdm_hypothetical"} with elements +#' \code{type} (\code{"data"} or \code{"location"}), \code{data}, +#' \code{mean} and \code{r}. +#' +#' @references +#' Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +#' decision-making framework in cell and gene therapy development for rare +#' diseases. \emph{Journal of Biopharmaceutical Statistics}. +#' \doi{10.1080/10543406.2026.2655410} +#' +#' @examples +#' # Binary endpoint: 5 responders out of 15 hypothetical control subjects +#' hypothetical(data = data_binary(n = 15, y = 5)) +#' +#' # Continuous endpoint: control mean located at 1 with the same scale +#' hypothetical(mean = 1, r = 1) +#' +#' # Time-to-event endpoint: 8 events in a total observed time of 60 +#' hypothetical(data = data_tte(events = 8, exposure = 60)) +#' @export +hypothetical <- function(data = NULL, mean = NULL, r = NULL) { + has_data <- !is.null(data) + has_location <- !is.null(mean) || !is.null(r) + if (has_data == has_location) { + stop(paste("Specify either 'data' (binary and time-to-event endpoints)", + "or both 'mean' and 'r' (continuous endpoints)."), + call. = FALSE) + } + if (has_data) { + if (!inherits(data, c("qdm_data_binary", "qdm_data_binary2", + "qdm_data_tte"))) { + stop(paste("'data' must be created by data_binary(), data_binary2()", + "or data_tte()."), call. = FALSE) + } + out <- list(type = "data", data = data, mean = NULL, r = NULL) + } else { + if (is.null(mean) || is.null(r)) { + stop("Both 'mean' and 'r' must be specified for continuous endpoints.", + call. = FALSE) + } + if (!(length(mean) %in% c(1L, 2L))) { + stop("'mean' must have length 1 or 2.", call. = FALSE) + } + check_numeric(mean, "mean", len = length(mean)) + check_numeric(r, "r", lower = 0, lower_open = TRUE) + out <- list(type = "location", data = NULL, mean = as.numeric(mean), + r = r) + } + structure(out, class = "qdm_hypothetical") +} diff --git a/R/mean_dist_continuous2.R b/R/mean_dist_continuous2.R new file mode 100644 index 0000000..c5b0c1c --- /dev/null +++ b/R/mean_dist_continuous2.R @@ -0,0 +1,26 @@ +#' Distribution of the mean of a group with two continuous endpoints +#' +#' The posterior distribution of the mean is +#' \eqn{t_{\nu - 1}(\mu, \Lambda / (\kappa (\nu - 1)))}, and the posterior +#' predictive distribution of the mean of \eqn{m} future subjects is +#' \eqn{t_{\nu - 1}(\mu, (1 / \kappa + 1 / m) \Lambda / (\nu - 1))}. +#' +#' @param post Parameters of the group (see \code{posterior_continuous2()}). +#' @param type \code{"posterior"} or \code{"predictive"}. +#' @param m Number of future subjects (predictive only). +#' +#' @return A list with elements \code{loc} (matrix with two columns), +#' \code{scale} (matrix with the columns \code{V11}, \code{V12} and +#' \code{V22}) and \code{df} (a number). +#' @noRd +mean_dist_continuous2 <- function(post, type, m = NULL) { + df <- post$nu - 1 + f <- if (type == "posterior") { + 1 / (post$kappa * df) + } else { + (1 / post$kappa + 1 / m) / df + } + scale <- f * post$Lambda + dimnames(scale) <- list(NULL, c("V11", "V12", "V22")) + list(loc = post$mu, scale = scale, df = df) +} diff --git a/R/meets_criterion.R b/R/meets_criterion.R new file mode 100644 index 0000000..fd3f65b --- /dev/null +++ b/R/meets_criterion.R @@ -0,0 +1,21 @@ +#' Whether a Go or NoGo criterion is met +#' +#' @param p Probabilities: a vector or matrix for one probability, or a list +#' of two (one per endpoint) for the marginal rules. For a single decision +#' under a marginal rule, a numeric vector of length 2 is also accepted. +#' @param gamma Threshold(s): one number, or one per endpoint. +#' @param rule One of \code{"joint"}, \code{"and"} or \code{"or"}. +#' +#' @return A logical vector or matrix (see \code{meets_threshold()}). +#' @noRd +meets_criterion <- function(p, gamma, rule = "joint") { + if (rule == "joint") { + return(meets_threshold(p, gamma)) + } + if (!is.list(p)) { + p <- as.list(p) + } + a <- meets_threshold(p[[1L]], gamma[1L]) + b <- meets_threshold(p[[2L]], gamma[2L]) + if (rule == "and") a & b else a | b +} diff --git a/R/meets_threshold.R b/R/meets_threshold.R new file mode 100644 index 0000000..362028a --- /dev/null +++ b/R/meets_threshold.R @@ -0,0 +1,16 @@ +#' Compare probabilities with a decision threshold +#' +#' A probability meets a threshold if it is at least the threshold. Values +#' below the threshold by less than \code{tol} are treated as equal to it, so +#' that ties that arise in symmetric settings (for example a posterior +#' probability of exactly 0.5) are not decided by rounding errors. +#' +#' @param p Numeric vector or matrix of probabilities. +#' @param gamma A single threshold. +#' @param tol Tolerance. +#' +#' @return A logical vector or matrix of the same shape as \code{p}. +#' @noRd +meets_threshold <- function(p, gamma, tol = 1e-10) { + p >= gamma - tol +} diff --git a/R/met_curve.R b/R/met_curve.R new file mode 100644 index 0000000..9e93239 --- /dev/null +++ b/R/met_curve.R @@ -0,0 +1,25 @@ +#' Probability that a criterion is met, as a function of the threshold +#' +#' @param p Probabilities of a region, one per outcome: a numeric vector, a +#' matrix over pairs of treatment and control outcomes, or a list of two +#' (one per endpoint) for the marginal rules. +#' @param w Probabilities of the outcomes: a numeric vector, or a list with +#' elements \code{t} and \code{c} for a matrix \code{p} over pairs (see +#' \code{sample_weights()}). +#' @param grid Numeric vector of thresholds. +#' @param rule One of \code{"joint"}, \code{"and"} or \code{"or"}; for the +#' marginal rules, the same threshold is used for both endpoints. +#' +#' @return A numeric vector of the same length as \code{grid}. +#' @noRd +met_curve <- function(p, w, grid, rule = "joint") { + k <- if (rule == "joint") 1L else 2L + vapply(grid, function(g) { + ind <- meets_criterion(p, rep(g, k), rule) + if (is.list(w)) { + sum(w$t * (ind %*% w$c)) + } else { + sum(w[ind]) + } + }, numeric(1)) +} diff --git a/R/method_label.R b/R/method_label.R new file mode 100644 index 0000000..f61ca8d --- /dev/null +++ b/R/method_label.R @@ -0,0 +1,18 @@ +#' Description of the method used to compute probabilities +#' +#' @param method One of \code{"NI"}, \code{"MM"} or \code{"MC"}. +#' @param nMC Number of Monte Carlo draws. +#' @param fixed Logical; if \code{TRUE} (fixed control), the probabilities +#' are computed exactly whatever the method. +#' +#' @return A character string. +#' @noRd +method_label <- function(method, nMC, fixed = FALSE) { + if (fixed) { + return("exact computation (fixed control)") + } + switch(method, + NI = "numerical integration", + MM = "moment-matching approximation", + MC = sprintf("Monte Carlo simulation (nMC = %d)", nMC)) +} diff --git a/R/oc_axis.R b/R/oc_axis.R new file mode 100644 index 0000000..727535b --- /dev/null +++ b/R/oc_axis.R @@ -0,0 +1,55 @@ +#' Horizontal axis of a plot of operating characteristics +#' +#' For a design with a concurrent control group, the axis is the true +#' treatment effect of each scenario and the thresholds of the criterion are +#' drawn at their values. Otherwise the axis is the true parameter of the +#' treatment group, and the thresholds are shifted by the fixed control value, +#' or by the mean (binary and time-to-event endpoints) or the location +#' (continuous endpoint) of the distribution of the control group. For a +#' time-to-event endpoint the parameter is the milestone survival +#' probability \eqn{\exp(-\log(2) t_0 / M)} for the median survival time +#' \eqn{M} of the scenario. +#' +#' @param design An object of class \code{"qdm_design"}. +#' @param x The scenarios (a data frame). +#' +#' @return A list with elements \code{x} (axis values), \code{xlab} +#' (expression), \code{lines} (positions of the thresholds), \code{labels} +#' (plotmath labels of the thresholds) and \code{caption}. +#' @noRd +oc_axis <- function(design, x) { + crit <- design$criterion + if (crit$type == "posterior") { + lines <- c(crit$theta_mav, crit$theta_tv) + labels <- c("theta[MAV]", "theta[TV]") + } else { + lines <- crit$theta_null + labels <- "theta[NULL]" + } + par <- switch( + design$endpoint, + binary = list(t = x$pi_t, c = x$pi_c, + xlab = expression(theta == pi[t] - pi[c]), + xlab_t = expression(pi[t]), center = "mean"), + continuous = list(t = x$mu_t, c = x$mu_c, + xlab = expression(theta == mu[t] - mu[c]), + xlab_t = expression(mu[t]), center = "location"), + tte = list(t = exp(-log(2) * design$milestone / x$median_t), + c = exp(-log(2) * design$milestone / x$median_c), + xlab = expression(theta == S[t](t[0]) - S[c](t[0])), + xlab_t = expression(S[t](t[0])), center = "mean") + ) + if (design$control == "concurrent") { + return(list(x = par$t - par$c, xlab = par$xlab, lines = lines, + labels = labels, caption = NULL)) + } + center <- control_location(design) + what <- if (design$control == "fixed") { + "fixed control value" + } else { + paste(par$center, "of the control distribution") + } + list(x = par$t, xlab = par$xlab_t, lines = center + lines, labels = labels, + caption = sprintf("Thresholds shifted by the %s (%s)", what, + format_num(center, 3L))) +} diff --git a/R/oc_from_sample.R b/R/oc_from_sample.R new file mode 100644 index 0000000..f17026d --- /dev/null +++ b/R/oc_from_sample.R @@ -0,0 +1,19 @@ +#' Decision probabilities from outcomes and their probabilities +#' +#' @param sample A list returned by \code{oc_sample()}. +#' @param gamma_go,gamma_nogo Thresholds of the Go and NoGo criteria. +#' @param rule One of \code{"joint"}, \code{"and"} or \code{"or"}. +#' +#' @return A matrix with one row per scenario and columns \code{Go}, +#' \code{NoGo}, \code{Gray} and \code{Miss} (\code{NA} for scenarios that +#' are not evaluable). +#' @noRd +oc_from_sample <- function(sample, gamma_go, gamma_nogo, rule = "joint") { + go <- meets_criterion(sample$p_go, gamma_go, rule) + nogo <- meets_criterion(sample$p_nogo, gamma_nogo, rule) + out <- cbind(Go = outcome_prob(go & !nogo, sample), + NoGo = outcome_prob(!go & nogo, sample), + Gray = outcome_prob(!go & !nogo, sample), + Miss = outcome_prob(go & nogo, sample)) + pmin(pmax(out, 0), 1) +} diff --git a/R/oc_sample.R b/R/oc_sample.R new file mode 100644 index 0000000..8c68f17 --- /dev/null +++ b/R/oc_sample.R @@ -0,0 +1,27 @@ +#' Outcomes of a design and their probabilities +#' +#' Dispatches to the function for the endpoint of the design. For one binary +#' endpoint all outcomes are enumerated and \code{nsim} is not used; for +#' continuous and time-to-event endpoints \code{nsim} studies are simulated; +#' for two binary endpoints the outcomes are enumerated or simulated as +#' specified by the design. +#' +#' @param design An object of class \code{"qdm_design"}. +#' @param scenarios Data frame of scenarios (checked). +#' @param nsim Number of simulated data sets (simulation-based endpoints). +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (vectors or +#' matrices, or lists of two for the marginal rules of two endpoints), +#' \code{per_scenario} (whether they have one column per scenario), the +#' probabilities of the outcomes (\code{weights}, or \code{weights_t} and +#' \code{weights_c} for enumerated pairs of outcomes; see +#' \code{outcome_prob()}) and \code{method}. +#' @noRd +oc_sample <- function(design, scenarios, nsim) { + switch(design$endpoint, + binary = oc_sample_binary(design, scenarios), + continuous = oc_sample_continuous(design, scenarios, nsim), + binary2 = oc_sample_binary2(design, scenarios, nsim), + continuous2 = oc_sample_continuous2(design, scenarios, nsim), + tte = oc_sample_tte(design, scenarios, nsim)) +} diff --git a/R/oc_sample_binary.R b/R/oc_sample_binary.R new file mode 100644 index 0000000..da7a1b5 --- /dev/null +++ b/R/oc_sample_binary.R @@ -0,0 +1,49 @@ +#' Outcomes of a binary design and their probabilities +#' +#' Enumerates all possible outcomes of the proof-of-concept study of a binary +#' design, computes the probabilities of the Go and NoGo regions for each +#' outcome, and the probability of each outcome under each scenario. +#' +#' @param design An object of class \code{"qdm_design_binary"}. +#' @param scenarios Data frame of scenarios (checked). +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (vectors over +#' the outcomes), \code{per_scenario} (\code{FALSE}), \code{weights} +#' (matrix of outcome probabilities with one column per scenario) and +#' \code{method}. +#' @noRd +oc_sample_binary <- function(design, scenarios) { + n_t <- design$n_t + y_t <- 0:n_t + post_t <- posterior_binary(design$prior_t, n_t, y_t, + external = design$external_t) + # Binomial probabilities: one row per outcome, one column per scenario + w_t <- vapply(scenarios$pi_t, function(p) stats::dbinom(y_t, n_t, p), + numeric(n_t + 1L)) + if (design$control == "concurrent") { + n_c <- design$n_c + y_c <- 0:n_c + post_c <- posterior_binary(design$prior_c, n_c, y_c, + external = design$external_c) + w_c <- vapply(scenarios$pi_c, function(p) stats::dbinom(y_c, n_c, p), + numeric(n_c + 1L)) + # Pairs (y_t, y_c) with y_t varying fastest + i_t <- rep(seq_along(y_t), times = n_c + 1L) + i_c <- rep(seq_along(y_c), each = n_t + 1L) + weights <- w_t[i_t, , drop = FALSE] * w_c[i_c, , drop = FALSE] + p <- region_prob_binary(design$criterion, post_t$a[i_t], post_t$b[i_t], + post_c$a[i_c], post_c$b[i_c]) + } else { + post_c <- if (design$control == "fixed") { + NULL + } else { + posterior_binary(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + } + weights <- w_t + p <- region_prob_binary(design$criterion, post_t$a, post_t$b, post_c$a, + post_c$b, fixed = design$fixed_c) + } + list(p_go = p$go, p_nogo = p$nogo, per_scenario = FALSE, + weights = weights, method = "exact enumeration of the outcomes") +} diff --git a/R/oc_sample_binary2.R b/R/oc_sample_binary2.R new file mode 100644 index 0000000..4e0cf3a --- /dev/null +++ b/R/oc_sample_binary2.R @@ -0,0 +1,150 @@ +#' Outcomes of a design with two binary endpoints and their probabilities +#' +#' With \code{design$enumerate = TRUE}, all outcomes of the proof-of-concept +#' study are enumerated (Yamaguchi et al., submitted, equation A.5): the +#' probabilities of the Go and NoGo regions are computed for every pair of +#' treatment and control outcomes, and the probability of a pair under a +#' scenario is the product of the multinomial probabilities of the two +#' outcomes (kept as one matrix per group); enumeration is limited to 1e7 +#' pairs of outcomes. Otherwise \code{nsim} studies are +#' simulated under each scenario with common random numbers (see +#' \code{simulate_counts_binary2()}); the uniform random numbers are drawn +#' for the treatment group and then for the concurrent control group, and the +#' probabilities of the regions are computed once for each distinct pair of +#' outcomes. A scenario whose correlation is infeasible for its response +#' rates is not evaluable: its probabilities are \code{NA} and a warning is +#' given. +#' +#' @param design An object of class \code{"qdm_design_binary2"}. +#' @param scenarios Data frame of scenarios (checked). +#' @param nsim Number of simulated studies (simulation only). +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (a matrix, or +#' a list of two matrices for the marginal rules), \code{per_scenario} +#' (whether the matrices have one column per scenario), either +#' \code{weights} (simulation) or \code{weights_t} and \code{weights_c} +#' (enumeration; one column per scenario), and \code{method}. +#' @noRd +oc_sample_binary2 <- function(design, scenarios, nsim) { + crit <- design$criterion + sets <- region_sets(crit) + n_go <- length(sets$go) + concurrent <- design$control == "concurrent" + n_scen <- nrow(scenarios) + cells_t <- cellprob_scenarios(scenarios$pi_t1, scenarios$pi_t2, + scenarios$rho_t) + bad <- is.na(cells_t[, 1L]) + if (concurrent) { + cells_c <- cellprob_scenarios(scenarios$pi_c1, scenarios$pi_c2, + scenarios$rho_c) + bad <- bad | is.na(cells_c[, 1L]) + } + if (any(bad)) { + warning(sprintf(paste("Scenario(s) %s are not evaluable: the", + "correlation is outside the feasible range for", + "the response rates. Their probabilities are NA."), + paste(which(bad), collapse = ", ")), call. = FALSE) + } + prob_label <- if (crit$type == "posterior") { + sprintf("posterior probabilities by Monte Carlo simulation (nMC = %d)", + design$nMC) + } else { + "predictive probabilities computed exactly" + } + # Distribution of the control group without a concurrent control (NULL for + # a fixed control) + alpha_nc <- if (concurrent || design$control == "fixed") { + NULL + } else { + posterior_binary2(design$prior_c, c(0, 0, 0, 0), + external = design$external_c, + hypothetical = design$hypothetical_c) + } + if (design$enumerate) { + n_pairs <- choose(design$n_t + 3, 3) * + (if (concurrent) choose(design$n_c + 3, 3) else 1) + if (n_pairs > 1e7) { + stop(sprintf(paste("Enumerating all outcomes would need %s pairs of", + "treatment and control outcomes (at most 1e7); use", + "enumerate = FALSE in design_binary2()."), + format(n_pairs, big.mark = ",")), call. = FALSE) + } + x_t <- outcomes_binary2(design$n_t) + alpha_t <- posterior_binary2(design$prior_t, x_t, design$external_t) + w_t <- vapply(seq_len(n_scen), function(s) { + dmultinom_counts(x_t, cells_t[s, ]) + }, numeric(nrow(x_t))) + if (concurrent) { + x_c <- outcomes_binary2(design$n_c) + alpha_c <- posterior_binary2(design$prior_c, x_c, design$external_c) + w_c <- vapply(seq_len(n_scen), function(s) { + dmultinom_counts(x_c, cells_c[s, ]) + }, numeric(nrow(x_c))) + } else { + alpha_c <- alpha_nc + w_c <- matrix(1, 1L, n_scen) + } + w_t <- matrix(w_t, ncol = n_scen) + w_c <- matrix(w_c, ncol = n_scen) + w_t[, bad] <- NA_real_ + n_t <- nrow(alpha_t) + n_c <- if (is.null(alpha_c)) 1L else nrow(alpha_c) + p <- region_prob_binary2(crit, alpha_t, alpha_c, + rep(seq_len(n_t), times = n_c), + rep(seq_len(n_c), each = n_t), + c(sets$go, sets$nogo), design$nMC, + fixed = design$fixed_c) + s <- split_sets(p, n_go, dim = c(n_t, n_c)) + return(list(p_go = s$go, p_nogo = s$nogo, per_scenario = FALSE, + weights_t = w_t, weights_c = w_c, + method = paste("exact enumeration of the outcomes;", + prob_label))) + } + nsim <- as.integer(round(nsim)) + u_t <- matrix(stats::runif(nsim * design$n_t), nrow = nsim) + if (concurrent) { + u_c <- matrix(stats::runif(nsim * design$n_c), nrow = nsim) + } + # Counts of all simulated studies, scenarios stacked (NA for scenarios + # that are not evaluable) + sim_t <- matrix(NA_integer_, nsim * n_scen, 4L) + sim_c <- matrix(0L, nsim * n_scen, 4L) + for (s in which(!bad)) { + rows <- (s - 1L) * nsim + seq_len(nsim) + sim_t[rows, ] <- simulate_counts_binary2(u_t, cells_t[s, ]) + if (concurrent) { + sim_c[rows, ] <- simulate_counts_binary2(u_c, cells_c[s, ]) + } + } + ok <- !is.na(sim_t[, 1L]) + key_t <- outcome_key(sim_t[ok, , drop = FALSE]) + key_c <- outcome_key(sim_c[ok, , drop = FALSE]) + ut <- unique(key_t) + uc <- unique(key_c) + it <- match(key_t, ut) + ic <- match(key_c, uc) + pair <- unique(cbind(it, ic)) + first_t <- match(ut, key_t) + first_c <- match(uc, key_c) + alpha_t <- posterior_binary2(design$prior_t, + sim_t[ok, , drop = FALSE][first_t, , + drop = FALSE], + design$external_t) + alpha_c <- if (concurrent) { + posterior_binary2(design$prior_c, + sim_c[ok, , drop = FALSE][first_c, , drop = FALSE], + design$external_c) + } else { + alpha_nc + } + p <- region_prob_binary2(crit, alpha_t, alpha_c, pair[, 1L], pair[, 2L], + c(sets$go, sets$nogo), design$nMC, + fixed = design$fixed_c) + idx <- match(paste(it, ic), paste(pair[, 1L], pair[, 2L])) + full <- matrix(NA_real_, nsim * n_scen, ncol(p)) + full[ok, ] <- p[idx, , drop = FALSE] + s <- split_sets(full, n_go, dim = c(nsim, n_scen)) + list(p_go = s$go, p_nogo = s$nogo, per_scenario = TRUE, + weights = matrix(1 / nsim, nsim, n_scen), + method = sprintf("simulation of %d studies; %s", nsim, prob_label)) +} diff --git a/R/oc_sample_continuous.R b/R/oc_sample_continuous.R new file mode 100644 index 0000000..9a96ba2 --- /dev/null +++ b/R/oc_sample_continuous.R @@ -0,0 +1,67 @@ +#' Simulated outcomes of a continuous design and their probabilities +#' +#' Simulates the sufficient statistics of \code{nsim} proof-of-concept +#' studies under each scenario and computes the probabilities of the Go and +#' NoGo regions for each simulated study. For a group with \eqn{n} subjects, +#' true mean \eqn{\mu} and standard deviation \eqn{\sigma}, the sample mean +#' and standard deviation are +#' \eqn{\bar y = \mu + \sigma Z / \sqrt{n}} and +#' \eqn{s = \sigma \sqrt{X / (n - 1)}} with independent +#' \eqn{Z \sim N(0, 1)} and \eqn{X \sim \chi^2_{n - 1}}. The same draws of +#' \eqn{Z} and \eqn{X} are used for all scenarios (common random numbers), so +#' that differences between scenarios are not blurred by simulation noise. +#' The draws are made in the order \code{rnorm(nsim)}, +#' \code{rchisq(nsim, n_t - 1)} for the treatment group and then the same for +#' the concurrent control group (if any). +#' +#' @param design An object of class \code{"qdm_design_continuous"}. +#' @param scenarios Data frame of scenarios (checked). +#' @param nsim Number of simulated studies. +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (matrices with +#' one row per simulated study and one column per scenario), +#' \code{per_scenario} (\code{TRUE}), \code{weights} +#' (matrix of the same size with all elements \code{1 / nsim}) and +#' \code{method}. +#' @noRd +oc_sample_continuous <- function(design, scenarios, nsim) { + nsim <- as.integer(round(nsim)) + n_t <- design$n_t + z_t <- stats::rnorm(nsim) + x_t <- stats::rchisq(nsim, n_t - 1) + concurrent <- design$control == "concurrent" + if (concurrent) { + n_c <- design$n_c + z_c <- stats::rnorm(nsim) + x_c <- stats::rchisq(nsim, n_c - 1) + } + n_scen <- nrow(scenarios) + p_go <- matrix(0, nsim, n_scen) + p_nogo <- matrix(0, nsim, n_scen) + for (j in seq_len(n_scen)) { + sd_t <- scenarios$sd_t[j] + post_t <- posterior_continuous( + design$prior_t, n_t, scenarios$mu_t[j] + sd_t * z_t / sqrt(n_t), + sd_t * sqrt(x_t / (n_t - 1)), external = design$external_t + ) + if (concurrent) { + sd_c <- scenarios$sd_c[j] + post_c <- control_posterior_continuous( + design, post_t, n_c, scenarios$mu_c[j] + sd_c * z_c / sqrt(n_c), + sd_c * sqrt(x_c / (n_c - 1)) + ) + } else { + post_c <- control_posterior_continuous(design, post_t) + } + p <- region_prob_continuous(design$criterion, post_t, post_c, + design$method, design$nMC, + fixed = design$fixed_c) + p_go[, j] <- p$go + p_nogo[, j] <- p$nogo + } + list(p_go = p_go, p_nogo = p_nogo, per_scenario = TRUE, + weights = matrix(1 / nsim, nsim, n_scen), + method = sprintf("simulation of %d studies; probabilities by %s", + nsim, method_label(design$method, design$nMC, + design$control == "fixed"))) +} diff --git a/R/oc_sample_continuous2.R b/R/oc_sample_continuous2.R new file mode 100644 index 0000000..73e828c --- /dev/null +++ b/R/oc_sample_continuous2.R @@ -0,0 +1,66 @@ +#' Simulated studies of a design with two continuous endpoints and their +#' probabilities +#' +#' Simulates the sufficient statistics of \code{nsim} studies under each +#' scenario with the same random numbers for all scenarios (see +#' \code{draws_continuous2()} and \code{stats_continuous2()}); the random +#' numbers are drawn for the treatment group and then for the concurrent +#' control group. For each study, the probabilities of the Go and NoGo +#' regions are computed by the method of the design (with +#' \code{method = "MC"}, the draws are made after the random numbers of the +#' studies, separately for each study and scenario). +#' +#' @param design An object of class \code{"qdm_design_continuous2"}. +#' @param scenarios Data frame of scenarios (checked). +#' @param nsim Number of simulated studies. +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (matrices with +#' one row per simulated study and one column per scenario, or lists of two +#' such matrices for the marginal rules), \code{per_scenario} +#' (\code{TRUE}), \code{weights} (matrix of the same size with all +#' elements \code{1 / nsim}) and \code{method}. +#' @noRd +oc_sample_continuous2 <- function(design, scenarios, nsim) { + nsim <- as.integer(round(nsim)) + crit <- design$criterion + sets <- region_sets(crit) + n_go <- length(sets$go) + concurrent <- design$control == "concurrent" + draws_t <- draws_continuous2(nsim, design$n_t) + if (concurrent) { + draws_c <- draws_continuous2(nsim, design$n_c) + } + n_scen <- nrow(scenarios) + p <- matrix(0, nsim * n_scen, 2L * n_go) + for (j in seq_len(n_scen)) { + sc <- scenarios[j, , drop = FALSE] + st <- stats_continuous2(draws_t, design$n_t, c(sc$mu_t1, sc$mu_t2), + c(sc$sd_t1, sc$sd_t2), sc$rho_t) + post_t <- posterior_continuous2(design$prior_t, design$n_t, st$mean, + st$cov, external = design$external_t) + if (concurrent) { + sc_c <- stats_continuous2(draws_c, design$n_c, c(sc$mu_c1, sc$mu_c2), + c(sc$sd_c1, sc$sd_c2), sc$rho_c) + post_c <- control_posterior_continuous2(design, post_t, design$n_c, + sc_c$mean, sc_c$cov) + } else { + post_c <- control_posterior_continuous2(design, post_t) + } + dist_t <- mean_dist_continuous2(post_t, crit$type, crit$m_t) + dist_c <- if (is.null(post_c)) { + NULL + } else { + mean_dist_continuous2(post_c, crit$type, crit$m_c) + } + p[(j - 1L) * nsim + seq_len(nsim), ] <- region_prob_continuous2( + crit, dist_t, dist_c, c(sets$go, sets$nogo), design$method, + design$nMC, fixed = design$fixed_c + ) + } + s <- split_sets(p, n_go, dim = c(nsim, n_scen)) + list(p_go = s$go, p_nogo = s$nogo, per_scenario = TRUE, + weights = matrix(1 / nsim, nsim, n_scen), + method = sprintf("simulation of %d studies; probabilities by %s", + nsim, method_label(design$method, design$nMC, + design$control == "fixed"))) +} diff --git a/R/oc_sample_tte.R b/R/oc_sample_tte.R new file mode 100644 index 0000000..d489b7d --- /dev/null +++ b/R/oc_sample_tte.R @@ -0,0 +1,51 @@ +#' Simulated outcomes of a time-to-event design and their probabilities +#' +#' Simulates \code{nsim} studies under each scenario as specified by the +#' conduct of the design (\code{cpp_tte_oc_data()}), with exponential event +#' times whose hazards are \eqn{\log(2) / M} for the median survival times +#' \eqn{M} of the scenario, and computes the probabilities of the Go and NoGo +#' regions for each simulated study. The same random numbers (enrollment +#' times, standard exponential numbers for the event times and dropout times) +#' are used for all scenarios. +#' +#' @param design An object of class \code{"qdm_design_tte"}. +#' @param scenarios Data frame of scenarios (checked). +#' @param nsim Number of simulated studies. +#' +#' @return A list with elements \code{p_go} and \code{p_nogo} (matrices with +#' one row per simulated study and one column per scenario), +#' \code{per_scenario} (\code{TRUE}), \code{weights} (matrix of the same +#' size with all elements \code{1 / nsim}) and \code{method}. +#' @noRd +oc_sample_tte <- function(design, scenarios, nsim) { + if (is.null(design$conduct)) { + stop(paste("The operating characteristics need the conduct of the", + "study: give 'conduct' in design_tte()."), call. = FALSE) + } + nsim <- as.integer(round(nsim)) + n_scen <- nrow(scenarios) + concurrent <- design$control == "concurrent" + ca <- conduct_args(design$conduct) + hazard_t <- log(2) / scenarios$median_t + hazard_c <- if (concurrent) log(2) / scenarios$median_c else rep(1, n_scen) + sim <- cpp_tte_oc_data(nsim, design$n_t, if (concurrent) design$n_c else 0L, + hazard_t, hazard_c, ca$acc_time, ca$acc_cum, + ca$drop_start, ca$drop_hazard, ca$cut_time, + ca$cut_events) + post_t <- posterior_tte(design$prior_t, sim[, 1L], sim[, 2L], + external = design$external_t) + post_c <- switch( + design$control, + concurrent = posterior_tte(design$prior_c, sim[, 3L], sim[, 4L], + external = design$external_c), + fixed = NULL, + posterior_tte(design$prior_c, 0, 0, external = design$external_c, + hypothetical = design$hypothetical_c) + ) + p <- region_prob_tte(design, post_t, post_c) + list(p_go = matrix(p$go, nsim, n_scen), + p_nogo = matrix(p$nogo, nsim, n_scen), per_scenario = TRUE, + weights = matrix(1 / nsim, nsim, n_scen), + method = sprintf("simulation of %d studies; probabilities by %s", + nsim, tte_method_label(design))) +} diff --git a/R/outcome_key.R b/R/outcome_key.R new file mode 100644 index 0000000..e06582b --- /dev/null +++ b/R/outcome_key.R @@ -0,0 +1,14 @@ +#' Integer keys of count vectors +#' +#' @param x Integer matrix of counts with columns \code{"00"}, \code{"01"}, +#' \code{"10"} and \code{"11"} and a common total. +#' +#' @return A numeric vector of keys that differ between different rows: the +#' counts of the last three columns as digits in base \code{b}, where +#' \code{b} exceeds the largest count (exact for totals below about +#' 200000). +#' @noRd +outcome_key <- function(x) { + b <- max(x, 0) + 1 + x[, 2L] + b * x[, 3L] + b ^ 2 * x[, 4L] +} diff --git a/R/outcome_prob.R b/R/outcome_prob.R new file mode 100644 index 0000000..760d68c --- /dev/null +++ b/R/outcome_prob.R @@ -0,0 +1,17 @@ +#' Probability of a set of outcomes under each scenario +#' +#' @param ind Logical vector or matrix indicating the outcomes: over the +#' outcomes (with \code{sample$weights}), one column per scenario (with +#' \code{sample$weights} of the same size), or a matrix over pairs of +#' treatment and control outcomes (with \code{sample$weights_t} and +#' \code{sample$weights_c}). +#' @param sample A list returned by \code{oc_sample()}. +#' +#' @return A numeric vector with one probability per scenario. +#' @noRd +outcome_prob <- function(ind, sample) { + if (is.null(sample[["weights"]])) { + return(colSums(sample$weights_t * (ind %*% sample$weights_c))) + } + colSums(sample[["weights"]] * ind) +} diff --git a/R/outcomes_binary2.R b/R/outcomes_binary2.R new file mode 100644 index 0000000..c8a87f1 --- /dev/null +++ b/R/outcomes_binary2.R @@ -0,0 +1,19 @@ +#' All outcomes of one group for two binary endpoints +#' +#' Lists all vectors of counts of the four joint response patterns +#' (\code{"00"}, \code{"01"}, \code{"10"}, \code{"11"}) with total \code{n}. +#' There are \code{choose(n + 3, 3)} of them. +#' +#' @param n Number of subjects (a whole number of at least 0). +#' +#' @return An integer matrix with one row per outcome and the columns +#' \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"}. +#' @noRd +outcomes_binary2 <- function(n) { + g <- expand.grid(x01 = 0:n, x10 = 0:n, x11 = 0:n) + g <- g[rowSums(g) <= n, , drop = FALSE] + out <- cbind(n - rowSums(g), g$x01, g$x10, g$x11) + storage.mode(out) <- "integer" + dimnames(out) <- list(NULL, c("00", "01", "10", "11")) + out +} diff --git a/R/pbayesdecisionprob1bin.R b/R/pbayesdecisionprob1bin.R deleted file mode 100644 index e7ec249..0000000 --- a/R/pbayesdecisionprob1bin.R +++ /dev/null @@ -1,484 +0,0 @@ -#' Go/NoGo/Gray Decision Probabilities for a Clinical Trial with a Single Binary Endpoint -#' -#' Evaluates operating characteristics (Go, NoGo, Gray probabilities) for binary-outcome -#' clinical trials under the Bayesian framework by enumerating all possible trial -#' outcomes. The function supports controlled, uncontrolled, and external designs. -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param theta_TV A numeric scalar giving the target value (TV) threshold used for -#' the Go decision when \code{prob = 'posterior'}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV A numeric scalar giving the minimum acceptable value (MAV) -#' threshold used for the NoGo decision when \code{prob = 'posterior'}. -#' Must satisfy \code{theta_TV > theta_MAV}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_NULL A numeric scalar giving the null hypothesis threshold used for -#' both Go and NoGo decisions when \code{prob = 'predictive'}. Set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param gamma_go A numeric scalar in \code{(0, 1)} giving the minimum posterior or -#' predictive probability required for a Go decision. -#' @param gamma_nogo A numeric scalar in \code{(0, 1)} giving the minimum posterior or -#' predictive probability required for a NoGo decision. No ordering -#' constraint on \code{gamma_go} and \code{gamma_nogo} is imposed, though -#' their combination determines the frequency of Miss outcomes. -#' @param pi_t A numeric value or vector giving the true response probability(s) for -#' the treatment group used to evaluate operating characteristics. Each element -#' must be in \code{(0, 1)}. -#' @param pi_c A numeric value or vector giving the true response probability(s) for -#' the control group. For \code{design = 'uncontrolled'}, this parameter is -#' not used in calculations but must be supplied; it is excluded from the output. -#' When supplied as a vector, must have the same length as \code{pi_t}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. For \code{design = 'uncontrolled'}, -#' this is the hypothetical control sample size (required for -#' consistency with other designs). -#' @param a_t A positive numeric scalar giving the first shape parameter -#' (alpha) of the prior Beta distribution for the treatment group. -#' @param a_c A positive numeric scalar giving the first shape parameter -#' (alpha) of the prior Beta distribution for the control group. -#' @param b_t A positive numeric scalar giving the second shape parameter -#' (beta) of the prior Beta distribution for the treatment group. -#' @param b_c A positive numeric scalar giving the second shape parameter -#' (beta) of the prior Beta distribution for the control group. -#' @param z A non-negative integer giving the hypothetical number of responders -#' in the control group. Required when \code{design = 'uncontrolled'}; -#' otherwise set to \code{NULL}. When used, \code{y_c} should be -#' \code{NULL}. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param ne_t A positive integer giving the number of patients in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'} and external treatment data are -#' available; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the number of patients in the -#' control group of the external data set. Required when -#' \code{design = 'external'} and external control data are available; -#' otherwise set to \code{NULL}. -#' @param ye_t A non-negative integer giving the number of responders in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'}; otherwise set to \code{NULL}. -#' @param ye_c A non-negative integer giving the number of responders in the -#' control group of the external data set. Required when -#' \code{design = 'external'}; otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior weight for -#' the treatment group. Required when \code{design = 'external'}; -#' otherwise \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior weight for -#' the control group. Required when \code{design = 'external'}; -#' otherwise \code{NULL}. -#' @param error_if_Miss A logical scalar; if \code{TRUE} (default), the function stops -#' with an error if Miss probability > 0, prompting reconsideration of thresholds. -#' @param Gray_inc_Miss A logical scalar; if \code{TRUE}, Miss probability is added -#' to Gray probability. If \code{FALSE} (default), Miss is reported separately. -#' Active only when \code{error_if_Miss = FALSE}. -#' -#' @return A data frame with one row per \code{pi_t} scenario and columns: -#' \describe{ -#' \item{pi_t}{True treatment response probability.} -#' \item{pi_c}{True control response probability (omitted for uncontrolled design).} -#' \item{Go}{Probability of making a Go decision.} -#' \item{Gray}{Probability of making a Gray (inconclusive) decision.} -#' \item{NoGo}{Probability of making a NoGo decision.} -#' \item{Miss}{(Optional) Probability where Go and NoGo criteria are simultaneously -#' met. Included when \code{error_if_Miss = FALSE} and -#' \code{Gray_inc_Miss = FALSE}.} -#' } -#' The returned object has S3 class \code{pbayesdecisionprob1bin} with an associated -#' \code{print} method. -#' -#' @details -#' Operating characteristics are computed by exact enumeration: -#' \enumerate{ -#' \item All possible outcome pairs \eqn{(y_t, y_c)} with \eqn{y_t \in \{0,\ldots,n_t\}} -#' and \eqn{y_c \in \{0,\ldots,n_c\}} (or fixed at \eqn{z} for uncontrolled) are -#' evaluated. -#' \item For each pair, \code{\link{pbayespostpred1bin}} computes the posterior or predictive -#' probability at both thresholds (TV/MAV or NULL). -#' \item Outcomes are classified into Go, NoGo, Miss, or Gray: -#' \itemize{ -#' \item \strong{Go}: \eqn{P(\mathrm{Go}) \ge \gamma_1} AND -#' \eqn{P(\mathrm{NoGo}) < \gamma_2} -#' \item \strong{NoGo}: \eqn{P(\mathrm{Go}) < \gamma_1} AND -#' \eqn{P(\mathrm{NoGo}) \ge \gamma_2} -#' \item \strong{Miss}: both Go and NoGo criteria met simultaneously -#' \item \strong{Gray}: neither Go nor NoGo criteria met -#' } -#' \item Each outcome is weighted by its binomial probability under the true rates. -#' } -#' -#' @examples -#' # Example 1: Controlled design with posterior probability -#' pbayesdecisionprob1bin( -#' prob = 'posterior', design = 'controlled', -#' theta_TV = 0.4, theta_MAV = 0.2, theta_NULL = NULL, -#' gamma_go = 0.8, gamma_nogo = 0.2, -#' pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), -#' n_t = 12, n_c = 12, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = NULL, m_c = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 2: Uncontrolled design with hypothetical control -#' pbayesdecisionprob1bin( -#' prob = 'posterior', design = 'uncontrolled', -#' theta_TV = 0.30, theta_MAV = 0.15, theta_NULL = NULL, -#' gamma_go = 0.75, gamma_nogo = 0.25, -#' pi_t = c(0.3, 0.5, 0.7), pi_c = NULL, -#' n_t = 15, n_c = 15, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = 5, m_t = NULL, m_c = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 3: External design with 50 percent power prior borrowing -#' pbayesdecisionprob1bin( -#' prob = 'posterior', design = 'external', -#' theta_TV = 0.4, theta_MAV = 0.2, theta_NULL = NULL, -#' gamma_go = 0.8, gamma_nogo = 0.2, -#' pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), -#' n_t = 12, n_c = 12, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = NULL, m_c = NULL, -#' ne_t = 15, ne_c = 15, ye_t = 6, ye_c = 4, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 4: Posterior predictive probability for controlled design -#' pbayesdecisionprob1bin( -#' prob = 'predictive', design = 'controlled', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, -#' gamma_go = 0.9, gamma_nogo = 0.3, -#' pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), -#' n_t = 12, n_c = 12, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = 30, m_c = 30, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 5: Uncontrolled design with posterior predictive probability -#' pbayesdecisionprob1bin( -#' prob = 'predictive', design = 'uncontrolled', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, -#' gamma_go = 0.75, gamma_nogo = 0.25, -#' pi_t = c(0.3, 0.5, 0.7), pi_c = NULL, -#' n_t = 15, n_c = 15, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = 5, m_t = 30, m_c = 30, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 6: External design with posterior predictive probability -#' pbayesdecisionprob1bin( -#' prob = 'predictive', design = 'external', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, -#' gamma_go = 0.9, gamma_nogo = 0.3, -#' pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), -#' n_t = 12, n_c = 12, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' z = NULL, m_t = 30, m_c = 30, -#' ne_t = 15, ne_c = 15, ye_t = 6, ye_c = 4, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE -#' ) -#' -#' @importFrom stats dbinom -#' @export -pbayesdecisionprob1bin <- function(prob = 'posterior', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, - theta_NULL = NULL, - gamma_go, gamma_nogo, pi_t, pi_c = NULL, - n_t, n_c, a_t, a_c, b_t, b_c, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, - ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE) { - - # --- Input validation --- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.numeric(gamma_go) || length(gamma_go) != 1L || is.na(gamma_go) || - gamma_go <= 0 || gamma_go >= 1) { - stop("'gamma_go' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(gamma_nogo) || length(gamma_nogo) != 1L || is.na(gamma_nogo) || - gamma_nogo <= 0 || gamma_nogo >= 1) { - stop("'gamma_nogo' must be a single numeric value in (0, 1)") - } - - for (nm in c("n_t", "n_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - - for (nm in c("a_t", "a_c", "b_t", "b_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) { - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - } - - if (!is.logical(error_if_Miss) || length(error_if_Miss) != 1L || - is.na(error_if_Miss)) { - stop("'error_if_Miss' must be a single logical value (TRUE or FALSE)") - } - - if (!is.logical(Gray_inc_Miss) || length(Gray_inc_Miss) != 1L || - is.na(Gray_inc_Miss)) { - stop("'Gray_inc_Miss' must be a single logical value (TRUE or FALSE)") - } - - # Validate pi vectors - pi_t <- as.numeric(pi_t) - pi_c <- as.numeric(pi_c) - - if (any(is.na(pi_t)) || any(pi_t <= 0) || any(pi_t >= 1)) { - stop("All elements of 'pi_t' must be in (0, 1)") - } - - if (design != 'uncontrolled') { - if (any(is.na(pi_c)) || any(pi_c <= 0) || any(pi_c >= 1)) { - stop("All elements of 'pi_c' must be in (0, 1)") - } - if (length(pi_t) != length(pi_c)) { - stop("'pi_t' and 'pi_c' must have the same length") - } - } - - # Validate prob-specific parameters - if (prob == 'posterior') { - if (is.null(theta_TV) || is.null(theta_MAV)) { - stop("'theta_TV' and 'theta_MAV' must be non-NULL when prob = 'posterior'") - } - if (!is.numeric(theta_TV) || length(theta_TV) != 1L || is.na(theta_TV)) { - stop("'theta_TV' must be a single numeric value") - } - if (!is.numeric(theta_MAV) || length(theta_MAV) != 1L || is.na(theta_MAV)) { - stop("'theta_MAV' must be a single numeric value") - } - if (theta_TV <= theta_MAV) { - stop("'theta_TV' must be strictly greater than 'theta_MAV'") - } - } else { - if (is.null(theta_NULL)) { - stop("'theta_NULL' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(theta_NULL) || length(theta_NULL) != 1L || is.na(theta_NULL)) { - stop("'theta_NULL' must be a single numeric value") - } - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer") - } - if (!is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer") - } - } - - # Validate design-specific parameters - if (design == 'uncontrolled') { - if (is.null(z)) { - stop("'z' must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(z) || length(z) != 1L || is.na(z) || - z != floor(z) || z < 0L || z > n_c) { - stop("'z' must be a single non-negative integer not exceeding n_c") - } - } - - if (design == 'external') { - if (any(sapply(list(ne_t, ne_c, ye_t, ye_c, alpha0e_t, alpha0e_c), is.null))) { - stop("'ne_t', 'ne_c', 'ye_t', 'ye_c', 'alpha0e_t', and 'alpha0e_c' must all be non-NULL when design = 'external'") - } - for (nm in c("ne_t", "ne_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - for (nm in c("ye_t", "ye_c")) { - val <- get(nm) - ne_v <- if (nm == "ye_t") ne_t else ne_c - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L || val > ne_v) { - stop(paste0("'", nm, "' must be a single non-negative integer not exceeding the corresponding ne")) - } - } - for (nm in c("alpha0e_t", "alpha0e_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val > 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1]")) - } - } - } - - # --- Set decision thresholds --- - if (prob == 'posterior') { - # Go threshold: TV, NoGo threshold: MAV - theta0 <- c(theta_TV, theta_MAV) - } else { - # Both thresholds equal to theta_NULL for predictive probability - theta0 <- c(theta_NULL, theta_NULL) - } - - # --- Enumerate all possible outcome combinations --- - Y_t <- 0:n_t - if (design == 'uncontrolled') { - all_y_t <- Y_t - all_y_c <- rep(z, length(Y_t)) - } else { - grid <- expand.grid(y_t = Y_t, y_c = 0:n_c) - all_y_t <- grid$y_t - all_y_c <- grid$y_c - } - - # --- Compute posterior/predictive probabilities for all outcome pairs --- - # Use z argument only for uncontrolled design; pass NULL otherwise - z_arg <- if (design == 'uncontrolled') z else NULL - - gPost_Go <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0[1], - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = if (design == 'uncontrolled') NULL else all_y_c, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = z_arg, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = FALSE - ) - - gPost_NoGo <- pbayespostpred1bin( - prob = prob, design = design, theta0 = theta0[2], - n_t = n_t, n_c = n_c, y_t = all_y_t, y_c = if (design == 'uncontrolled') NULL else all_y_c, - a_t = a_t, a_c = a_c, b_t = b_t, b_c = b_c, - m_t = m_t, m_c = m_c, z = z_arg, - ne_t = ne_t, ne_c = ne_c, ye_t = ye_t, ye_c = ye_c, alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - lower.tail = TRUE - ) - - # --- Decision indicators (Go, NoGo, Miss are mutually exclusive; Gray is the complement) --- - probs_Go <- (gPost_Go >= gamma_go) & (gPost_NoGo < gamma_nogo) - probs_NoGo <- (gPost_Go < gamma_go) & (gPost_NoGo >= gamma_nogo) - probs_Miss <- (gPost_Go >= gamma_go) & (gPost_NoGo >= gamma_nogo) - - # --- Weight outcomes by binomial probability under each scenario --- - n_scenarios <- length(pi_t) - GoNogoProb <- matrix(0, nrow = n_scenarios, ncol = 3L) - - for (scenario in seq_len(n_scenarios)) { - if (design == 'uncontrolled') { - # y_c is fixed at z; sum over y_t only - binom_w <- dbinom(all_y_t, n_t, pi_t[scenario]) - GoNogoProb[scenario, 1L] <- sum(probs_Go * binom_w) - GoNogoProb[scenario, 2L] <- sum(probs_NoGo * binom_w) - GoNogoProb[scenario, 3L] <- sum(probs_Miss * binom_w) - } else { - # Sum over all (y_t, y_c) combinations - w <- dbinom(all_y_t, n_t, pi_t[scenario]) * dbinom(all_y_c, n_c, pi_c[scenario]) - GoNogoProb[scenario, 1L] <- sum(probs_Go * w) - GoNogoProb[scenario, 2L] <- sum(probs_NoGo * w) - GoNogoProb[scenario, 3L] <- sum(probs_Miss * w) - } - } - - # --- Check for positive Miss probability --- - if (error_if_Miss && sum(GoNogoProb[, 3L]) > 0) { - stop("Positive Miss probability detected. Please re-consider the chosen thresholds.") - } - - # --- Gray probability (complement of Go and NoGo) --- - if (Gray_inc_Miss) { - # Include Miss in Gray: Gray = 1 - Go - NoGo - GrayProb <- 1 - rowSums(GoNogoProb[, -3L, drop = FALSE]) - } else { - # Exclude Miss from Gray: Gray = 1 - Go - NoGo - Miss - GrayProb <- 1 - rowSums(GoNogoProb[, , drop = FALSE]) - } - - # --- Build results data frame --- - if (design == 'uncontrolled') { - results <- data.frame( - pi_t = pi_t, - Go = GoNogoProb[, 1L], - Gray = GrayProb, - NoGo = GoNogoProb[, 2L] - ) - } else { - results <- data.frame( - pi_t = pi_t, - pi_c = pi_c, - Go = GoNogoProb[, 1L], - Gray = GrayProb, - NoGo = GoNogoProb[, 2L] - ) - } - - if (!error_if_Miss && !Gray_inc_Miss) { - results$Miss <- GoNogoProb[, 3L] - } - - # Address floating-point rounding artefacts - results[results < .Machine$double.eps ^ 0.25] <- 0 - - # Attach metadata as attributes for use in print() - attr(results, 'prob') <- prob - attr(results, 'design') <- design - attr(results, 'theta_TV') <- theta_TV - attr(results, 'theta_MAV') <- theta_MAV - attr(results, 'theta_NULL') <- theta_NULL - attr(results, 'gamma_go') <- gamma_go - attr(results, 'gamma_nogo') <- gamma_nogo - attr(results, 'n_t') <- n_t - attr(results, 'n_c') <- n_c - attr(results, 'a_t') <- a_t - attr(results, 'a_c') <- a_c - attr(results, 'b_t') <- b_t - attr(results, 'b_c') <- b_c - attr(results, 'z') <- z - attr(results, 'm_t') <- m_t - attr(results, 'm_c') <- m_c - attr(results, 'ne_t') <- ne_t - attr(results, 'ne_c') <- ne_c - attr(results, 'ye_t') <- ye_t - attr(results, 'ye_c') <- ye_c - attr(results, 'alpha0e_t') <- alpha0e_t - attr(results, 'alpha0e_c') <- alpha0e_c - attr(results, 'error_if_Miss') <- error_if_Miss - attr(results, 'Gray_inc_Miss') <- Gray_inc_Miss - - # Assign S3 class - class(results) <- c('pbayesdecisionprob1bin', 'data.frame') - - return(results) -} diff --git a/R/pbayesdecisionprob1cont.R b/R/pbayesdecisionprob1cont.R deleted file mode 100644 index cc5c10f..0000000 --- a/R/pbayesdecisionprob1cont.R +++ /dev/null @@ -1,655 +0,0 @@ -#' Bayesian Go/NoGo/Gray Decision Probabilities for Single Continuous Endpoint -#' -#' Evaluates Go/NoGo/Gray decision probabilities for a single continuous endpoint -#' via Monte Carlo simulation. Supports controlled (parallel control), uncontrolled -#' (single-arm with informative priors), and external (power prior borrowing) -#' designs with both posterior and predictive probability approaches. -#' -#' @param nsim A positive integer specifying the number of Monte Carlo simulation replicates. -#' @param prob A character string specifying the probability type: \code{'posterior'} or -#' \code{'predictive'}. -#' @param design A character string specifying the trial design: \code{'controlled'}, -#' \code{'uncontrolled'}, or \code{'external'}. -#' @param prior A character string specifying the prior distribution: \code{'vague'} or -#' \code{'N-Inv-Chisq'}. -#' @param CalcMethod A character string specifying the computation method: \code{'NI'} -#' (Numerical Integration), \code{'MC'} (Monte Carlo), or \code{'MM'} -#' (Moment Matching). -#' @param theta_TV A numeric value representing the target value (TV) threshold for the -#' Go decision. Required if \code{prob = 'posterior'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param theta_MAV A numeric value representing the minimum acceptable value (MAV) threshold -#' for the NoGo decision. Required if \code{prob = 'posterior'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param theta_NULL A numeric value representing the null hypothesis threshold. -#' Required if \code{prob = 'predictive'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param nMC A positive integer specifying the number of Monte Carlo draws for computing -#' posterior probabilities. Required if \code{CalcMethod = 'MC'}; -#' otherwise \code{NULL}. -#' @param gamma_go A numeric scalar in \code{(0, 1)} giving the minimum posterior or -#' predictive probability required for a Go decision. -#' @param gamma_nogo A numeric scalar in \code{(0, 1)} giving the minimum posterior or -#' predictive probability required for a NoGo decision. No ordering -#' constraint on \code{gamma_go} and \code{gamma_nogo} is imposed, though -#' their combination determines the frequency of Miss outcomes. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the proof-of-concept (PoC) trial. Required for -#' \code{design = 'controlled'} or \code{'external'}; set to -#' \code{NULL} for \code{design = 'uncontrolled'}. -#' @param m_t A positive integer representing the future sample size for the -#' treatment group. Required if \code{prob = 'predictive'}; -#' otherwise \code{NULL}. Default is \code{NULL}. -#' @param m_c A positive integer representing the future sample size for the control group. -#' Required if \code{prob = 'predictive'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param kappa0_t A positive numeric value representing the prior hyperparameter kappa for -#' the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param kappa0_c A positive numeric value representing the prior hyperparameter kappa for -#' the control group. Required if \code{prior = 'N-Inv-Chisq'} and -#' \code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param nu0_t A positive numeric value representing the prior hyperparameter nu for -#' the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param nu0_c A positive numeric value representing the prior hyperparameter nu for -#' the control group. Required if \code{prior = 'N-Inv-Chisq'} and -#' \code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param mu0_t A numeric value representing the prior mean for the treatment group. Required if -#' \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. Default is \code{NULL}. -#' @param mu0_c A numeric value representing the prior mean for the control group. For -#' \code{design = 'uncontrolled'}, this represents the hypothetical control mean. -#' Required if \code{prior = 'N-Inv-Chisq'} and -#' \code{design \%in\% c('controlled', 'external')}, or if -#' \code{design = 'uncontrolled'}; otherwise \code{NULL}. Default is \code{NULL}. -#' @param sigma0_t A positive numeric value representing the prior standard deviation for -#' the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param sigma0_c A positive numeric value representing the prior standard deviation for -#' the control group. Required if \code{prior = 'N-Inv-Chisq'} and -#' \code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -#' Default is \code{NULL}. -#' @param mu_t A numeric value representing the true mean for the treatment group in the simulation. -#' @param mu_c A numeric value representing the true mean for the control group in the simulation. -#' For uncontrolled design, this represents the historical control mean. -#' Set to \code{NULL} if \code{design = 'uncontrolled'}. -#' @param sigma_t A positive numeric value representing the true standard deviation -#' for the treatment group in the simulation. -#' @param sigma_c A positive numeric value representing the true standard deviation -#' for the control group in the simulation. For uncontrolled design, this represents -#' the historical control standard deviation. -#' Set to \code{NULL} if \code{design = 'uncontrolled'}. -#' @param r A positive numeric value representing the variance scaling factor that allows -#' the scale of hypothetical control to be different from treatment. Specifically, -#' \code{sd.control = sqrt(r) * sd.treatment}. Required if \code{design = 'uncontrolled'}. -#' When \code{r = 1}, the control and treatment have the same variance scale. -#' @param ne_t A positive integer representing the number of patients in the treatment group for -#' the external data. Required if \code{design = 'external'} and external -#' treatment data are available. -#' @param ne_c A positive integer representing the number of patients in the control group for -#' the external data. Required if \code{design = 'external'} and external -#' control data are available. -#' @param alpha0e_t A numeric value in \code{(0, 1]} representing the power prior scale parameter -#' for the treatment group. Controls the degree of borrowing from external treatment data: -#' 0 = no borrowing, 1 = full borrowing. Required if \code{ne_t} is specified. -#' @param alpha0e_c A numeric value in \code{(0, 1]} representing the power prior scale parameter -#' for the control group. Controls the degree of borrowing from external control data: -#' 0 = no borrowing, 1 = full borrowing. Required if \code{ne_c} is specified. -#' @param bar_ye_t A numeric value representing the sample mean of the external data -#' for the treatment group. Required if \code{ne_t} is specified. -#' @param bar_ye_c A numeric value representing the sample mean of the external data -#' for the control group. Required if \code{ne_c} is specified. -#' @param se_t A positive numeric value representing the sample standard deviation -#' of the external data for the treatment group. Required if \code{ne_t} is specified. -#' @param se_c A positive numeric value representing the sample standard deviation -#' of the external data for the control group. Required if \code{ne_c} is specified. -#' @param error_if_Miss A logical value; if \code{TRUE} (default), the function stops -#' with an error when positive Miss probability is obtained, indicating poorly -#' chosen thresholds. If \code{FALSE}, the function proceeds and reports Miss -#' probability based on \code{Gray_inc_Miss} setting. -#' @param Gray_inc_Miss A logical value; if \code{TRUE}, Miss probability is included -#' in Gray probability (Miss is not reported separately). If \code{FALSE} -#' (default), Miss probability is reported as a separate category. This parameter -#' is only active when \code{error_if_Miss = FALSE}. -#' @param seed A numeric value representing the seed number for reproducible random number generation. -#' -#' @return A data frame containing the true means for both groups and the Go, NoGo, and -#' Gray probabilities. When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = FALSE}, -#' Miss probability is also included as a separate column. For uncontrolled design, -#' only mu_t is included (not mu_c). -#' -#' @details -#' The function performs Monte Carlo simulation to evaluate operating characteristics by: -#' \itemize{ -#' \item Generating random trial data based on specified true parameters -#' \item Computing posterior or predictive probabilities for each simulated trial -#' \item Classifying each trial as Go, NoGo, or Gray based on decision thresholds -#' } -#' -#' Posterior parameter calculations (mu.t1, mu.t2, sd.t1, sd.t2, nu.t1, nu.t2) are -#' fully vectorized over the nsim simulated datasets. pbayespostpred1cont is called -#' twice (once per threshold), with each call receiving vectors of length nsim and -#' returning a vector of nsim probabilities - no inner loop over simulation replicates -#' is required. -#' -#' For external designs, power priors are incorporated using exact conjugate representation: -#' \itemize{ -#' \item Power priors for normal data are mathematically equivalent to Normal-Inverse-Chi-squared distributions -#' \item This enables closed-form computation without MCMC sampling -#' \item Alpha parameters control the degree of borrowing (0 = no borrowing, 1 = full borrowing) -#' } -#' -#' \strong{Decision rules}: -#' \itemize{ -#' \item \strong{Go}: gGo >= gamma_go and gNoGo < gamma_nogo -#' \item \strong{NoGo}: gGo < gamma_go and gNoGo >= gamma_nogo -#' \item \strong{Gray}: neither Go nor NoGo criterion is met -#' \item \strong{Miss}: both Go and NoGo criteria are met simultaneously -#' } -#' -#' \strong{Handling Miss probability}: -#' \itemize{ -#' \item When \code{error_if_Miss = TRUE} (default): Function stops with error if -#' Miss probability > 0, prompting reconsideration of thresholds -#' \item When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = TRUE}: Miss -#' probability is added to Gray probability -#' \item When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = FALSE}: Miss -#' probability is reported as a separate category -#' } -#' -#' The function can be used for: -#' \itemize{ -#' \item \strong{Controlled design}: Two-arm randomized trial -#' \item \strong{Uncontrolled design}: Single-arm trial with informative priors (historical control) -#' \item \strong{External design}: Incorporating historical data through power priors -#' } -#' -#' @examples -#' # Example 1: Controlled design with vague prior and NI method -#' # (default: error_if_Miss = TRUE, Gray_inc_Miss = FALSE) -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'NI', -#' theta_TV = 1.5, theta_MAV = -0.5, theta_NULL = NULL, -#' nMC = NULL, gamma_go = 0.7, gamma_nogo = 0.2, -#' n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' mu_t = 3, mu_c = 1, sigma_t = 1.2, sigma_c = 1.1, -#' r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 2 -#' ) -#' -#' # Example 2: Uncontrolled design with informative prior -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Chisq', CalcMethod = 'NI', -#' theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, -#' nMC = NULL, gamma_go = 0.8, gamma_nogo = 0.2, -#' n_t = 20, n_c = NULL, m_t = NULL, m_c = NULL, -#' kappa0_t = 2, kappa0_c = NULL, nu0_t = 5, nu0_c = NULL, -#' mu0_t = 3.0, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = NULL, -#' mu_t = 3.5, mu_c = NULL, sigma_t = 1.3, sigma_c = NULL, -#' r = 1, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 3 -#' ) -#' -#' # Example 3: External design with control data using MM approximation -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'posterior', design = 'external', prior = 'vague', CalcMethod = 'MM', -#' theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, -#' nMC = NULL, gamma_go = 0.8, gamma_nogo = 0.2, -#' n_t = 12, n_c = 12, m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' mu_t = 2, mu_c = 0, sigma_t = 1, sigma_c = 1, -#' r = NULL, ne_t = NULL, ne_c = 20, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = 0, se_t = NULL, se_c = 1, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 4 -#' ) -#' -#' # Example 4: Controlled design with predictive probability -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'predictive', design = 'controlled', prior = 'N-Inv-Chisq', CalcMethod = 'NI', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 2.0, -#' nMC = NULL, gamma_go = 0.75, gamma_nogo = 0.35, -#' n_t = 15, n_c = 15, m_t = 50, m_c = 50, -#' kappa0_t = 3, kappa0_c = 3, nu0_t = 4, nu0_c = 4, -#' mu0_t = 3.5, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = 1.5, -#' mu_t = 3.2, mu_c = 1.3, sigma_t = 1.4, sigma_c = 1.2, -#' r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 5 -#' ) -#' -#' # Example 5: Uncontrolled design with predictive probability -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'predictive', design = 'uncontrolled', prior = 'vague', CalcMethod = 'NI', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, -#' nMC = NULL, gamma_go = 0.75, gamma_nogo = 0.35, -#' n_t = 20, n_c = NULL, m_t = 40, m_c = 40, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = 1.5, sigma0_t = NULL, sigma0_c = NULL, -#' mu_t = 3, mu_c = NULL, sigma_t = 1.3, sigma_c = NULL, -#' r = 1, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 9 -#' ) -#' -#' # Example 6: External design with predictive probability using MC method -#' pbayesdecisionprob1cont( -#' nsim = 100, prob = 'predictive', design = 'external', prior = 'vague', CalcMethod = 'MC', -#' theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.5, -#' nMC = 5000, gamma_go = 0.7, gamma_nogo = 0.4, -#' n_t = 12, n_c = 12, m_t = 30, m_c = 30, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' mu_t = 2.5, mu_c = 1.0, sigma_t = 1.3, sigma_c = 1.1, -#' r = NULL, ne_t = 15, ne_c = 18, alpha0e_t = 0.6, alpha0e_c = 0.7, -#' bar_ye_t = 2.3, bar_ye_c = 0.9, se_t = 1.2, se_c = 1.0, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE, seed = 6 -#' ) -#' -#' @importFrom stats rnorm -#' @export -pbayesdecisionprob1cont <- function(nsim, prob, design, prior, CalcMethod, - theta_TV = NULL, theta_MAV = NULL, theta_NULL = NULL, - nMC = NULL, gamma_go, gamma_nogo, n_t, n_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, - nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, - sigma0_t = NULL, sigma0_c = NULL, - mu_t, mu_c = NULL, sigma_t, sigma_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed) { - - # --- Input validation --- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c("posterior", "predictive")) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c("controlled", "uncontrolled", "external")) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c("vague", "N-Inv-Chisq")) { - stop("'prior' must be either 'vague' or 'N-Inv-Chisq'") - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c("NI", "MC", "MM")) { - stop("'CalcMethod' must be 'NI', 'MC', or 'MM'") - } - - if (!is.numeric(nsim) || length(nsim) != 1L || is.na(nsim) || - nsim != floor(nsim) || nsim < 1L) { - stop("'nsim' must be a single positive integer") - } - - # Validate n_t (always required) - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) { - stop("'n_t' must be a single positive integer") - } - - # Validate n_c (required only for controlled and external designs) - if (design %in% c("controlled", "external")) { - if (!is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) { - stop("'n_c' must be a single positive integer") - } - } - - if (!is.numeric(gamma_go) || length(gamma_go) != 1L || is.na(gamma_go) || - gamma_go <= 0 || gamma_go >= 1) { - stop("'gamma_go' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(gamma_nogo) || length(gamma_nogo) != 1L || is.na(gamma_nogo) || - gamma_nogo <= 0 || gamma_nogo >= 1) { - stop("'gamma_nogo' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(sigma_t) || length(sigma_t) != 1L || is.na(sigma_t) || sigma_t <= 0) { - stop("'sigma_t' must be a single positive numeric value") - } - - if (!is.logical(error_if_Miss) || length(error_if_Miss) != 1L || is.na(error_if_Miss)) { - stop("'error_if_Miss' must be a single logical value (TRUE or FALSE)") - } - - if (!is.logical(Gray_inc_Miss) || length(Gray_inc_Miss) != 1L || is.na(Gray_inc_Miss)) { - stop("'Gray_inc_Miss' must be a single logical value (TRUE or FALSE)") - } - - # Validate CalcMethod-specific parameter - if (CalcMethod == "MC") { - if (is.null(nMC)) { - stop("'nMC' must be non-NULL when CalcMethod = 'MC'") - } - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer") - } - } - - # Validate prob-specific parameters - if (prob == "posterior") { - if (is.null(theta_TV) || is.null(theta_MAV)) { - stop("'theta_TV' and 'theta_MAV' must be non-NULL when prob = 'posterior'") - } - if (!is.numeric(theta_TV) || length(theta_TV) != 1L || is.na(theta_TV)) { - stop("'theta_TV' must be a single numeric value") - } - if (!is.numeric(theta_MAV) || length(theta_MAV) != 1L || is.na(theta_MAV)) { - stop("'theta_MAV' must be a single numeric value") - } - if (theta_TV <= theta_MAV) { - stop("'theta_TV' must be strictly greater than 'theta_MAV'") - } - } else { - if (is.null(theta_NULL)) { - stop("'theta_NULL' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(theta_NULL) || length(theta_NULL) != 1L || is.na(theta_NULL)) { - stop("'theta_NULL' must be a single numeric value") - } - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer") - } - if (!is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer") - } - } - - # Validate prior-specific parameters - if (prior == "N-Inv-Chisq") { - if (is.null(kappa0_t) || is.null(nu0_t) || is.null(mu0_t) || is.null(sigma0_t)) { - stop("'kappa0_t', 'nu0_t', 'mu0_t', and 'sigma0_t' must be non-NULL when prior = 'N-Inv-Chisq'") - } - if (!is.numeric(kappa0_t) || length(kappa0_t) != 1L || is.na(kappa0_t) || kappa0_t <= 0) { - stop("'kappa0_t' must be a single positive numeric value") - } - if (!is.numeric(nu0_t) || length(nu0_t) != 1L || is.na(nu0_t) || nu0_t <= 0) { - stop("'nu0_t' must be a single positive numeric value") - } - if (!is.numeric(mu0_t) || length(mu0_t) != 1L || is.na(mu0_t)) { - stop("'mu0_t' must be a single numeric value") - } - if (!is.numeric(sigma0_t) || length(sigma0_t) != 1L || is.na(sigma0_t) || sigma0_t <= 0) { - stop("'sigma0_t' must be a single positive numeric value") - } - if (design %in% c("controlled", "external")) { - for (nm in c("kappa0_c", "nu0_c", "mu0_c", "sigma0_c")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prior = 'N-Inv-Chisq' and design = '", - design, "'")) - } - } - if (!is.numeric(kappa0_c) || length(kappa0_c) != 1L || is.na(kappa0_c) || kappa0_c <= 0) { - stop("'kappa0_c' must be a single positive numeric value") - } - if (!is.numeric(nu0_c) || length(nu0_c) != 1L || is.na(nu0_c) || nu0_c <= 0) { - stop("'nu0_c' must be a single positive numeric value") - } - if (!is.numeric(mu0_c) || length(mu0_c) != 1L || is.na(mu0_c)) { - stop("'mu0_c' must be a single numeric value") - } - if (!is.numeric(sigma0_c) || length(sigma0_c) != 1L || is.na(sigma0_c) || sigma0_c <= 0) { - stop("'sigma0_c' must be a single positive numeric value") - } - } - } - - # Validate design-specific parameters - if (design == "uncontrolled") { - if (is.null(mu0_c)) { - stop("'mu0_c' must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(mu0_c) || length(mu0_c) != 1L || is.na(mu0_c)) { - stop("'mu0_c' must be a single numeric value") - } - if (is.null(r)) { - stop("'r' must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(r) || length(r) != 1L || is.na(r) || r <= 0) { - stop("'r' must be a single positive numeric value") - } - } - - if (design == "external") { - has_ext1 <- !is.null(ne_t) && !is.null(alpha0e_t) && !is.null(bar_ye_t) && !is.null(se_t) - has_ext2 <- !is.null(ne_c) && !is.null(alpha0e_c) && !is.null(bar_ye_c) && !is.null(se_c) - if (!has_ext1 && !has_ext2) { - stop(paste0("For design = 'external', at least one complete set of external data ", - "(ne_t + alpha0e_t + bar_ye_t + se_t, or ne_c + alpha0e_c + bar_ye_c + se_c) ", - "must be provided")) - } - if (!is.null(ne_t)) { - if (!is.numeric(ne_t) || length(ne_t) != 1L || is.na(ne_t) || - ne_t != floor(ne_t) || ne_t < 1L) { - stop("'ne_t' must be a single positive integer") - } - if (!is.numeric(alpha0e_t) || length(alpha0e_t) != 1L || is.na(alpha0e_t) || - alpha0e_t <= 0 || alpha0e_t > 1) { - stop("'alpha0e_t' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_t) || length(bar_ye_t) != 1L || is.na(bar_ye_t)) { - stop("'bar_ye_t' must be a single numeric value") - } - if (!is.numeric(se_t) || length(se_t) != 1L || is.na(se_t) || se_t <= 0) { - stop("'se_t' must be a single positive numeric value") - } - } - if (!is.null(ne_c)) { - if (!is.numeric(ne_c) || length(ne_c) != 1L || is.na(ne_c) || - ne_c != floor(ne_c) || ne_c < 1L) { - stop("'ne_c' must be a single positive integer") - } - if (!is.numeric(alpha0e_c) || length(alpha0e_c) != 1L || is.na(alpha0e_c) || - alpha0e_c <= 0 || alpha0e_c > 1) { - stop("'alpha0e_c' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_c) || length(bar_ye_c) != 1L || is.na(bar_ye_c)) { - stop("'bar_ye_c' must be a single numeric value") - } - if (!is.numeric(se_c) || length(se_c) != 1L || is.na(se_c) || se_c <= 0) { - stop("'se_c' must be a single positive numeric value") - } - } - } - - # --- Simulation setup --- - set.seed(seed) - - # Shared across all mu_t scenarios: bar_y_t[scenario] = rowMeans(Z_t) + mu_t[scenario], - # and s_t is independent of mu_t, so it is computed once and reused. - Z_t <- matrix(rnorm(nsim * n_t, mean = 0, sd = sigma_t), nrow = nsim) - Z_t_rowmean <- rowSums(Z_t) / n_t - s_t <- sqrt(rowSums((Z_t - Z_t_rowmean) ^ 2) / (n_t - 1)) - - if (design == 'controlled' | design == 'external') { - # Generate nsim x n_c matrix of standardized residuals for the control group (mean=0, sd=sigma_c). - # mu_c is fixed to a single value, so bar_y_c and s_c are computed once. - Z_c <- matrix(rnorm(nsim * n_c, mean = 0, sd = sigma_c), nrow = nsim) - Z_c_rowmean <- rowSums(Z_c) / n_c - bar_y_c <- Z_c_rowmean + mu_c - s_c <- sqrt(rowSums((Z_c - Z_c_rowmean) ^ 2) / (n_c - 1)) - } else if (design == 'uncontrolled') { - # For uncontrolled design: no control group data generated - bar_y_c <- NULL - s_c <- NULL - } - - # External data are fixed historical sample statistics (no generation needed) - - # Ensure mu_t is a numeric vector to support multiple scenarios - mu_t <- as.numeric(mu_t) - n_scenarios <- length(mu_t) - - # Set threshold values based on probability type - if (prob == 'posterior') { - theta0_Go <- theta_TV - theta0_NoGo <- theta_MAV - } else { - theta0_Go <- theta_NULL - theta0_NoGo <- theta_NULL - } - - # Expand bar_y_t and s_t across all mu_t scenarios into a single vector of - # length nsim * n_scenarios. For bar_y_t, shift each scenario's block by mu_t[i]. - # s_t is independent of mu_t so it is simply replicated. - bar_y_t_all <- rep(Z_t_rowmean, times = n_scenarios) + rep(mu_t, each = nsim) - s_t_all <- rep(s_t, times = n_scenarios) - - if (design == 'controlled' | design == 'external') { - bar_y_c_all <- rep(bar_y_c, times = n_scenarios) - s_c_all <- rep(s_c, times = n_scenarios) - } else { - bar_y_c_all <- NULL - s_c_all <- NULL - } - - # Call pbayespostpred1cont once with the expanded vectors. - # Returns a vector of length nsim * n_scenarios. - gPost_Go_all <- pbayespostpred1cont( - prob = prob, design = design, prior = prior, CalcMethod = CalcMethod, - theta0 = theta0_Go, nMC = nMC, n_t = n_t, n_c = n_c, m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, kappa0_c = kappa0_c, nu0_t = nu0_t, nu0_c = nu0_c, - mu0_t = mu0_t, mu0_c = mu0_c, sigma0_t = sigma0_t, sigma0_c = sigma0_c, - bar_y_t = bar_y_t_all, bar_y_c = bar_y_c_all, s_t = s_t_all, s_c = s_c_all, - r = r, ne_t = ne_t, ne_c = ne_c, alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, se_t = se_t, se_c = se_c, - lower.tail = FALSE - ) - - gPost_NoGo_all <- pbayespostpred1cont( - prob = prob, design = design, prior = prior, CalcMethod = CalcMethod, - theta0 = theta0_NoGo, nMC = nMC, n_t = n_t, n_c = n_c, m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, kappa0_c = kappa0_c, nu0_t = nu0_t, nu0_c = nu0_c, - mu0_t = mu0_t, mu0_c = mu0_c, sigma0_t = sigma0_t, sigma0_c = sigma0_c, - bar_y_t = bar_y_t_all, bar_y_c = bar_y_c_all, s_t = s_t_all, s_c = s_c_all, - r = r, ne_t = ne_t, ne_c = ne_c, alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, se_t = se_t, se_c = se_c, - lower.tail = TRUE - ) - - # --- Decision indicators (Go, NoGo, Miss are mutually exclusive; Gray is the complement) --- - # Reshape results into nsim x n_scenarios matrices and compute decision - # probabilities per scenario using colMeans (no R-level loop needed). - probs_Go_mat <- matrix((gPost_Go_all >= gamma_go) & (gPost_NoGo_all < gamma_nogo), - nrow = nsim) - probs_NoGo_mat <- matrix((gPost_Go_all < gamma_go) & (gPost_NoGo_all >= gamma_nogo), - nrow = nsim) - probs_Miss_mat <- matrix((gPost_Go_all >= gamma_go) & (gPost_NoGo_all >= gamma_nogo), - nrow = nsim) - - GoNogoProb <- cbind( - colMeans(probs_Go_mat), - colMeans(probs_NoGo_mat), - colMeans(probs_Miss_mat) - ) # n_scenarios x 3 matrix - - # Check for positive Miss probabilities (indicates inappropriate thresholds) - if (error_if_Miss) { - if (any(GoNogoProb[, 3] > 0)) { - stop("Positive Miss probability detected. Please re-consider the chosen thresholds.") - } - } - - # Calculate Gray probability for each scenario (complement of Go and NoGo) - if (Gray_inc_Miss) { - # Include Miss in Gray probability - GrayProb <- 1 - rowSums(GoNogoProb[, -3, drop = FALSE]) - } else { - # Exclude Miss from Gray probability - GrayProb <- 1 - rowSums(GoNogoProb) - } - - # Create results data frame - if (design == 'uncontrolled') { - # For uncontrolled design, only include mu_t - results <- data.frame( - mu_t, Go = GoNogoProb[, 1], Gray = GrayProb, NoGo = GoNogoProb[, 2] - ) - } else { - # For controlled and external designs, include both mu_t and mu_c - results <- data.frame( - mu_t, mu_c, Go = GoNogoProb[, 1], Gray = GrayProb, NoGo = GoNogoProb[, 2] - ) - } - - # Add Miss column when error_if_Miss is FALSE and Gray_inc_Miss is FALSE - if (!error_if_Miss) { - if (!Gray_inc_Miss) { - results$Miss <- GoNogoProb[, 3] - } - } - - # Address floating point error (apply only to probability columns, not mu_t/mu_c) - prob_cols <- names(results)[!names(results) %in% c('mu_t', 'mu_c')] - results[prob_cols] <- lapply(results[prob_cols], function(col) { - ifelse(col < .Machine$double.eps ^ 0.25, 0, col) - }) - - # Attach metadata as attributes for use in print() - attr(results, 'prob') <- prob - attr(results, 'design') <- design - attr(results, 'prior') <- prior - attr(results, 'CalcMethod') <- CalcMethod - attr(results, 'nsim') <- nsim - attr(results, 'nMC') <- nMC - attr(results, 'theta_TV') <- theta_TV - attr(results, 'theta_MAV') <- theta_MAV - attr(results, 'theta_NULL') <- theta_NULL - attr(results, 'gamma_go') <- gamma_go - attr(results, 'gamma_nogo') <- gamma_nogo - attr(results, 'n_t') <- n_t - attr(results, 'n_c') <- n_c - attr(results, 'sigma_t') <- sigma_t - attr(results, 'sigma_c') <- sigma_c - attr(results, 'r') <- r - attr(results, 'm_t') <- m_t - attr(results, 'm_c') <- m_c - attr(results, 'kappa0_t') <- kappa0_t - attr(results, 'kappa0_c') <- kappa0_c - attr(results, 'nu0_t') <- nu0_t - attr(results, 'nu0_c') <- nu0_c - attr(results, 'mu0_t') <- mu0_t - attr(results, 'mu0_c') <- mu0_c - attr(results, 'sigma0_t') <- sigma0_t - attr(results, 'sigma0_c') <- sigma0_c - attr(results, 'ne_t') <- ne_t - attr(results, 'ne_c') <- ne_c - attr(results, 'alpha0e_t') <- alpha0e_t - attr(results, 'alpha0e_c') <- alpha0e_c - attr(results, 'bar_ye_t') <- bar_ye_t - attr(results, 'bar_ye_c') <- bar_ye_c - attr(results, 'se_t') <- se_t - attr(results, 'se_c') <- se_c - attr(results, 'error_if_Miss') <- error_if_Miss - attr(results, 'Gray_inc_Miss') <- Gray_inc_Miss - attr(results, 'seed') <- seed - - # Assign S3 class - class(results) <- c('pbayesdecisionprob1cont', 'data.frame') - - return(results) -} diff --git a/R/pbayesdecisionprob2bin.R b/R/pbayesdecisionprob2bin.R deleted file mode 100644 index 5585206..0000000 --- a/R/pbayesdecisionprob2bin.R +++ /dev/null @@ -1,1254 +0,0 @@ -#' Go/NoGo/Gray Decision Probabilities for a Clinical Trial with Two Binary -#' Endpoints -#' -#' Evaluates operating characteristics (Go, NoGo, Gray probabilities) for -#' clinical trials with two binary endpoints under the Bayesian framework. -#' The function supports controlled, uncontrolled, and external designs, -#' and uses both posterior probability and posterior predictive probability -#' criteria. -#' -#' Computation proceeds in two stages for efficiency. In Stage 1, posterior -#' or predictive probabilities are precomputed for every possible multinomial -#' count combination \eqn{(x_t, x_c)}. In Stage 2, operating characteristics -#' for each scenario are obtained by weighting the Stage 1 decisions by their -#' multinomial probabilities under the true parameters, avoiding repeated Monte -#' Carlo sampling per scenario. -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param GoRegions An integer vector specifying which of the nine posterior -#' regions (R1--R9) or four predictive regions (R1--R4) constitute a -#' Go decision. For \code{prob = 'posterior'}, valid values are -#' integers in 1--9; for \code{prob = 'predictive'}, in 1--4. -#' A common choice is \code{GoRegions = 1} (both endpoints exceed TV -#' or NULL for posterior/predictive, respectively). -#' @param NoGoRegions An integer vector specifying which regions constitute a -#' NoGo decision. A common choice is \code{NoGoRegions = 9} (both -#' endpoints below MAV) for posterior, or \code{NoGoRegions = 4} for -#' predictive. Must be disjoint from \code{GoRegions}. -#' @param gamma_go A numeric scalar in \code{(0, 1)}. Go threshold: -#' a Go decision is made if \eqn{P(\mathrm{GoRegions}) \ge \gamma_1}. -#' @param gamma_nogo A numeric scalar in \code{(0, 1)}. NoGo threshold: -#' a NoGo decision is made if \eqn{P(\mathrm{NoGoRegions}) \ge \gamma_2}. -#' No ordering constraint on \code{gamma_go} and \code{gamma_nogo} is -#' imposed; their combination determines the frequency of Miss outcomes. -#' @param pi_t1 A numeric vector of true treatment response probabilities -#' for Endpoint 1. Each element must be in \code{(0, 1)}. -#' @param pi_t2 A numeric vector of true treatment response probabilities -#' for Endpoint 2. Must have the same length as \code{pi_t1}. -#' @param rho_t A numeric vector of true within-treatment-arm correlations -#' between Endpoint 1 and Endpoint 2. Must have the same length as -#' \code{pi_t1}. If any element is outside the feasible range for -#' the corresponding \code{(pi_t1, pi_t2)} pair, that scenario returns -#' \code{NA} for all decision probabilities instead of stopping with -#' an error. -#' @param pi_c1 A numeric vector of true control response probabilities for -#' Endpoint 1. For \code{design = 'uncontrolled'}, this parameter -#' is not used in probability calculations but must still be supplied; -#' it is retained in the output for reference. Must have the same -#' length as \code{pi_t1}. -#' @param pi_c2 A numeric vector of true control response probabilities for -#' Endpoint 2. For \code{design = 'uncontrolled'}, see note for -#' \code{pi_c1}. Must have the same length as \code{pi_t1}. -#' @param rho_c A numeric vector of true within-control-arm correlations. -#' For \code{design = 'uncontrolled'}, not used in probability -#' calculations. Must have the same length as \code{pi_t1}. If any -#' element is outside the feasible range for the corresponding -#' \code{(pi_c1, pi_c2)} pair, that scenario returns \code{NA} for -#' all decision probabilities. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. For \code{design = 'uncontrolled'}, -#' this is the hypothetical control sample size (required for -#' consistency with other designs). -#' @param a_t_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 0)} response pattern in the treatment -#' group. -#' @param a_t_01 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 1)} response pattern in the treatment -#' group. -#' @param a_t_10 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 0)} response pattern in the treatment -#' group. -#' @param a_t_11 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 1)} response pattern in the treatment -#' group. -#' @param a_c_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 0)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_01 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 1)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_10 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 0)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_11 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 1)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param theta_TV1 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 1. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV1 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 1. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_TV2 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 2. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV2 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 2. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param z00 A non-negative integer giving the hypothetical control count -#' for pattern \code{(0, 0)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z01 A non-negative integer giving the hypothetical control count -#' for pattern \code{(0, 1)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z10 A non-negative integer giving the hypothetical control count -#' for pattern \code{(1, 0)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z11 A non-negative integer giving the hypothetical control count -#' for pattern \code{(1, 1)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param xe_t_00 A non-negative integer giving the external treatment group -#' count for pattern \code{(0, 0)}. Required when -#' \code{design = 'external'} and external treatment data are used; -#' otherwise \code{NULL}. -#' @param xe_t_01 A non-negative integer giving the external treatment group -#' count for pattern \code{(0, 1)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_t_10 A non-negative integer giving the external treatment group -#' count for pattern \code{(1, 0)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_t_11 A non-negative integer giving the external treatment group -#' count for pattern \code{(1, 1)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_c_00 A non-negative integer giving the external control group -#' count for pattern \code{(0, 0)}. Required when -#' \code{design = 'external'} and external control data are used; -#' otherwise \code{NULL}. -#' @param xe_c_01 A non-negative integer giving the external control group -#' count for pattern \code{(0, 1)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param xe_c_10 A non-negative integer giving the external control group -#' count for pattern \code{(1, 0)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param xe_c_11 A non-negative integer giving the external control group -#' count for pattern \code{(1, 1)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the treatment group. Required when external treatment -#' data are used; otherwise \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the control group. Required when external control -#' data are used; otherwise \code{NULL}. -#' @param nsim A positive integer giving the number of PoC count vectors -#' sampled via \code{rmultinom} per arm per scenario when -#' \code{CalcMethod = 'MC'} (outer loop). The sampled vectors are -#' deduplicated into \eqn{K_t} and \eqn{K_c} unique vectors -#' (\eqn{K_t, K_c \ll} \code{nsim}); Dirichlet sampling is then -#' performed only for these unique vectors using \code{nMC} draws each. -#' Ignored when \code{CalcMethod = 'Exact'}. Default is \code{10000}. -#' @param nMC A positive integer giving the number of Dirichlet draws used to -#' evaluate the decision probability for each count combination in -#' Stage 1. Used by both \code{CalcMethod = 'Exact'} and -#' \code{CalcMethod = 'MC'} (inner loop). Default is \code{10000}. -#' @param CalcMethod A character string specifying the computation method. -#' Must be \code{'Exact'} (default) or \code{'MC'}. -#' \code{'Exact'} uses full enumeration of all possible multinomial -#' count combinations (two-stage approach described in Details). -#' \code{'MC'} samples \code{nsim} \eqn{(x_t, x_c)} pairs via -#' \code{rmultinom}, deduplicates them into \eqn{K} unique pairs -#' (\eqn{K \ll} \code{nsim}), calls -#' \code{\link{pbayespostpred2bin}} for each unique pair to obtain -#' Go/NoGo probabilities, and weights the decisions by the observed -#' pair frequencies. This reuses the same validated probability logic -#' as the Exact method, avoiding any duplication of computation. -#' The \code{'MC'} method trades some Monte Carlo variance for -#' substantially reduced computation time when \code{n_t} and/or -#' \code{n_c} are large. -#' @param error_if_Miss A logical scalar; if \code{TRUE} (default), the -#' function stops with an error if the Miss probability is positive, -#' prompting reconsideration of the thresholds. -#' @param Gray_inc_Miss A logical scalar; if \code{TRUE}, the Miss -#' probability is added to Gray. If \code{FALSE} (default), Miss is -#' reported separately. Active only when -#' \code{error_if_Miss = FALSE}. -#' -#' @return A data frame with one row per scenario and columns: -#' \describe{ -#' \item{pi_t1}{True treatment response probability for Endpoint 1.} -#' \item{pi_t2}{True treatment response probability for Endpoint 2.} -#' \item{rho_t}{True within-arm correlation in the treatment arm.} -#' \item{pi_c1}{True control response probability for Endpoint 1 -#' (omitted when \code{design = 'uncontrolled'}).} -#' \item{pi_c2}{True control response probability for Endpoint 2 -#' (omitted when \code{design = 'uncontrolled'}).} -#' \item{rho_c}{True within-arm correlation in the control arm -#' (omitted when \code{design = 'uncontrolled'}).} -#' \item{Go}{Probability of making a Go decision.} -#' \item{Gray}{Probability of making a Gray (inconclusive) decision.} -#' \item{NoGo}{Probability of making a NoGo decision.} -#' \item{Miss}{Probability where Go and NoGo criteria are simultaneously -#' met. Included when \code{error_if_Miss = FALSE} and -#' \code{Gray_inc_Miss = FALSE}.} -#' } -#' The returned object has S3 class \code{pbayesdecisionprob2bin} with -#' an associated \code{print} method. -#' -#' @details -#' \strong{Two-stage computation.} -#' -#' Stage 1 (precomputation): All possible multinomial count combinations -#' \eqn{x_t} are enumerated using \code{\link{allmultinom}}. -#' For \code{design = 'controlled'} or \code{'external'}, all combinations -#' \eqn{x_c} are also enumerated and the Go/NoGo probability matrix -#' \code{PrGo[i, j]} has dimensions \eqn{n_t \times n_c}. -#' For \code{design = 'uncontrolled'}, the control distribution is fixed as -#' \eqn{\mathrm{Dir}(\alpha_{2,**} + z_{**})} and does not depend on any -#' observed control counts; the probability matrix therefore has dimensions -#' \eqn{n_t \times 1}, eliminating the \eqn{\binom{n_2+3}{3}}-row control -#' enumeration and the associated Gamma sampling. -#' This stage is independent of the true scenario parameters. -#' -#' Stage 2 (scenario evaluation): For each scenario -#' \eqn{(\pi_{t1}, \pi_{t2}, \rho_t, \pi_{c1}, \pi_{c2}, \rho_c)}, -#' \code{\link{getjointbin}} converts the marginal rates and correlation -#' into the four-cell probability vector \eqn{p_k}. The multinomial -#' probability mass function weights the Stage 1 decisions: -#' \deqn{\Pr(\mathrm{Go} \mid \Theta) = \sum_{i,j} -#' \mathbf{1}(\mathrm{Go}_{ij}) \cdot -#' P(x_{t,i} \mid n_1, p_t) \cdot P(x_{c,j} \mid n_2, p_c),} -#' where \eqn{\mathbf{1}(\mathrm{Go}_{ij})} is the Go indicator from Stage 1. -#' Stage 2 requires no additional Monte Carlo and is fast even for large -#' scenario grids. -#' -#' \strong{Decision categories.} -#' \itemize{ -#' \item \strong{Go}: sum of Go region probabilities \eqn{\ge \gamma_1} -#' AND sum of NoGo region probabilities \eqn{< \gamma_2}. -#' \item \strong{NoGo}: sum of Go region probabilities \eqn{< \gamma_1} -#' AND sum of NoGo region probabilities \eqn{\ge \gamma_2}. -#' \item \strong{Miss}: both Go and NoGo criteria satisfied simultaneously. -#' \item \strong{Gray}: neither Go nor NoGo criterion satisfied. -#' } -#' -#' @examples -#' -#' # Example 1: Posterior probability, controlled design (rho > 0) -#' # Explores the impact of positive within-arm endpoint correlation. -#' pbayesdecisionprob2bin( -#' prob = 'posterior', -#' design = 'controlled', -#' GoRegions = 1L, -#' NoGoRegions = 9L, -#' gamma_go = 0.52, -#' gamma_nogo = 0.52, -#' pi_t1 = c(0.15, 0.25, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.30, 0.35, 0.45), -#' rho_t = rep(0.6, 4), -#' pi_c1 = rep(0.15, 4), -#' pi_c2 = rep(0.20, 4), -#' rho_c = rep(0.6, 4), -#' n_t = 10, n_c = 10, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = NULL, m_c = NULL, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 2: Posterior probability, uncontrolled design -#' # Hypothetical control specified via pseudo-counts. -#' pbayesdecisionprob2bin( -#' prob = 'posterior', -#' design = 'uncontrolled', -#' GoRegions = 1L, -#' NoGoRegions = 9L, -#' gamma_go = 0.27, -#' gamma_nogo = 0.36, -#' pi_t1 = c(0.15, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.35, 0.45), -#' rho_t = rep(0.2, 3), -#' pi_c1 = NULL, -#' pi_c2 = NULL, -#' rho_c = NULL, -#' n_t = 10, n_c = NULL, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = NULL, m_c = NULL, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 3: Posterior probability, external control design -#' # External control data incorporated via power prior (alpha0e_c = 0.5). -#' pbayesdecisionprob2bin( -#' prob = 'posterior', -#' design = 'external', -#' GoRegions = 1L, -#' NoGoRegions = 9L, -#' gamma_go = 0.27, -#' gamma_nogo = 0.36, -#' pi_t1 = c(0.15, 0.25, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.30, 0.35, 0.45), -#' rho_t = rep(0.0, 4), -#' pi_c1 = rep(0.15, 4), -#' pi_c2 = rep(0.20, 4), -#' rho_c = rep(0.0, 4), -#' n_t = 10, n_c = 10, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = NULL, m_c = NULL, -#' theta_TV1 = 0.15, theta_MAV1 = 0.10, -#' theta_TV2 = 0.15, theta_MAV2 = 0.10, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = 4L, xe_c_01 = 2L, xe_c_10 = 3L, xe_c_11 = 1L, -#' alpha0e_t = NULL, alpha0e_c = 0.5, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 4: Predictive probability, controlled design -#' # Future trial has m_t = m_c = 30 patients per arm. -#' pbayesdecisionprob2bin( -#' prob = 'predictive', -#' design = 'controlled', -#' GoRegions = 1L, -#' NoGoRegions = 4L, -#' gamma_go = 0.60, -#' gamma_nogo = 0.80, -#' pi_t1 = c(0.15, 0.25, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.30, 0.35, 0.45), -#' rho_t = rep(0.3, 4), -#' pi_c1 = rep(0.15, 4), -#' pi_c2 = rep(0.20, 4), -#' rho_c = rep(0.3, 4), -#' n_t = 10, n_c = 10, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = 30L, m_c = 30L, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 5: Predictive probability, uncontrolled design -#' # Hypothetical control specified via pseudo-counts; future trial m_t = m_c = 30. -#' pbayesdecisionprob2bin( -#' prob = 'predictive', -#' design = 'uncontrolled', -#' GoRegions = 1L, -#' NoGoRegions = 4L, -#' gamma_go = 0.60, -#' gamma_nogo = 0.80, -#' pi_t1 = c(0.15, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.35, 0.45), -#' rho_t = rep(0.7, 3), -#' pi_c1 = rep(0.15, 3), -#' pi_c2 = rep(0.20, 3), -#' rho_c = rep(0.7, 3), -#' n_t = 10, n_c = 10, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = 30L, m_c = 30L, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' # Example 6: Predictive probability, external treatment design -#' # External treatment data incorporated via power prior (alpha0e_t = 0.5). -#' pbayesdecisionprob2bin( -#' prob = 'predictive', -#' design = 'external', -#' GoRegions = 1L, -#' NoGoRegions = 4L, -#' gamma_go = 0.60, -#' gamma_nogo = 0.80, -#' pi_t1 = c(0.15, 0.25, 0.30, 0.40), -#' pi_t2 = c(0.20, 0.30, 0.35, 0.45), -#' rho_t = rep(0.5, 4), -#' pi_c1 = rep(0.15, 4), -#' pi_c2 = rep(0.20, 4), -#' rho_c = rep(0.5, 4), -#' n_t = 10, n_c = 10, -#' a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, -#' a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, -#' m_t = 30L, m_c = 30L, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.10, theta_NULL2 = 0.10, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = 3L, xe_t_01 = 2L, xe_t_10 = 3L, xe_t_11 = 2L, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = 0.5, alpha0e_c = NULL, -#' nMC = 100, -#' error_if_Miss = FALSE, Gray_inc_Miss = FALSE -#' ) -#' -#' @importFrom stats dmultinom rmultinom rgamma rbinom -#' @export -pbayesdecisionprob2bin <- function(nsim = 10000L, - prob = 'posterior', - design = 'controlled', - GoRegions, - NoGoRegions, - gamma_go, - gamma_nogo, - pi_t1, pi_t2, rho_t, - pi_c1 = NULL, pi_c2 = NULL, rho_c = NULL, - n_t, n_c = NULL, - a_t_00, a_t_01, a_t_10, a_t_11, - a_c_00, a_c_01, a_c_10, a_c_11, - m_t = NULL, - m_c = NULL, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, - z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, - xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, - xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - nMC = 10000L, - CalcMethod = 'Exact', - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE) { - - # --------------------------------------------------------------------------- - # Section 1: Input validation - # --------------------------------------------------------------------------- - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c('Exact', 'MC')) - stop("'CalcMethod' must be either 'Exact' or 'MC'") - - if (CalcMethod == 'MC') { - if (!is.numeric(nsim) || length(nsim) != 1L || is.na(nsim) || - nsim != floor(nsim) || nsim < 1L) - stop("'nsim' must be a single positive integer") - nsim <- as.integer(nsim) - } - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - # Determine valid region range based on prob type - max_region <- if (prob == 'posterior') 9L else 4L - - if (!is.numeric(GoRegions) || length(GoRegions) < 1L || - any(is.na(GoRegions)) || any(GoRegions != floor(GoRegions)) || - any(GoRegions < 1L) || any(GoRegions > max_region)) { - stop(sprintf("'GoRegions' must be an integer vector with values in 1:%d", - max_region)) - } - - if (!is.numeric(NoGoRegions) || length(NoGoRegions) < 1L || - any(is.na(NoGoRegions)) || any(NoGoRegions != floor(NoGoRegions)) || - any(NoGoRegions < 1L) || any(NoGoRegions > max_region)) { - stop(sprintf("'NoGoRegions' must be an integer vector with values in 1:%d", - max_region)) - } - - if (length(intersect(GoRegions, NoGoRegions)) > 0L) { - stop("'GoRegions' and 'NoGoRegions' must be disjoint") - } - - if (!is.numeric(gamma_go) || length(gamma_go) != 1L || is.na(gamma_go) || - gamma_go <= 0 || gamma_go >= 1) { - stop("'gamma_go' must be a single numeric value in (0, 1)") - } - - if (!is.numeric(gamma_nogo) || length(gamma_nogo) != 1L || is.na(gamma_nogo) || - gamma_nogo <= 0 || gamma_nogo >= 1) { - stop("'gamma_nogo' must be a single numeric value in (0, 1)") - } - - # No ordering constraint on gamma_go and gamma_nogo is imposed; their - # combination determines the frequency of Miss outcomes. - - # --- Scenario vectors --- - pi_t1 <- as.numeric(pi_t1) - pi_t2 <- as.numeric(pi_t2) - rho_t <- as.numeric(rho_t) - pi_c1 <- as.numeric(pi_c1) - pi_c2 <- as.numeric(pi_c2) - rho_c <- as.numeric(rho_c) - - n_scen <- length(pi_t1) - - if (any(is.na(pi_t1)) || any(pi_t1 <= 0) || any(pi_t1 >= 1)) - stop("All elements of 'pi_t1' must be in (0, 1)") - if (length(pi_t2) != n_scen || any(is.na(pi_t2)) || - any(pi_t2 <= 0) || any(pi_t2 >= 1)) - stop("'pi_t2' must have the same length as 'pi_t1' with all elements in (0, 1)") - if (length(rho_t) != n_scen || any(is.na(rho_t))) - stop("'rho_t' must have the same length as 'pi_t1'") - - if (design != 'uncontrolled') { - pi_c1 <- as.numeric(pi_c1) - pi_c2 <- as.numeric(pi_c2) - rho_c <- as.numeric(rho_c) - if (length(pi_c1) != n_scen || any(is.na(pi_c1)) || - any(pi_c1 <= 0) || any(pi_c1 >= 1)) - stop("'pi_c1' must have the same length as 'pi_t1' with all elements in (0, 1)") - if (length(pi_c2) != n_scen || any(is.na(pi_c2)) || - any(pi_c2 <= 0) || any(pi_c2 >= 1)) - stop("'pi_c2' must have the same length as 'pi_t1' with all elements in (0, 1)") - if (length(rho_c) != n_scen || any(is.na(rho_c))) - stop("'rho_c' must have the same length as 'pi_t1'") - } - - # --- Sample sizes --- - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) - stop("'n_t' must be a single positive integer") - n_t <- as.integer(n_t) - - if (design != 'uncontrolled') { - if (!is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) - stop("'n_c' must be a single positive integer") - n_c <- as.integer(n_c) - } - - # --- Dirichlet prior parameters --- - for (nm in c("a_t_00", "a_t_01", "a_t_10", "a_t_11", - "a_c_00", "a_c_01", "a_c_10", "a_c_11")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - - # --- Threshold parameters --- - if (prob == 'posterior') { - for (nm in c("theta_TV1", "theta_MAV1", "theta_TV2", "theta_MAV2")) { - val <- get(nm) - if (is.null(val)) - stop(paste0("'", nm, "' must be non-NULL when prob = 'posterior'")) - if (!is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric value")) - } - if (theta_TV1 <= theta_MAV1) - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - if (theta_TV2 <= theta_MAV2) - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } else { - for (nm in c("theta_NULL1", "theta_NULL2")) { - val <- get(nm) - if (is.null(val)) - stop(paste0("'", nm, "' must be non-NULL when prob = 'predictive'")) - if (!is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric value")) - } - # For pbayespostpred2bin, predictive uses TV = MAV = NULL threshold - theta_TV1 <- theta_NULL1; theta_MAV1 <- theta_NULL1 - theta_TV2 <- theta_NULL2; theta_MAV2 <- theta_NULL2 - } - - # --- Future sample sizes --- - if (prob == 'predictive') { - if (is.null(m_t) || is.null(m_c)) - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - for (nm in c("m_t", "m_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) - stop(paste0("'", nm, "' must be a single positive integer")) - } - m_t <- as.integer(m_t); m_c <- as.integer(m_c) - } - - # --- Uncontrolled design: hypothetical control counts --- - if (design == 'uncontrolled') { - for (nm in c("z00", "z01", "z10", "z11")) { - val <- get(nm) - if (is.null(val)) - stop(paste0("'", nm, "' must be non-NULL when design = 'uncontrolled'")) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - - # --- External design --- - if (design == 'external') { - has_ext_t <- !is.null(xe_t_00) && !is.null(xe_t_01) && - !is.null(xe_t_10) && !is.null(xe_t_11) && !is.null(alpha0e_t) - has_ext_c <- !is.null(xe_c_00) && !is.null(xe_c_01) && - !is.null(xe_c_10) && !is.null(xe_c_11) && !is.null(alpha0e_c) - if (!has_ext_t && !has_ext_c) - stop(paste0("For design = 'external', at least one complete set of ", - "external data must be provided")) - } - - if (!is.logical(error_if_Miss) || length(error_if_Miss) != 1L || - is.na(error_if_Miss)) - stop("'error_if_Miss' must be a single logical value") - - if (!is.logical(Gray_inc_Miss) || length(Gray_inc_Miss) != 1L || - is.na(Gray_inc_Miss)) - stop("'Gray_inc_Miss' must be a single logical value") - - # --------------------------------------------------------------------------- - # Section 2 (MC): Unique-pair weighted Monte Carlo per scenario - # - # For each scenario s: - # 1. Sample nsim count vectors via rmultinom for each arm. - # 2. Deduplicate (x_t, x_c) pairs jointly; extract K unique pairs and - # their observed frequencies w (where K << nsim^2). - # 3. Call pbayespostpred2bin for each unique pair to obtain PrGo/PrNoGo, - # reusing the same validated logic as the Exact method. - # 4. Accumulate Go/NoGo/Miss probabilities weighted by w. - # --------------------------------------------------------------------------- - - if (CalcMethod == 'MC') { - - # --------------------------------------------------------------------------- - # MC method: sample nsim (x_t, x_c) pairs, deduplicate as joint pairs, - # call pbayespostpred2bin for each unique pair, then weight by frequency. - # - # Using pbayespostpred2bin directly guarantees the same computation as the - # Exact method's Stage 1, and avoids duplicating the posterior/predictive - # probability logic. - # --------------------------------------------------------------------------- - - result_mat <- matrix(0, nrow = n_scen, ncol = 3L) - - for (s in seq_len(n_scen)) { - - # Sample nsim treatment count vectors - p_t <- getjointbin(pi1 = pi_t1[s], pi2 = pi_t2[s], rho = rho_t[s]) - xt_raw <- t(rmultinom(nsim, size = n_t, prob = p_t)) # nsim x 4 - - if (design == 'uncontrolled') { - - # Deduplicate treatment counts only - xt_keys <- apply(xt_raw, 1L, paste, collapse = "_") - uniq_keys <- unique(xt_keys) - w_pairs <- tabulate(match(xt_keys, uniq_keys)) / nsim - K <- length(uniq_keys) - xt_uniq <- xt_raw[match(uniq_keys, xt_keys), , drop = FALSE] - - PrGo_vec <- numeric(K) - PrNoGo_vec <- numeric(K) - - for (i in seq_len(K)) { - Pr_R <- pbayespostpred2bin( - prob = prob, design = design, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - x_t_00 = xt_uniq[i, 1L], x_t_01 = xt_uniq[i, 2L], - x_t_10 = xt_uniq[i, 3L], x_t_11 = xt_uniq[i, 4L], - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = a_t_00, a_t_01 = a_t_01, a_t_10 = a_t_10, a_t_11 = a_t_11, - a_c_00 = a_c_00, a_c_01 = a_c_01, a_c_10 = a_c_10, a_c_11 = a_c_11, - m_t = m_t, m_c = m_c, - z00 = z00, z01 = z01, z10 = z10, z11 = z11, - xe_t_00 = xe_t_00, xe_t_01 = xe_t_01, - xe_t_10 = xe_t_10, xe_t_11 = xe_t_11, - xe_c_00 = xe_c_00, xe_c_01 = xe_c_01, - xe_c_10 = xe_c_10, xe_c_11 = xe_c_11, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - nMC = nMC - ) - PrGo_vec[i] <- sum(Pr_R[GoRegions]) - PrNoGo_vec[i] <- sum(Pr_R[NoGoRegions]) - } - - } else { - - # Sample nsim control count vectors - p_c <- getjointbin(pi1 = pi_c1[s], pi2 = pi_c2[s], rho = rho_c[s]) - xc_raw <- t(rmultinom(nsim, size = n_c, prob = p_c)) # nsim x 4 - - # Deduplicate (x_t, x_c) pairs jointly - pair_keys <- paste( - apply(xt_raw, 1L, paste, collapse = "_"), - apply(xc_raw, 1L, paste, collapse = "_"), - sep = "|" - ) - uniq_keys <- unique(pair_keys) - w_pairs <- tabulate(match(pair_keys, uniq_keys)) / nsim - K <- length(uniq_keys) - - uniq_idx <- match(uniq_keys, pair_keys) - xt_uniq <- xt_raw[uniq_idx, , drop = FALSE] - xc_uniq <- xc_raw[uniq_idx, , drop = FALSE] - - PrGo_vec <- numeric(K) - PrNoGo_vec <- numeric(K) - - for (i in seq_len(K)) { - Pr_R <- pbayespostpred2bin( - prob = prob, design = design, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - x_t_00 = xt_uniq[i, 1L], x_t_01 = xt_uniq[i, 2L], - x_t_10 = xt_uniq[i, 3L], x_t_11 = xt_uniq[i, 4L], - x_c_00 = xc_uniq[i, 1L], x_c_01 = xc_uniq[i, 2L], - x_c_10 = xc_uniq[i, 3L], x_c_11 = xc_uniq[i, 4L], - a_t_00 = a_t_00, a_t_01 = a_t_01, a_t_10 = a_t_10, a_t_11 = a_t_11, - a_c_00 = a_c_00, a_c_01 = a_c_01, a_c_10 = a_c_10, a_c_11 = a_c_11, - m_t = m_t, m_c = m_c, - z00 = z00, z01 = z01, z10 = z10, z11 = z11, - xe_t_00 = xe_t_00, xe_t_01 = xe_t_01, - xe_t_10 = xe_t_10, xe_t_11 = xe_t_11, - xe_c_00 = xe_c_00, xe_c_01 = xe_c_01, - xe_c_10 = xe_c_10, xe_c_11 = xe_c_11, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - nMC = nMC - ) - PrGo_vec[i] <- sum(Pr_R[GoRegions]) - PrNoGo_vec[i] <- sum(Pr_R[NoGoRegions]) - } - } - - # --- Decision indicators (Go, NoGo, Miss are mutually exclusive; Gray is the complement) --- - # Accumulate Go/NoGo/Miss using frequency weights - ind_Go <- (PrGo_vec >= gamma_go) & (PrNoGo_vec < gamma_nogo) - ind_NoGo <- (PrGo_vec < gamma_go) & (PrNoGo_vec >= gamma_nogo) - ind_Miss <- (PrGo_vec >= gamma_go) & (PrNoGo_vec >= gamma_nogo) - - result_mat[s, 1L] <- sum(ind_Go * w_pairs) - result_mat[s, 2L] <- sum(ind_NoGo * w_pairs) - result_mat[s, 3L] <- sum(ind_Miss * w_pairs) - } - - } else { - - # --------------------------------------------------------------------------- - # Section 2 (Exact): Stage 1 -- Precompute decision probabilities for all - # count combinations using fully vectorised batch Gamma sampling. - # - # Key idea: Dirichlet posterior Dir(alpha + x) can be sampled via - # Gamma(alpha_k + x_k, 1) normalised by their row sum. - # We split this into: - # Y_k ~ Gamma(alpha_k, 1) [prior component, shared across all x] - # Z_k ~ Gamma(x_k, 1) [data component, specific to each x] - # and generate all Y and Z draws in a single rgamma() call each, - # then add them to form the unnormalised posterior samples. - # This reduces function-call overhead from n_t * n_c calls to O(1) calls. - # --------------------------------------------------------------------------- - - # Enumerate all possible count vectors for each arm - counts_t <- allmultinom(n_t) # (n_t x 4) integer matrix - n_row_t <- nrow(counts_t) - - # For uncontrolled design, the control distribution is fixed (Dir(a2 + z)) - # and does not vary with observed control counts. The Stage 1 probability - # matrix therefore needs only a single column (n_c = 1), avoiding the - # generation of the full allmultinom(n_c) table (C(n_c+3,3) rows). - if (design == 'uncontrolled') { - n_row_c <- 1L - } else { - counts_c <- allmultinom(n_c) # (n_c x 4) integer matrix - n_row_c <- nrow(counts_c) - } - - # --- Build posterior Dirichlet base parameters (prior + external data) --- - xe_t_w <- if (!is.null(alpha0e_t) && design == 'external') alpha0e_t else 0 - xe_c_w <- if (!is.null(alpha0e_c) && design == 'external') alpha0e_c else 0 - - alpha_t_base <- c( - a_t_00 + xe_t_w * ifelse(!is.null(xe_t_00), xe_t_00, 0), - a_t_01 + xe_t_w * ifelse(!is.null(xe_t_01), xe_t_01, 0), - a_t_10 + xe_t_w * ifelse(!is.null(xe_t_10), xe_t_10, 0), - a_t_11 + xe_t_w * ifelse(!is.null(xe_t_11), xe_t_11, 0) - ) - - if (design == 'uncontrolled') { - # Hypothetical control: fixed Dir(a2 + z), no data component varies - alpha_c_fixed <- c(a_c_00 + z00, a_c_01 + z01, a_c_10 + z10, a_c_11 + z11) - } else { - alpha_c_base <- c( - a_c_00 + xe_c_w * ifelse(!is.null(xe_c_00), xe_c_00, 0), - a_c_01 + xe_c_w * ifelse(!is.null(xe_c_01), xe_c_01, 0), - a_c_10 + xe_c_w * ifelse(!is.null(xe_c_10), xe_c_10, 0), - a_c_11 + xe_c_w * ifelse(!is.null(xe_c_11), xe_c_11, 0) - ) - } - - # --- Batch Gamma sampling: prior component (nMC x 4) --- - # Y_t[u, k] ~ Gamma(alpha_t_base[k], 1), shared across all x_t - # Y_c[u, k] ~ Gamma(alpha_c_base[k], 1), shared across all x_c - Y_t <- matrix(rgamma(nMC * 4L, shape = rep(alpha_t_base, each = nMC)), - nrow = nMC, ncol = 4L) - - if (design == 'uncontrolled') { - # Control is fixed: sample once from Dir(alpha_c_fixed) - G_c_fixed <- matrix(rgamma(nMC * 4L, - shape = rep(alpha_c_fixed, each = nMC)), - nrow = nMC, ncol = 4L) - S_c_fixed <- rowSums(G_c_fixed) - p_c_fixed <- G_c_fixed / S_c_fixed # (nMC x 4) Dirichlet samples - } else { - Y_c <- matrix(rgamma(nMC * 4L, shape = rep(alpha_c_base, each = nMC)), - nrow = nMC, ncol = 4L) - } - - # --- For predictive: pre-generate uniform random draws for future data --- - # (Sequential binomial approach; uniform variates reused across count combos - # is NOT valid because each combo has different p parameters. - # We therefore keep the sequential-binomial loop but operate on the - # nMC-length p vectors produced per combo from the batch Gamma above.) - - # --- Precompute Gamma data components for all count combinations --- - # Z_t[i, u, k] ~ Gamma(counts_t[i, k] + 1, 1) would be expensive; - # instead we use the additive property: - # Gamma(alpha + x, 1) = Gamma(alpha, 1) + Gamma(x, 1) [in distribution] - # Z_t_arr[i, u, k]: nMC draws of Gamma(counts_t[i,k], 1) for each i. - # We generate all at once: shape vector of length n_row_t * nMC * 4. - # To avoid Gamma(0, 1) (undefined), we clamp shapes to a small epsilon - # and note that Gamma(0,1) = 0 a.s., so we handle zeros separately. - - # Vectorised Gamma draws for treatment arm data component. - # Replicate each row of counts_t nMC times: row block i holds counts_t[i, ] - # for nMC consecutive rows, giving the correct (n_row_t * nMC x 4) shape matrix. - shapes_t_rep <- counts_t[rep(seq_len(n_row_t), each = nMC), , drop = FALSE] - zero_mask_t <- shapes_t_rep == 0L - shapes_t_rep[zero_mask_t] <- 1L - raw_t <- rgamma(n_row_t * nMC * 4L, shape = shapes_t_rep, rate = 1) - raw_t[zero_mask_t] <- 0 # Gamma(0,1) = 0 a.s. - Z_t_mat <- matrix(raw_t, nrow = n_row_t * nMC, ncol = 4L) - - if (design != 'uncontrolled') { - shapes_c_rep <- counts_c[rep(seq_len(n_row_c), each = nMC), , drop = FALSE] - zero_mask_c <- shapes_c_rep == 0L - shapes_c_rep[zero_mask_c] <- 1L - raw_c <- rgamma(n_row_c * nMC * 4L, shape = shapes_c_rep, rate = 1) - raw_c[zero_mask_c] <- 0 - Z_c_mat <- matrix(raw_c, nrow = n_row_c * nMC, ncol = 4L) - } - - # --- Helper: compute PrGo and PrNoGo from a set of (p_t, p_c) samples --- - # p_t, p_c: (nMC x 4) matrices of Dirichlet samples - .compute_PrGoNoGo <- function(p_t, p_c) { - - # Marginal response rates and treatment effects - theta1 <- (p_t[, 3L] + p_t[, 4L]) - (p_c[, 3L] + p_c[, 4L]) - theta2 <- (p_t[, 2L] + p_t[, 4L]) - (p_c[, 2L] + p_c[, 4L]) - - if (prob == 'posterior') { - # Region index: row-major, Endpoint 1 slowest (3 x 3 grid -> 9 regions) - r1 <- 3L - as.integer(theta1 > theta_MAV1) - - as.integer(theta1 > theta_TV1) - r2 <- 3L - as.integer(theta2 > theta_MAV2) - - as.integer(theta2 > theta_TV2) - region <- (r1 - 1L) * 3L + r2 - Pr_R <- tabulate(region, nbins = 9L) / nMC - - } else { - # Predictive: simulate future multinomial data via sequential binomials - x1f <- matrix(0L, nrow = nMC, ncol = 4L) - x2f <- matrix(0L, nrow = nMC, ncol = 4L) - rem1 <- rep(m_t, nMC); rem2 <- rep(m_c, nMC) - u1 <- rep(0, nMC); u2 <- rep(0, nMC) - - for (jj in seq_len(3L)) { - d1 <- pmax(1 - u1, 0); d2 <- pmax(1 - u2, 0) - q1 <- pmin(pmax(ifelse(d1 > 0, p_t[, jj] / d1, 0), 0), 1) - q2 <- pmin(pmax(ifelse(d2 > 0, p_c[, jj] / d2, 0), 0), 1) - b1 <- rbinom(nMC, rem1, q1); b2 <- rbinom(nMC, rem2, q2) - x1f[, jj] <- b1; x2f[, jj] <- b2 - rem1 <- rem1 - b1; rem2 <- rem2 - b2 - u1 <- u1 + p_t[, jj]; u2 <- u2 + p_c[, jj] - } - x1f[, 4L] <- rem1; x2f[, 4L] <- rem2 - - theta1 <- (x1f[, 3L] + x1f[, 4L]) / m_t - - (x2f[, 3L] + x2f[, 4L]) / m_c - theta2 <- (x1f[, 2L] + x1f[, 4L]) / m_t - - (x2f[, 2L] + x2f[, 4L]) / m_c - - r1 <- 2L - as.integer(theta1 > theta_TV1) - r2 <- 2L - as.integer(theta2 > theta_TV2) - region <- (r1 - 1L) * 2L + r2 - Pr_R <- tabulate(region, nbins = 4L) / nMC - } - - list(PrGo = sum(Pr_R[GoRegions]), - PrNoGo = sum(Pr_R[NoGoRegions])) - } - - # --- Main Stage 1 loop: iterate over treatment count combinations --- - # For the controlled/external case, we eliminate the inner j-loop by - # computing region memberships for all n_row_c control combos simultaneously. - # - # For each treatment combo i: - # p_t[u, k] = (Y_t[u,k] + Z_t[i,u,k]) / rowSum -- (nMC x 4) - # - # theta1_t[u] = p_t[u,3] + p_t[u,4] (treatment marginal for Endpoint 1) - # theta2_t[u] = p_t[u,2] + p_t[u,4] (treatment marginal for Endpoint 2) - # - # For each control combo j: - # theta1_c[u] = p_c[u,3] + p_c[u,4] - # theta2_c[u] = p_c[u,2] + p_c[u,4] - # - # region_ij = f(theta1_t[u] - theta1_c[u], theta2_t[u] - theta2_c[u]) - # - # Key vectorisation: pre-compute normalised p_c for ALL j at once: - # p_c_all: (n_row_c * nMC x 4) -- all control combos stacked - # Then for fixed i, broadcast theta_t (length nMC) against - # theta_c (n_row_c blocks of nMC) to get all n_row_c results in one pass. - - PrGo_mat <- matrix(0, nrow = n_row_t, ncol = n_row_c) - PrNoGo_mat <- matrix(0, nrow = n_row_t, ncol = n_row_c) - - if (design == 'uncontrolled') { - - # --- Uncontrolled: single fixed control distribution --- - for (i in seq_len(n_row_t)) { - idx1 <- ((i - 1L) * nMC + 1L):(i * nMC) - G1 <- Y_t + Z_t_mat[idx1, , drop = FALSE] - p_t <- G1 / rowSums(G1) - - res <- .compute_PrGoNoGo(p_t, p_c_fixed) - # n_row_c = 1 for uncontrolled, so only column 1 exists - PrGo_mat[i, 1L] <- res$PrGo - PrNoGo_mat[i, 1L] <- res$PrNoGo - } - - } else { - - # --- Controlled / External: vectorise over all j for each i --- - - # Pre-normalise all control combos: p_c_all is (n_row_c * nMC) x 4 - G_c_all <- Y_c[rep(seq_len(nMC), times = n_row_c), , drop = FALSE] + Z_c_mat - p_c_all <- G_c_all / rowSums(G_c_all) - - # Pre-compute control marginals for all combos: each is length n_row_c * nMC - # theta_c1[j-block, u] = p_c_all[(j-1)*nMC+u, 3] + p_c_all[(j-1)*nMC+u, 4] - tc1_all <- p_c_all[, 3L] + p_c_all[, 4L] # length n_row_c * nMC - tc2_all <- p_c_all[, 2L] + p_c_all[, 4L] # length n_row_c * nMC - - # Pre-compute control marginals reshaped as (nMC x n_row_c) matrices. - # tc1_mat[u, j] = marginal for Endpoint 1 in control combo j, MC draw u - # tc2_mat[u, j] = marginal for Endpoint 2 in control combo j, MC draw u - # This avoids rep() inside the i-loop (case B optimisation). - tc1_mat <- matrix(tc1_all, nrow = nMC, ncol = n_row_c) - tc2_mat <- matrix(tc2_all, nrow = nMC, ncol = n_row_c) - - if (prob == 'predictive') { - # Pre-compute future multinomial draws for ALL control combos at once. - # Layout of p_c_all: (n_row_c * nMC) x 4, blocks of nMC rows per combo j. - # Sequential binomial for all n_row_c * nMC rows simultaneously (case C). - x2f_all <- matrix(0L, nrow = n_row_c * nMC, ncol = 4L) - rem2_all <- rep(m_c, n_row_c * nMC) - u2_all <- rep(0, n_row_c * nMC) - for (jj in seq_len(3L)) { - d2_all <- pmax(1 - u2_all, 0) - q2_all <- pmin(pmax( - ifelse(d2_all > 0, p_c_all[, jj] / d2_all, 0), 0), 1) - b2_all <- rbinom(n_row_c * nMC, rem2_all, q2_all) - x2f_all[, jj] <- b2_all - rem2_all <- rem2_all - b2_all - u2_all <- u2_all + p_c_all[, jj] - } - x2f_all[, 4L] <- rem2_all - - # Endpoint marginals for future control data: (nMC x n_row_c) matrices - # fut_tc1_mat[u, j] = (x2f_all[(j-1)*nMC+u, 3] + x2f_all[..., 4]) / m_c - fut_tc1_mat <- matrix( - (x2f_all[, 3L] + x2f_all[, 4L]) / m_c, nrow = nMC, ncol = n_row_c) - fut_tc2_mat <- matrix( - (x2f_all[, 2L] + x2f_all[, 4L]) / m_c, nrow = nMC, ncol = n_row_c) - } - - for (i in seq_len(n_row_t)) { - idx1 <- ((i - 1L) * nMC + 1L):(i * nMC) - G1 <- Y_t + Z_t_mat[idx1, , drop = FALSE] - p_t <- G1 / rowSums(G1) - - # Treatment marginals: (nMC x 1) vectors - tt1 <- p_t[, 3L] + p_t[, 4L] - tt2 <- p_t[, 2L] + p_t[, 4L] - - if (prob == 'posterior') { - - # th1_mat[u, j] = tt1[u] - tc1_mat[u, j] (nMC x n_row_c, no rep()) - th1_mat <- tt1 - tc1_mat # R broadcasts (nMC) against (nMC x n_row_c) - th2_mat <- tt2 - tc2_mat - - # Region classification: (nMC x n_row_c) integer matrices - r1_mat <- 3L - (th1_mat > theta_MAV1) - (th1_mat > theta_TV1) - r2_mat <- 3L - (th2_mat > theta_MAV2) - (th2_mat > theta_TV2) - reg_mat <- (r1_mat - 1L) * 3L + r2_mat # values in 1..9 - - # Go/NoGo indicator matrices (nMC x n_row_c), then column means = PrGo[i,] - # matrix() restores dimensions lost by %in% (which returns a plain vector) - PrGo_mat[i, ] <- colMeans( - matrix(reg_mat %in% GoRegions, nrow = nMC, ncol = n_row_c)) - PrNoGo_mat[i, ] <- colMeans( - matrix(reg_mat %in% NoGoRegions, nrow = nMC, ncol = n_row_c)) - - } else { - - # Predictive: simulate future treatment data for this combo i - x1f <- matrix(0L, nrow = nMC, ncol = 4L) - rem1 <- rep(m_t, nMC) - u1 <- rep(0, nMC) - for (jj in seq_len(3L)) { - d1 <- pmax(1 - u1, 0) - q1 <- pmin(pmax(ifelse(d1 > 0, p_t[, jj] / d1, 0), 0), 1) - b1 <- rbinom(nMC, rem1, q1) - x1f[, jj] <- b1 - rem1 <- rem1 - b1 - u1 <- u1 + p_t[, jj] - } - x1f[, 4L] <- rem1 - - # Future treatment marginals: (nMC x 1) vectors - fut_tt1 <- (x1f[, 3L] + x1f[, 4L]) / m_t - fut_tt2 <- (x1f[, 2L] + x1f[, 4L]) / m_t - - # Difference matrices (nMC x n_row_c) using pre-computed control futures - fth1_mat <- fut_tt1 - fut_tc1_mat - fth2_mat <- fut_tt2 - fut_tc2_mat - - r1_mat <- 2L - (fth1_mat > theta_TV1) - r2_mat <- 2L - (fth2_mat > theta_TV2) - reg_mat <- (r1_mat - 1L) * 2L + r2_mat - - PrGo_mat[i, ] <- colMeans( - matrix(reg_mat %in% GoRegions, nrow = nMC, ncol = n_row_c)) - PrNoGo_mat[i, ] <- colMeans( - matrix(reg_mat %in% NoGoRegions, nrow = nMC, ncol = n_row_c)) - } - } - } - - # --- Decision indicators (Go, NoGo, Miss are mutually exclusive; Gray is the complement) --- - ind_Go <- (PrGo_mat >= gamma_go) & (PrNoGo_mat < gamma_nogo) - ind_NoGo <- (PrGo_mat < gamma_go) & (PrNoGo_mat >= gamma_nogo) - ind_Miss <- (PrGo_mat >= gamma_go) & (PrNoGo_mat >= gamma_nogo) - - # --------------------------------------------------------------------------- - # Section 3 (Exact): Stage 2 -- Compute operating characteristics per - # scenario by weighting Stage 1 decisions with multinomial - # probabilities - # --------------------------------------------------------------------------- - - # Result matrix: columns = Go, NoGo, Miss - result_mat <- matrix(0, nrow = n_scen, ncol = 3L) - - for (s in seq_len(n_scen)) { - - # Convert (pi, rho) to four-cell probability vector for each arm. - # If the correlation is infeasible for the given marginals, return NA - # for this scenario instead of stopping with an error. - p_t <- tryCatch( - getjointbin(pi1 = pi_t1[s], pi2 = pi_t2[s], rho = rho_t[s]), - error = function(e) NULL - ) - - if (is.null(p_t)) { - result_mat[s, ] <- NA_real_ - next - } - - if (design == 'uncontrolled') { - # Control distribution is fixed (Dir(a2 + z)) and independent of x_c. - # Stage 1 was computed with n_row_c = 1, so ind_Go/ind_NoGo/ind_Miss have - # exactly one column. Only treatment counts contribute multinomial - # weights; the control column index is always 1. - w_t <- apply(counts_t, 1L, function(x) - dmultinom(x, size = n_t, prob = p_t)) - - result_mat[s, 1L] <- sum(ind_Go[, 1L] * w_t) - result_mat[s, 2L] <- sum(ind_NoGo[, 1L] * w_t) - result_mat[s, 3L] <- sum(ind_Miss[, 1L] * w_t) - - } else { - # Controlled or external: both arms contribute multinomial weights - p_c <- tryCatch( - getjointbin(pi1 = pi_c1[s], pi2 = pi_c2[s], rho = rho_c[s]), - error = function(e) NULL - ) - - if (is.null(p_c)) { - result_mat[s, ] <- NA_real_ - next - } - - w_t <- apply(counts_t, 1L, function(x) - dmultinom(x, size = n_t, prob = p_t)) - w_c <- apply(counts_c, 1L, function(x) - dmultinom(x, size = n_c, prob = p_c)) - - # Outer product of weights: w[i,j] = w_t[i] * w_c[j] - w_mat <- outer(w_t, w_c) - - result_mat[s, 1L] <- sum(ind_Go * w_mat) - result_mat[s, 2L] <- sum(ind_NoGo * w_mat) - result_mat[s, 3L] <- sum(ind_Miss * w_mat) - } - } - - } # end if (CalcMethod == 'MC') ... else ... - - # --------------------------------------------------------------------------- - # Section 4: Assemble output - # --------------------------------------------------------------------------- - - # Suppress floating-point rounding artefacts near zero before Miss check - # (only for non-NA rows) - non_na <- !is.na(result_mat[, 1L]) - result_mat[non_na & result_mat < .Machine$double.eps ^ 0.25] <- 0 - - # Check for positive Miss probability (after zeroing out numerical noise) - if (error_if_Miss && any(result_mat[non_na, 3L] > 0)) { - stop("Positive Miss probability detected. Please re-consider the chosen thresholds.") - } - - # Gray probability = complement of Go + NoGo (+ Miss if not included) - # NA scenarios propagate NA to GrayProb automatically - if (Gray_inc_Miss) { - GrayProb <- 1 - result_mat[, 1L] - result_mat[, 2L] - } else { - GrayProb <- 1 - rowSums(result_mat) - } - - # Build the results data frame - if (design == 'uncontrolled') { - results <- data.frame( - pi_t1 = pi_t1, - pi_t2 = pi_t2, - rho_t = rho_t, - Go = result_mat[, 1L], - Gray = GrayProb, - NoGo = result_mat[, 2L] - ) - } else { - results <- data.frame( - pi_t1 = pi_t1, - pi_t2 = pi_t2, - rho_t = rho_t, - pi_c1 = pi_c1, - pi_c2 = pi_c2, - rho_c = rho_c, - Go = result_mat[, 1L], - Gray = GrayProb, - NoGo = result_mat[, 2L] - ) - } - - if (!error_if_Miss && !Gray_inc_Miss) { - results$Miss <- result_mat[, 3L] - } - - # Attach metadata as attributes for use in print() - attr(results, 'prob') <- prob - attr(results, 'design') <- design - attr(results, 'GoRegions') <- GoRegions - attr(results, 'NoGoRegions') <- NoGoRegions - attr(results, 'gamma_go') <- gamma_go - attr(results, 'gamma_nogo') <- gamma_nogo - attr(results, 'n_t') <- n_t - attr(results, 'n_c') <- n_c - attr(results, 'a_t_00') <- a_t_00 - attr(results, 'a_t_01') <- a_t_01 - attr(results, 'a_t_10') <- a_t_10 - attr(results, 'a_t_11') <- a_t_11 - attr(results, 'a_c_00') <- a_c_00 - attr(results, 'a_c_01') <- a_c_01 - attr(results, 'a_c_10') <- a_c_10 - attr(results, 'a_c_11') <- a_c_11 - attr(results, 'm_t') <- m_t - attr(results, 'm_c') <- m_c - attr(results, 'theta_TV1') <- theta_TV1 - attr(results, 'theta_MAV1') <- theta_MAV1 - attr(results, 'theta_TV2') <- theta_TV2 - attr(results, 'theta_MAV2') <- theta_MAV2 - attr(results, 'theta_NULL1') <- theta_NULL1 - attr(results, 'theta_NULL2') <- theta_NULL2 - attr(results, 'z00') <- z00 - attr(results, 'z01') <- z01 - attr(results, 'z10') <- z10 - attr(results, 'z11') <- z11 - attr(results, 'xe_t_00') <- xe_t_00 - attr(results, 'xe_t_01') <- xe_t_01 - attr(results, 'xe_t_10') <- xe_t_10 - attr(results, 'xe_t_11') <- xe_t_11 - attr(results, 'xe_c_00') <- xe_c_00 - attr(results, 'xe_c_01') <- xe_c_01 - attr(results, 'xe_c_10') <- xe_c_10 - attr(results, 'xe_c_11') <- xe_c_11 - attr(results, 'alpha0e_t') <- alpha0e_t - attr(results, 'alpha0e_c') <- alpha0e_c - attr(results, 'nMC') <- nMC - attr(results, 'nsim') <- nsim - attr(results, 'CalcMethod') <- CalcMethod - attr(results, 'error_if_Miss') <- error_if_Miss - attr(results, 'Gray_inc_Miss') <- Gray_inc_Miss - - class(results) <- c('pbayesdecisionprob2bin', 'data.frame') - - return(results) -} diff --git a/R/pbayesdecisionprob2cont.R b/R/pbayesdecisionprob2cont.R deleted file mode 100644 index 5530b82..0000000 --- a/R/pbayesdecisionprob2cont.R +++ /dev/null @@ -1,941 +0,0 @@ -#' Go/NoGo/Gray Decision Probabilities for Two Continuous Endpoints -#' -#' Computes the operating characteristics (Go, NoGo, Gray, and optionally Miss -#' probabilities) for a two-continuous-endpoint Bayesian Go/NoGo decision -#' framework by Monte Carlo simulation over treatment scenarios. -#' -#' @param nsim A positive integer. Number of simulated datasets per scenario. -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param prior A character string specifying the prior distribution. -#' Must be \code{'vague'} or \code{'N-Inv-Wishart'}. -#' @param GoRegions An integer vector specifying which of the nine posterior -#' regions (R1--R9) or four predictive regions (R1--R4) constitute a -#' Go decision. For \code{prob = 'posterior'}, valid values are -#' integers in 1--9; for \code{prob = 'predictive'}, in 1--4. -#' A common choice is \code{GoRegions = 1} (both endpoints exceed TV -#' or NULL for posterior/predictive, respectively). -#' @param NoGoRegions An integer vector specifying which regions constitute a -#' NoGo decision. A common choice is \code{NoGoRegions = 9} (both -#' endpoints below MAV) for posterior, or \code{NoGoRegions = 4} for -#' predictive. Must be disjoint from \code{GoRegions}. -#' @param gamma_go A numeric scalar in \code{(0, 1)}. Go threshold: -#' a Go decision is made if \eqn{P(\mathrm{GoRegions}) \ge \gamma_1}. -#' @param gamma_nogo A numeric scalar in \code{(0, 1)}. NoGo threshold: -#' a NoGo decision is made if \eqn{P(\mathrm{NoGoRegions}) \ge \gamma_2}. -#' No ordering constraint on \code{gamma_go} and \code{gamma_nogo} is -#' imposed; their combination determines the frequency of Miss outcomes. -#' @param theta_TV1 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 1. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV1 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 1. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_TV2 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 2. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV2 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 2. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. For \code{design = 'uncontrolled'}, -#' this is the hypothetical control sample size (required for -#' consistency with other designs). -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param mu_t Numeric matrix with 2 columns. Each row gives the true treatment -#' mean vector for one scenario. A length-2 vector is coerced to a -#' 1-row matrix. -#' @param Sigma_t A 2x2 positive-definite matrix. True treatment covariance. -#' @param mu_c Numeric matrix with 2 columns or a length-2 vector. True control -#' (or hypothetical control) mean vector(s). -#' @param Sigma_c A 2x2 positive-definite matrix. True control covariance. -#' @param kappa0_t A positive numeric scalar giving the NIW prior -#' concentration parameter for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param nu0_t A numeric scalar giving the NIW prior degrees of freedom for -#' the treatment group. Must be greater than 3. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param mu0_t A numeric vector of length 2 giving the NIW prior mean for -#' the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param Lambda0_t A 2x2 positive-definite numeric matrix giving the NIW -#' prior scale matrix for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param kappa0_c A positive numeric scalar giving the NIW prior -#' concentration parameter for the control group. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param nu0_c A numeric scalar giving the NIW prior degrees of freedom for -#' the control group. Must be greater than 3. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param mu0_c A numeric vector of length 2 giving the NIW prior mean for -#' the control group, or the hypothetical control location when -#' \code{design = 'uncontrolled'}. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param Lambda0_c A 2x2 positive-definite numeric matrix giving the NIW -#' prior scale matrix for the control group. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param r A positive numeric scalar giving the variance scaling factor for -#' the hypothetical control distribution. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param ne_t A positive integer giving the external treatment group sample -#' size. Required when \code{design = 'external'} and external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the external control group sample -#' size. Required when \code{design = 'external'} and external -#' control data are used; otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external treatment data. Required when external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external control data. Required when external -#' control data are used; otherwise set to \code{NULL}. -#' @param bar_ye_t A numeric vector of length 2 giving the external treatment -#' group sample mean. Required when external treatment data are used; -#' otherwise set to \code{NULL}. -#' @param bar_ye_c A numeric vector of length 2 giving the external control -#' group sample mean. Required when external control data are used; -#' otherwise set to \code{NULL}. -#' @param se_t A 2x2 numeric matrix giving the external treatment group -#' sum-of-squares matrix. Required when external treatment data are -#' used; otherwise set to \code{NULL}. -#' @param se_c A 2x2 numeric matrix giving the external control group -#' sum-of-squares matrix. Required when external control data are -#' used; otherwise set to \code{NULL}. -#' @param nMC A positive integer giving the number of Monte Carlo draws used -#' to estimate region probabilities. Default is \code{10000}. Required -#' when \code{CalcMethod = 'MC'}. May be set to \code{NULL} when -#' \code{CalcMethod = 'MM'} and \eqn{\nu_k > 4} (the MM method uses -#' \code{mvtnorm::pmvt} analytically); if \code{CalcMethod = 'MM'} but -#' \eqn{\nu_k \le 4} causes a fallback to MC, \code{nMC} must be a -#' positive integer. -#' @param CalcMethod A character string specifying the computation method. -#' Must be \code{'MC'} (Monte Carlo, default) or \code{'MM'} -#' (Moment-Matching via \code{mvtnorm::pmvt}). When -#' \code{CalcMethod = 'MM'} and \eqn{\nu_k \le 4}, a warning is issued -#' and the function falls back to \code{CalcMethod = 'MC'}. -#' @param error_if_Miss Logical. If \code{TRUE} (default), the function stops -#' with an error when positive Miss probability is obtained. If -#' \code{FALSE}, Miss probability is handled according to -#' \code{Gray_inc_Miss}. -#' @param Gray_inc_Miss Logical. If \code{TRUE}, Miss probability is included -#' in Gray probability. If \code{FALSE} (default), Miss probability is -#' reported as a separate column. Active only when -#' \code{error_if_Miss = FALSE}. -#' @param seed A single numeric value. Seed for reproducible random number -#' generation. -#' -#' @return A data frame of class \code{c("pbayesdecisionprob2cont", "data.frame")} -#' with columns for the scenario parameters and Go, NoGo, Gray -#' (and optionally Miss) probabilities. All input parameters are -#' attached as attributes. -#' -#' @details -#' The function follows the same structure as -#' \code{\link{pbayesdecisionprob1cont}}: -#' \enumerate{ -#' \item For each scenario \eqn{s}, \code{nsim} datasets are simulated by -#' generating treatment (and control) observations from -#' \eqn{N_2(\mu_k^{(s)}, \Sigma_k)}. To minimise overhead, raw -#' standardised residuals are generated \emph{once} (scenario- -#' invariant) and shifted by the scenario mean. -#' \item All \code{nsim} simulated sufficient statistics -#' \eqn{(\bar{y}_{1,i}, S_{1,i})} (and \eqn{(\bar{y}_{2,i}, S_{2,i})} -#' for controlled/external designs) are passed to -#' \code{\link{pbayespostpred2cont}} in a \emph{single vectorised -#' call}, returning an \eqn{nsim \times n_{\rm regions}} matrix of -#' region probabilities. -#' \item Go/NoGo/Miss probabilities are obtained as the column means of -#' indicator matrices derived from the region probability matrix. -#' } -#' -#' @examples -#' # Example 1: Controlled design, posterior probability, vague prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'posterior', design = 'controlled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 9L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 20L, n_c = 20L, m_t = NULL, m_c = NULL, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), -#' Sigma_c = Sigma, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 1L -#' ) -#' -#' # Example 2: Uncontrolled design, posterior probability, NIW prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'posterior', design = 'uncontrolled', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 9L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 20L, n_c = NULL, m_t = NULL, m_c = NULL, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), -#' Sigma_c = Sigma, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 3L -#' ) -#' -#' # Example 3: External design (control only), posterior probability, NIW prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -#' se_mat <- matrix(c(7.0, 1.2, 1.2, 1.8), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'posterior', design = 'external', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 9L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 20L, n_c = 20L, m_t = NULL, m_c = NULL, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), -#' Sigma_c = Sigma, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, -#' r = NULL, -#' ne_t = NULL, ne_c = 15L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(0.2, 0.1), se_t = NULL, se_c = se_mat, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 5L -#' ) -#' -#' # Example 4: Controlled design, predictive probability, NIW prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'predictive', design = 'controlled', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 4L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 20L, n_c = 20L, m_t = 60L, m_c = 60L, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), -#' Sigma_c = Sigma, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 4L -#' ) -#' -#' # Example 5: Uncontrolled design, predictive probability, vague prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'predictive', design = 'uncontrolled', -#' prior = 'vague', -#' GoRegions = 1L, NoGoRegions = 4L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 20L, n_c = NULL, m_t = 60L, m_c = 60L, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = NULL, -#' Sigma_c = NULL, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 8L -#' ) -#' -#' # Example 6: External design (control only), predictive probability, NIW prior -#' Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -#' L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -#' se_mat <- matrix(c(7.0, 1.2, 1.2, 1.8), 2, 2) -#' pbayesdecisionprob2cont( -#' nsim = 100L, prob = 'predictive', design = 'external', -#' prior = 'N-Inv-Wishart', -#' GoRegions = 1L, NoGoRegions = 4L, -#' gamma_go = 0.8, gamma_nogo = 0.8, -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 20L, n_c = 20L, m_t = 60L, m_c = 60L, -#' mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), -#' Sigma_t = Sigma, -#' mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), -#' Sigma_c = Sigma, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, -#' r = NULL, -#' ne_t = NULL, ne_c = 15L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(0.2, 0.1), se_t = NULL, se_c = se_mat, -#' nMC = 500L, CalcMethod = 'MC', -#' error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 9L -#' ) -#' -#' @importFrom stats rnorm -#' @export -pbayesdecisionprob2cont <- function(nsim, - prob, - design, - prior, - GoRegions, NoGoRegions, - gamma_go, gamma_nogo, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t, n_c = NULL, - m_t = NULL, m_c = NULL, - mu_t, Sigma_t, - mu_c = NULL, Sigma_c = NULL, - kappa0_t = NULL, nu0_t = NULL, - mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, - mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - nMC = NULL, - CalcMethod = 'MC', - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE, - seed) { - - # --------------------------------------------------------------------------- - # Section 1: Input validation - # --------------------------------------------------------------------------- - - if (!is.numeric(nsim) || length(nsim) != 1L || is.na(nsim) || - nsim != floor(nsim) || nsim < 1L) - stop("'nsim' must be a single positive integer") - nsim <- as.integer(nsim) - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) - stop("'prob' must be either 'posterior' or 'predictive'") - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c('vague', 'N-Inv-Wishart')) - stop("'prior' must be 'vague' or 'N-Inv-Wishart'") - - max_region <- if (prob == 'posterior') 9L else 4L - if (!is.numeric(GoRegions) || length(GoRegions) < 1L || - any(is.na(GoRegions)) || any(GoRegions != floor(GoRegions)) || - any(GoRegions < 1L) || any(GoRegions > max_region)) - stop(sprintf("'GoRegions' must be integer(s) in 1:%d", max_region)) - if (!is.numeric(NoGoRegions) || length(NoGoRegions) < 1L || - any(is.na(NoGoRegions)) || any(NoGoRegions != floor(NoGoRegions)) || - any(NoGoRegions < 1L) || any(NoGoRegions > max_region)) - stop(sprintf("'NoGoRegions' must be integer(s) in 1:%d", max_region)) - if (any(GoRegions %in% NoGoRegions)) - stop("'GoRegions' and 'NoGoRegions' must be disjoint") - - for (nm in c('gamma_go', 'gamma_nogo')) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val >= 1) - stop(paste0("'", nm, "' must be a single numeric value in (0, 1)")) - } - - if (prob == 'posterior') { - for (nm in c('theta_TV1', 'theta_MAV1', 'theta_TV2', 'theta_MAV2')) { - val <- get(nm) - if (is.null(val)) - stop(paste0("'", nm, "' must be non-NULL when prob = 'posterior'")) - if (!is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric value")) - } - if (theta_TV1 <= theta_MAV1) - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - if (theta_TV2 <= theta_MAV2) - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } else { - for (nm in c('theta_NULL1', 'theta_NULL2')) { - val <- get(nm) - if (is.null(val)) - stop(paste0("'", nm, "' must be non-NULL when prob = 'predictive'")) - if (!is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric value")) - } - if (is.null(m_t) || is.null(m_c)) - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - for (nm in c('m_t', 'm_c')) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) - stop("'n_t' must be a single positive integer") - n_t <- as.integer(n_t) - - if (design %in% c('controlled', 'external')) { - if (is.null(n_c)) - stop("'n_c' must be non-NULL when design is 'controlled' or 'external'") - if (!is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) - stop("'n_c' must be a single positive integer") - n_c <- as.integer(n_c) - } - - # Coerce mu_t to matrix if needed - if (is.vector(mu_t) && length(mu_t) == 2L) mu_t <- matrix(mu_t, nrow = 1L) - if (!is.matrix(mu_t) || ncol(mu_t) != 2L) - stop("'mu_t' must be a matrix with 2 columns (or a length-2 vector)") - - n_scen_t <- nrow(mu_t) - - if (design == 'uncontrolled') { - # mu_c is not used in simulation; n_scen is determined by mu_t alone - n_scen <- n_scen_t - } else { - if (is.vector(mu_c) && length(mu_c) == 2L) mu_c <- matrix(mu_c, nrow = 1L) - if (!is.matrix(mu_c) || ncol(mu_c) != 2L) - stop("'mu_c' must be a matrix with 2 columns (or a length-2 vector)") - n_scen_c <- nrow(mu_c) - if (n_scen_c != n_scen_t) - stop("'mu_t' and 'mu_c' must have the same number of rows") - n_scen <- n_scen_t - } - - if (!is.matrix(Sigma_t) || nrow(Sigma_t) != 2L || ncol(Sigma_t) != 2L) - stop("'Sigma_t' must be a 2x2 numeric matrix") - if (design != 'uncontrolled') { - if (!is.matrix(Sigma_c) || nrow(Sigma_c) != 2L || ncol(Sigma_c) != 2L) - stop("'Sigma_c' must be a 2x2 numeric matrix") - } - - if (prior == 'N-Inv-Wishart') { - for (nm in c('kappa0_t', 'nu0_t')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val <= 0) - stop(paste0("'", nm, "' must be a single positive numeric for NIW prior")) - } - if (is.null(mu0_t) || !is.numeric(mu0_t) || length(mu0_t) != 2L) - stop("'mu0_t' must be a length-2 numeric vector for NIW prior") - if (is.null(Lambda0_t) || !is.matrix(Lambda0_t) || nrow(Lambda0_t) != 2L) - stop("'Lambda0_t' must be a 2x2 numeric matrix for NIW prior") - if (design %in% c('controlled', 'external')) { - for (nm in c('kappa0_c', 'nu0_c')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val <= 0) - stop(paste0("'", nm, "' must be a single positive numeric for NIW prior")) - } - if (is.null(mu0_c) || !is.numeric(mu0_c) || length(mu0_c) != 2L) - stop("'mu0_c' must be a length-2 numeric vector for NIW prior") - if (is.null(Lambda0_c) || !is.matrix(Lambda0_c) || nrow(Lambda0_c) != 2L) - stop("'Lambda0_c' must be a 2x2 numeric matrix for NIW prior") - } - } - - if (design == 'uncontrolled') { - if (is.null(r) || !is.numeric(r) || length(r) != 1L || is.na(r) || r <= 0) - stop("'r' must be a single positive numeric when design = 'uncontrolled'") - if (is.null(mu0_c) || !is.numeric(mu0_c) || length(mu0_c) != 2L) - stop("'mu0_c' must be a length-2 numeric vector when design = 'uncontrolled'") - } - - if (design == 'external') { - has_ext_t <- !is.null(ne_t) && !is.null(alpha0e_t) && - !is.null(bar_ye_t) && !is.null(se_t) - has_ext_c <- !is.null(ne_c) && !is.null(alpha0e_c) && - !is.null(bar_ye_c) && !is.null(se_c) - if (!has_ext_t && !has_ext_c) - stop(paste0("For design = 'external', at least one complete set of ", - "external data must be provided")) - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c('MC', 'MM')) - stop("'CalcMethod' must be either 'MC' or 'MM'") - - # nMC validation: required for CalcMethod = 'MC', optional for CalcMethod = 'MM' - if (CalcMethod == 'MC') { - if (is.null(nMC)) - stop("'nMC' must be non-NULL when CalcMethod = 'MC'") - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) - stop("'nMC' must be a single positive integer") - nMC <- as.integer(nMC) - } else { - # CalcMethod == 'MM': nMC may be NULL or a positive integer - if (!is.null(nMC)) { - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) - stop("'nMC' must be a single positive integer or NULL") - nMC <- as.integer(nMC) - } - } - - if (!is.logical(error_if_Miss) || length(error_if_Miss) != 1L || - is.na(error_if_Miss)) - stop("'error_if_Miss' must be a single logical value") - - if (!is.logical(Gray_inc_Miss) || length(Gray_inc_Miss) != 1L || - is.na(Gray_inc_Miss)) - stop("'Gray_inc_Miss' must be a single logical value") - - # --------------------------------------------------------------------------- - # Section 2: Pre-generate simulation data (scenario-invariant) - # - # Raw standardised residuals are generated once. - # For group k, the sample mean for scenario s and replicate i is: - # ybar_k[s, i, ] = (Z_k_colsums[i, ] / n_k) + mu_k[s, ] - # The scatter matrix S_k[i] depends only on Z_k (not on mu_k[s,]). - # --------------------------------------------------------------------------- - - set.seed(seed) - - R_Sigma_t <- chol(Sigma_t) - Z_t_raw <- matrix(rnorm(nsim * n_t * 2L), - nrow = nsim * n_t, ncol = 2L) %*% R_Sigma_t - block_t <- rep(seq_len(nsim), each = n_t) - - Z_t_colsums <- apply(Z_t_raw, 2L, function(col) tapply(col, block_t, sum)) - Z_t_colmeans_rep <- Z_t_colsums[block_t, ] / n_t - Z_t_centered <- Z_t_raw - Z_t_colmeans_rep - - # S_t stored as 3 unique elements per replicate (symmetric 2x2) - S_t_11 <- tapply(Z_t_centered[, 1L] ^ 2, block_t, sum) - S_t_12 <- tapply(Z_t_centered[, 1L] * Z_t_centered[, 2L], block_t, sum) - S_t_22 <- tapply(Z_t_centered[, 2L] ^ 2, block_t, sum) - - if (design %in% c('controlled', 'external')) { - R_Sigma_c <- chol(Sigma_c) - Z_c_raw <- matrix(rnorm(nsim * n_c * 2L), - nrow = nsim * n_c, ncol = 2L) %*% R_Sigma_c - block_c <- rep(seq_len(nsim), each = n_c) - - Z_c_colsums <- apply(Z_c_raw, 2L, function(col) tapply(col, block_c, sum)) - Z_c_colmeans_rep <- Z_c_colsums[block_c, ] / n_c - Z_c_centered <- Z_c_raw - Z_c_colmeans_rep - - S_c_11 <- tapply(Z_c_centered[, 1L] ^ 2, block_c, sum) - S_c_12 <- tapply(Z_c_centered[, 1L] * Z_c_centered[, 2L], block_c, sum) - S_c_22 <- tapply(Z_c_centered[, 2L] ^ 2, block_c, sum) - } - - # --------------------------------------------------------------------------- - # Section 3: Scenario loop - # - # For each scenario s: - # 1. Construct nsim sufficient statistics by shifting the pre-generated - # residuals by the scenario mean. - # 2. Call pbayespostpred2cont once in vectorised mode (ybar_t as matrix, - # S_t as list) to obtain an nsim x n_regions matrix of Pr_R values. - # 3. Compute PrGo and PrNoGo for each replicate and classify. - # --------------------------------------------------------------------------- - - result_mat <- matrix(0, nrow = n_scen, ncol = 3L) - - for (s in seq_len(n_scen)) { - - # Shift residual column sums by scenario mean (vectorised over nsim) - ybar_t_sim <- sweep(Z_t_colsums / n_t, 2L, mu_t[s, ], '+') - # ybar_t_sim: nsim x 2 matrix - - # Build S_t list for this scenario (scenario-invariant values) - S_t_list <- vector('list', nsim) - for (i in seq_len(nsim)) { - S_t_list[[i]] <- matrix(c(S_t_11[i], S_t_12[i], S_t_12[i], S_t_22[i]), - nrow = 2L, ncol = 2L) - } - - if (design %in% c('controlled', 'external')) { - ybar_c_sim <- sweep(Z_c_colsums / n_c, 2L, mu_c[s, ], '+') - S_c_list <- vector('list', nsim) - for (i in seq_len(nsim)) { - S_c_list[[i]] <- matrix(c(S_c_11[i], S_c_12[i], S_c_12[i], S_c_22[i]), - nrow = 2L, ncol = 2L) - } - } else { - ybar_c_sim <- NULL - S_c_list <- NULL - } - - # Vectorised call: returns nsim x n_regions matrix - Pr_R_mat <- pbayespostpred2cont( - prob = prob, - design = design, - prior = prior, - theta_TV1 = theta_TV1, theta_MAV1 = theta_MAV1, - theta_TV2 = theta_TV2, theta_MAV2 = theta_MAV2, - theta_NULL1 = theta_NULL1, theta_NULL2 = theta_NULL2, - n_t = n_t, n_c = n_c, - ybar_t = ybar_t_sim, S_t = S_t_list, - ybar_c = ybar_c_sim, S_c = S_c_list, - m_t = m_t, m_c = m_c, - kappa0_t = kappa0_t, nu0_t = nu0_t, - mu0_t = mu0_t, Lambda0_t = Lambda0_t, - kappa0_c = kappa0_c, nu0_c = nu0_c, - mu0_c = mu0_c, Lambda0_c = Lambda0_c, - r = r, - ne_t = ne_t, ne_c = ne_c, - alpha0e_t = alpha0e_t, alpha0e_c = alpha0e_c, - bar_ye_t = bar_ye_t, bar_ye_c = bar_ye_c, - se_t = se_t, se_c = se_c, - nMC = nMC, - CalcMethod = CalcMethod - ) - # Pr_R_mat: nsim x n_regions (column names R1...R9 or R1...R4) - - # Go/NoGo probability per replicate - PrGo_vec <- rowSums(Pr_R_mat[, GoRegions, drop = FALSE]) - PrNoGo_vec <- rowSums(Pr_R_mat[, NoGoRegions, drop = FALSE]) - - # --- Decision indicators (Go, NoGo, Miss are mutually exclusive; Gray is the complement) --- - ind_Go <- (PrGo_vec >= gamma_go) & (PrNoGo_vec < gamma_nogo) - ind_NoGo <- (PrGo_vec < gamma_go) & (PrNoGo_vec >= gamma_nogo) - ind_Miss <- (PrGo_vec >= gamma_go) & (PrNoGo_vec >= gamma_nogo) - - result_mat[s, 1L] <- mean(ind_Go) - result_mat[s, 2L] <- mean(ind_NoGo) - result_mat[s, 3L] <- mean(ind_Miss) - } - - # --------------------------------------------------------------------------- - # Section 4: Assemble output - # --------------------------------------------------------------------------- - - result_mat[result_mat < .Machine$double.eps ^ 0.25] <- 0 - - if (error_if_Miss && any(result_mat[, 3L] > 0)) - stop("Positive Miss probability detected. Please re-consider the chosen thresholds.") - - GrayProb <- if (Gray_inc_Miss) { - 1 - result_mat[, 1L] - result_mat[, 2L] - } else { - 1 - rowSums(result_mat) - } - - if (design == 'uncontrolled') { - results <- data.frame( - mu_t1 = mu_t[, 1L], - mu_t2 = mu_t[, 2L], - Go = result_mat[, 1L], - Gray = GrayProb, - NoGo = result_mat[, 2L] - ) - } else { - results <- data.frame( - mu_t1 = mu_t[, 1L], - mu_t2 = mu_t[, 2L], - mu_c1 = mu_c[, 1L], - mu_c2 = mu_c[, 2L], - Go = result_mat[, 1L], - Gray = GrayProb, - NoGo = result_mat[, 2L] - ) - } - - if (!error_if_Miss && !Gray_inc_Miss) - results$Miss <- result_mat[, 3L] - - # Suppress floating-point noise in output probability columns - prob_cols <- c('Go', 'Gray', 'NoGo', 'Miss') - prob_cols <- prob_cols[prob_cols %in% names(results)] - results[prob_cols] <- lapply(results[prob_cols], function(col) { - ifelse(col < .Machine$double.eps ^ 0.25, 0, col) - }) - - # Attach metadata as attributes - attr(results, 'prob') <- prob - attr(results, 'design') <- design - attr(results, 'prior') <- prior - attr(results, 'nsim') <- nsim - attr(results, 'nMC') <- nMC - attr(results, 'CalcMethod') <- CalcMethod - attr(results, 'GoRegions') <- GoRegions - attr(results, 'NoGoRegions') <- NoGoRegions - attr(results, 'gamma_go') <- gamma_go - attr(results, 'gamma_nogo') <- gamma_nogo - attr(results, 'theta_TV1') <- theta_TV1 - attr(results, 'theta_MAV1') <- theta_MAV1 - attr(results, 'theta_TV2') <- theta_TV2 - attr(results, 'theta_MAV2') <- theta_MAV2 - attr(results, 'theta_NULL1') <- theta_NULL1 - attr(results, 'theta_NULL2') <- theta_NULL2 - attr(results, 'n_t') <- n_t - attr(results, 'n_c') <- n_c - attr(results, 'm_t') <- m_t - attr(results, 'm_c') <- m_c - attr(results, 'Sigma_t') <- Sigma_t - attr(results, 'Sigma_c') <- Sigma_c - attr(results, 'kappa0_t') <- kappa0_t - attr(results, 'nu0_t') <- nu0_t - attr(results, 'mu0_t') <- mu0_t - attr(results, 'Lambda0_t') <- Lambda0_t - attr(results, 'kappa0_c') <- kappa0_c - attr(results, 'nu0_c') <- nu0_c - attr(results, 'mu0_c') <- mu0_c - attr(results, 'Lambda0_c') <- Lambda0_c - attr(results, 'r') <- r - attr(results, 'ne_t') <- ne_t - attr(results, 'ne_c') <- ne_c - attr(results, 'alpha0e_t') <- alpha0e_t - attr(results, 'alpha0e_c') <- alpha0e_c - attr(results, 'bar_ye_t') <- bar_ye_t - attr(results, 'bar_ye_c') <- bar_ye_c - attr(results, 'se_t') <- se_t - attr(results, 'se_c') <- se_c - attr(results, 'error_if_Miss') <- error_if_Miss - attr(results, 'Gray_inc_Miss') <- Gray_inc_Miss - attr(results, 'seed') <- seed - - class(results) <- c('pbayesdecisionprob2cont', 'data.frame') - - return(results) -} - -#' Print Method for pbayesdecisionprob2cont Objects -#' -#' Displays a formatted summary of Go/NoGo/Gray decision probabilities for -#' two-continuous-endpoint results returned by -#' \code{\link{pbayesdecisionprob2cont}}. -#' -#' @param x An object of class \code{pbayesdecisionprob2cont}. -#' @param digits A positive integer specifying the number of decimal places -#' for probability values. Default is 4. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns \code{x}. -#' -#' @export -print.pbayesdecisionprob2cont <- function(x, digits = 4, ...) { - - # Helper: format a scalar/vector/NULL as string - fmt <- function(v) { - if (is.null(v)) return("NULL") - if (length(v) > 1) return(paste0("(", paste(v, collapse = ", "), ")")) - as.character(v) - } - - # Helper: format a 2x2 matrix as "[r1c1, r1c2; r2c1, r2c2]" - fmt_mat <- function(m) { - if (is.null(m)) return("NULL") - sprintf("[%s, %s; %s, %s]", m[1,1], m[1,2], m[2,1], m[2,2]) - } - - # Extract metadata from attributes - prob <- attr(x, "prob") - design <- attr(x, "design") - prior <- attr(x, "prior") - nsim <- attr(x, "nsim") - nMC <- attr(x, "nMC") - CalcMethod <- attr(x, "CalcMethod") - GoRegions <- attr(x, "GoRegions") - NoGoRegions <- attr(x, "NoGoRegions") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - theta_TV1 <- attr(x, "theta_TV1") - theta_MAV1 <- attr(x, "theta_MAV1") - theta_TV2 <- attr(x, "theta_TV2") - theta_MAV2 <- attr(x, "theta_MAV2") - theta_NULL1 <- attr(x, "theta_NULL1") - theta_NULL2 <- attr(x, "theta_NULL2") - n_t <- attr(x, "n_t") - n_c <- attr(x, "n_c") - m_t <- attr(x, "m_t") - m_c <- attr(x, "m_c") - Sigma_t <- attr(x, "Sigma_t") - Sigma_c <- attr(x, "Sigma_c") - kappa0_t <- attr(x, "kappa0_t") - nu0_t <- attr(x, "nu0_t") - mu0_t <- attr(x, "mu0_t") - Lambda0_t <- attr(x, "Lambda0_t") - kappa0_c <- attr(x, "kappa0_c") - nu0_c <- attr(x, "nu0_c") - mu0_c <- attr(x, "mu0_c") - Lambda0_c <- attr(x, "Lambda0_c") - r <- attr(x, "r") - ne_t <- attr(x, "ne_t") - ne_c <- attr(x, "ne_c") - alpha0e_t <- attr(x, "alpha0e_t") - alpha0e_c <- attr(x, "alpha0e_c") - bar_ye_t <- attr(x, "bar_ye_t") - bar_ye_c <- attr(x, "bar_ye_c") - se_t <- attr(x, "se_t") - se_c <- attr(x, "se_c") - error_if_Miss <- attr(x, "error_if_Miss") - Gray_inc_Miss <- attr(x, "Gray_inc_Miss") - seed <- attr(x, "seed") - - # Build info lines with fixed label width (lw) for consistent alignment - lw <- 17L # label field width - pad <- " " # left margin - - lines <- character(0) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Probability type", prob)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Design", design)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Prior", prior)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Method", fmt(CalcMethod))) - lines <- c(lines, sprintf("%s%-*s: nsim = %s", pad, lw, "Simulations", fmt(nsim))) - lines <- c(lines, sprintf("%s%-*s: nMC = %s", pad, lw, "MC draws", fmt(nMC))) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Seed", fmt(seed))) - - # Threshold(s): split posterior across two lines to avoid overflow - if (prob == "posterior") { - lines <- c(lines, sprintf("%s%-*s: TV1 = %s, MAV1 = %s", - pad, lw, "Threshold(s)", - fmt(theta_TV1), fmt(theta_MAV1))) - lines <- c(lines, sprintf("%s%-*s TV2 = %s, MAV2 = %s", - pad, lw, "", - fmt(theta_TV2), fmt(theta_MAV2))) - } else { - lines <- c(lines, sprintf("%s%-*s: NULL1 = %s, NULL2 = %s", - pad, lw, "Threshold(s)", - fmt(theta_NULL1), fmt(theta_NULL2))) - } - - lines <- c(lines, sprintf("%s%-*s: gamma_go = %s", - pad, lw, "Go threshold", fmt(gamma_go))) - lines <- c(lines, sprintf("%s%-*s: gamma_nogo = %s", - pad, lw, "NoGo threshold", fmt(gamma_nogo))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "Go regions", - paste(GoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "NoGo regions", - paste(NoGoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: n_t = %s, n_c = %s", - pad, lw, "Sample size", fmt(n_t), fmt(n_c))) - lines <- c(lines, sprintf("%s%-*s: Sigma_t = %s", - pad, lw, "True cov (treat.)", fmt_mat(Sigma_t))) - if (design != "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: Sigma_c = %s", - pad, lw, "True cov (cont.) ", fmt_mat(Sigma_c))) - } - - # N-Inv-Wishart prior: treatment and control each split across two lines - if (prior == "N-Inv-Wishart") { - lines <- c(lines, sprintf( - "%s%-*s: kappa0_t = %s, nu0_t = %s, mu0_t = %s", - pad, lw, "Prior (treatment)", fmt(kappa0_t), fmt(nu0_t), fmt(mu0_t))) - lines <- c(lines, sprintf("%s%-*s Lambda0_t = %s", - pad, lw, "", fmt_mat(Lambda0_t))) - if (design %in% c("controlled", "external")) { - lines <- c(lines, sprintf( - "%s%-*s: kappa0_c = %s, nu0_c = %s, mu0_c = %s", - pad, lw, "Prior (control) ", fmt(kappa0_c), fmt(nu0_c), fmt(mu0_c))) - lines <- c(lines, sprintf("%s%-*s Lambda0_c = %s", - pad, lw, "", fmt_mat(Lambda0_c))) - } - } - - if (design == "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: mu0_c = %s, r = %s", - pad, lw, "Hyp. control", fmt(mu0_c), fmt(r))) - } - if (prob == "predictive") { - lines <- c(lines, sprintf("%s%-*s: m_t = %s, m_c = %s", - pad, lw, "Future trial", fmt(m_t), fmt(m_c))) - } - if (design == "external") { - # External data: treatment and control on separate lines - lines <- c(lines, sprintf( - "%s%-*s: ne_t = %s, alpha0e_t = %s", - pad, lw, "External (treat.)", fmt(ne_t), fmt(alpha0e_t))) - if (!is.null(bar_ye_t)) { - lines <- c(lines, sprintf("%s%-*s bar_ye_t = %s, se_t = %s", - pad, lw, "", fmt(bar_ye_t), fmt(se_t))) - } - lines <- c(lines, sprintf( - "%s%-*s: ne_c = %s, alpha0e_c = %s", - pad, lw, "External (cont.) ", fmt(ne_c), fmt(alpha0e_c))) - if (!is.null(bar_ye_c)) { - lines <- c(lines, sprintf("%s%-*s bar_ye_c = %s, se_c = %s", - pad, lw, "", fmt(bar_ye_c), fmt(se_c))) - } - } - lines <- c(lines, sprintf("%s%-*s: error_if_Miss = %s, Gray_inc_Miss = %s", - pad, lw, "Miss handling", - fmt(error_if_Miss), fmt(Gray_inc_Miss))) - - # Determine separator width dynamically from the longest line - title <- "Go/NoGo/Gray Decision Probabilities (Two Continuous Endpoints)" - sep_width <- max(nchar(title), max(nchar(lines))) - sep <- strrep("-", sep_width) - - # Print header block - cat(title, "\n") - cat(sep, "\n") - for (ln in lines) cat(ln, "\n") - cat(sep, "\n") - - # Format probability columns only (not scenario columns) - scenario_cols <- c("mu_t1", "mu_t2", "mu_c1", "mu_c2") - prob_cols <- names(x)[!names(x) %in% scenario_cols] - - x_print <- x - x_print[prob_cols] <- lapply(x[prob_cols], function(col) { - formatC(col, digits = digits, format = "f") - }) - - # Print table without row names (explicit call to avoid recursion) - print.data.frame(x_print, row.names = FALSE, quote = FALSE) - cat(sep, "\n") - - invisible(x) -} diff --git a/R/pbayespostpred1bin.R b/R/pbayespostpred1bin.R deleted file mode 100644 index 0b5ae14..0000000 --- a/R/pbayespostpred1bin.R +++ /dev/null @@ -1,326 +0,0 @@ -#' Bayesian Posterior or Posterior Predictive Probability for a Single -#' Binary Endpoint -#' -#' Computes the Bayesian posterior probability or posterior predictive -#' probability for binary-outcome clinical trials under a beta-binomial -#' conjugate model. The function supports controlled, uncontrolled, and -#' external designs, with optional incorporation of external data through -#' power priors. Vector inputs for \code{y_t} and \code{y_c} are supported -#' for efficient batch processing (e.g., across all possible trial outcomes -#' in \code{\link{pbayesdecisionprob1bin}}). -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param theta0 A numeric scalar in \code{(-1, 1)} giving the threshold for the -#' treatment effect (difference in response rates). -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. For \code{design = 'uncontrolled'}, -#' this is the hypothetical control sample size (required for -#' consistency with other designs). -#' @param y_t A non-negative integer or integer vector giving the observed -#' number of responders in the treatment group (must satisfy -#' \code{0 <= y_t <= n_t}). -#' @param y_c A non-negative integer or integer vector giving the number of -#' responders in the control group (must satisfy -#' \code{0 <= y_c <= n_c}). Set to \code{NULL} for -#' \code{design = 'uncontrolled'} and use \code{z} instead. When -#' provided as a vector, must have the same length as \code{y_t}. -#' @param a_t A positive numeric scalar giving the first shape parameter -#' (alpha) of the prior Beta distribution for the treatment group. -#' @param a_c A positive numeric scalar giving the first shape parameter -#' (alpha) of the prior Beta distribution for the control group. -#' @param b_t A positive numeric scalar giving the second shape parameter -#' (beta) of the prior Beta distribution for the treatment group. -#' @param b_c A positive numeric scalar giving the second shape parameter -#' (beta) of the prior Beta distribution for the control group. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param z A non-negative integer giving the hypothetical number of responders -#' in the control group. Required when \code{design = 'uncontrolled'}; -#' otherwise set to \code{NULL}. When used, \code{y_c} should be -#' \code{NULL}. -#' @param ne_t A positive integer giving the number of patients in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'} and external treatment data are -#' available; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the number of patients in the -#' control group of the external data set. Required when -#' \code{design = 'external'} and external control data are available; -#' otherwise set to \code{NULL}. -#' @param ye_t A non-negative integer giving the number of responders in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'}; otherwise set to \code{NULL}. -#' @param ye_c A non-negative integer giving the number of responders in the -#' control group of the external data set. Required when -#' \code{design = 'external'}; otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external treatment data. Required when external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external control data. Required when external -#' control data are used; otherwise set to \code{NULL}. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(\mathrm{effect} \le \theta_0)}, otherwise -#' \eqn{P(\mathrm{effect} > \theta_0)}. -#' -#' @return A numeric scalar or vector in \code{[0, 1]}. When \code{y_t} and -#' \code{y_c} are vectors of length \eqn{n}, a vector of length -#' \eqn{n} is returned. -#' -#' @details -#' Posterior shape parameters are computed from the beta-binomial conjugate -#' model: -#' \itemize{ -#' \item Prior: \eqn{\pi_j \sim \mathrm{Beta}(a_j, b_j)}. -#' \item Posterior: -#' \eqn{\pi_j \mid y_j \sim \mathrm{Beta}(a_j + y_j, b_j + n_j - y_j)}. -#' } -#' -#' For \code{design = 'external'}, external data are incorporated through -#' the power prior, which inflates the prior by the weighted external -#' sufficient statistics: -#' \deqn{(\alpha_j^*, \beta_j^*) = (a_j + ae_j \cdot ye_j, b_j + ae_j \cdot -#' (ne_j - ye_j)).} -#' -#' For \code{design = 'uncontrolled'}, the hypothetical control value -#' \code{z} is used in place of \code{y_c}, and \code{n_c} acts as the -#' hypothetical control sample size. -#' -#' The final probability is obtained by calling \code{\link{pbetadiff}} for -#' \code{prob = 'posterior'} or \code{\link{pbetabinomdiff}} for -#' \code{prob = 'predictive'}, applied element-wise via \code{mapply}. -#' -#' @examples -#' # Example 1: Controlled design - posterior probability -#' pbayespostpred1bin( -#' prob = 'posterior', design = 'controlled', theta0 = 0.15, -#' n_t = 12, n_c = 15, y_t = 7, y_c = 5, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = NULL, m_c = NULL, z = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -#' ) -#' -#' # Example 2: Uncontrolled design - posterior probability -#' pbayespostpred1bin( -#' prob = 'posterior', design = 'uncontrolled', theta0 = 0.20, -#' n_t = 20, n_c = 20, y_t = 12, y_c = NULL, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = NULL, m_c = NULL, z = 3, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -#' ) -#' -#' # Example 3: External design - posterior probability -#' pbayespostpred1bin( -#' prob = 'posterior', design = 'external', theta0 = 0.15, -#' n_t = 12, n_c = 15, y_t = 7, y_c = 9, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = NULL, m_c = NULL, z = NULL, -#' ne_t = 12, ne_c = 12, ye_t = 6, ye_c = 6, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' lower.tail = FALSE -#' ) -#' -#' # Example 4: Controlled design - posterior predictive probability -#' pbayespostpred1bin( -#' prob = 'predictive', design = 'controlled', theta0 = 0.10, -#' n_t = 12, n_c = 15, y_t = 7, y_c = 5, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = 30, m_c = 30, z = NULL, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -#' ) -#' -#' # Example 5: Uncontrolled design - posterior predictive probability -#' pbayespostpred1bin( -#' prob = 'predictive', design = 'uncontrolled', theta0 = 0.20, -#' n_t = 20, n_c = 20, y_t = 12, y_c = NULL, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = 30, m_c = 30, z = 3, -#' ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -#' ) -#' -#' # Example 6: External design - posterior predictive probability -#' pbayespostpred1bin( -#' prob = 'predictive', design = 'external', theta0 = 0.15, -#' n_t = 12, n_c = 15, y_t = 7, y_c = 9, -#' a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, -#' m_t = 30, m_c = 30, z = NULL, -#' ne_t = 12, ne_c = 12, ye_t = 6, ye_c = 6, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' lower.tail = FALSE -#' ) -#' -#' @importFrom stats integrate -#' @export -pbayespostpred1bin <- function(prob = 'posterior', design = 'controlled', theta0, - n_t, n_c, y_t, y_c = NULL, a_t, a_c, b_t, b_c, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, - ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = TRUE) { - - # --- Input validation --- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.numeric(theta0) || length(theta0) != 1L || is.na(theta0) || - theta0 <= -1 || theta0 >= 1) { - stop("'theta0' must be a single numeric value in (-1, 1)") - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) { - stop("'n_t' must be a single positive integer") - } - - if (!is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) { - stop("'n_c' must be a single positive integer") - } - - for (nm in c("a_t", "a_c", "b_t", "b_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) { - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # Validate prob-specific parameters - if (prob == 'predictive') { - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - for (nm in c("m_t", "m_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - } - - # Validate design-specific parameters - if (design == 'uncontrolled') { - if (is.null(z)) { - stop("'z' must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(z) || length(z) != 1L || is.na(z) || - z != floor(z) || z < 0 || z > n_c) { - stop("'z' must be a single non-negative integer not exceeding n_c") - } - } - - if (design == 'external') { - for (nm in c("ne_t", "ne_c", "ye_t", "ye_c", "alpha0e_t", "alpha0e_c")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when design = 'external'")) - } - } - for (nm in c("ne_t", "ne_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - for (nm in c("ye_t", "ye_c")) { - val <- get(nm) - ne_val <- get(sub("ye", "ne", nm)) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0 || val > ne_val) { - stop(paste0("'", nm, "' must be a single non-negative integer not exceeding the corresponding ne")) - } - } - for (nm in c("alpha0e_t", "alpha0e_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val > 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1]")) - } - } - } - - # --- Coerce y_t to numeric vector --- - y_t <- as.numeric(y_t) - - if (any(is.na(y_t)) || any(y_t < 0) || any(y_t > n_t) || - any(y_t != floor(y_t))) { - stop("All elements of 'y_t' must be non-negative integers not exceeding n_t") - } - - # --- Resolve y_c: fixed at z for uncontrolled design --- - if (is.null(y_c)) { - if (design == 'uncontrolled') { - y_c <- rep(z, length(y_t)) - } else { - stop("'y_c' must be provided for controlled and external designs") - } - } - y_c <- as.numeric(y_c) - - if (any(is.na(y_c)) || any(y_c < 0) || any(y_c > n_c) || - any(y_c != floor(y_c))) { - stop("All elements of 'y_c' must be non-negative integers not exceeding n_c") - } - - if (length(y_t) != length(y_c)) { - stop("'y_t' and 'y_c' must have the same length") - } - - # --- Compute posterior shape parameters (vectorised) --- - if (design == 'external') { - # Power prior: augment the prior with weighted external sufficient statistics - s_t1 <- y_t + a_t + alpha0e_t * ye_t - s_t2 <- n_t - y_t + b_t + alpha0e_t * (ne_t - ye_t) - s_c1 <- y_c + a_c + alpha0e_c * ye_c - s_c2 <- n_c - y_c + b_c + alpha0e_c * (ne_c - ye_c) - } else { - # Controlled or uncontrolled (y_c already set to z for uncontrolled) - s_t1 <- y_t + a_t - s_t2 <- n_t - y_t + b_t - s_c1 <- y_c + a_c - s_c2 <- n_c - y_c + b_c - } - - # --- Compute probabilities element-wise via mapply --- - if (prob == 'posterior') { - # P(pi_t - pi_c > theta0 | data) using Beta posterior distributions - results <- mapply( - pbetadiff, - alpha_t = s_t1, alpha_c = s_c1, beta_t = s_t2, beta_c = s_c2, - MoreArgs = list(q = theta0, lower.tail = lower.tail) - ) - } else { - # P(future trial success | data) using Beta-Binomial predictive distributions - results <- mapply( - pbetabinomdiff, - alpha_t = s_t1, alpha_c = s_c1, beta_t = s_t2, beta_c = s_c2, - MoreArgs = list(q = theta0, m_t = m_t, m_c = m_c, lower.tail = lower.tail) - ) - } - - return(results) -} diff --git a/R/pbayespostpred1cont.R b/R/pbayespostpred1cont.R deleted file mode 100644 index c47b538..0000000 --- a/R/pbayespostpred1cont.R +++ /dev/null @@ -1,653 +0,0 @@ -#' Bayesian Posterior or Posterior Predictive Probability for a Single -#' Continuous Endpoint -#' -#' Computes the Bayesian posterior probability or posterior predictive -#' probability for continuous-outcome clinical trials under a -#' Normal-Inverse-Chi-squared (or vague Jeffreys) conjugate model. The -#' function supports controlled, uncontrolled, and external designs, with -#' optional incorporation of external data through power priors. Vector -#' inputs for \code{bar_y_t}, \code{s_t}, \code{bar_y_c}, and \code{s_c} -#' are supported for efficient batch processing (e.g., across simulation -#' replicates in \code{\link{pbayesdecisionprob1cont}}). -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param prior A character string specifying the prior type. -#' Must be \code{'vague'} (Jeffreys) or \code{'N-Inv-Chisq'} -#' (Normal-Inverse-Chi-squared conjugate). -#' @param CalcMethod A character string specifying the calculation method. -#' Must be \code{'NI'} (numerical integration), \code{'MC'} -#' (Monte Carlo), or \code{'MM'} (Moment-Matching approximation). -#' For large \code{nsim} or multi-scenario use, \code{'MM'} is -#' strongly recommended; see Details. -#' @param theta0 A numeric scalar giving the threshold for the treatment -#' effect (difference in means). -#' @param nMC A positive integer giving the number of Monte Carlo draws. -#' Required when \code{CalcMethod = 'MC'}; otherwise \code{NULL}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. Required for -#' \code{design = 'controlled'} or \code{'external'}; set to -#' \code{NULL} for \code{design = 'uncontrolled'}. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param kappa0_t A positive numeric scalar giving the prior precision -#' parameter for the treatment group. Required when -#' \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -#' @param kappa0_c A positive numeric scalar giving the prior precision -#' parameter for the control group. Required when -#' \code{prior = 'N-Inv-Chisq'} and \code{design = 'controlled'}; -#' otherwise \code{NULL}. -#' @param nu0_t A positive numeric scalar giving the prior degrees of freedom -#' for the treatment group. Required when \code{prior = 'N-Inv-Chisq'}; -#' otherwise \code{NULL}. -#' @param nu0_c A positive numeric scalar giving the prior degrees of freedom -#' for the control group. Required when \code{prior = 'N-Inv-Chisq'} -#' and \code{design = 'controlled'}; otherwise \code{NULL}. -#' @param mu0_t A numeric scalar giving the prior mean for the treatment -#' group. Required when \code{prior = 'N-Inv-Chisq'}; otherwise -#' \code{NULL}. -#' @param mu0_c A numeric scalar giving the prior mean for the control group -#' (\code{design = 'controlled'} with \code{prior = 'N-Inv-Chisq'}) -#' or the hypothetical control mean (\code{design = 'uncontrolled'}). -#' Required for uncontrolled design; otherwise \code{NULL}. -#' @param sigma0_t A positive numeric scalar giving the prior scale for the -#' treatment group. Required when \code{prior = 'N-Inv-Chisq'}; -#' otherwise \code{NULL}. -#' @param sigma0_c A positive numeric scalar giving the prior scale for the -#' control group. Required when \code{prior = 'N-Inv-Chisq'} and -#' \code{design = 'controlled'}; otherwise \code{NULL}. -#' @param bar_y_t A numeric scalar or vector giving the sample mean for the -#' treatment group. When a vector of length \code{nsim} is supplied, -#' all posterior parameters are computed simultaneously for all -#' replicates. -#' @param bar_y_c A numeric scalar or vector giving the sample mean for the -#' control group. Required for \code{design = 'controlled'} or -#' \code{'external'}; set to \code{NULL} for uncontrolled design. -#' @param s_t A positive numeric scalar or vector giving the sample standard -#' deviation for the treatment group. -#' @param s_c A positive numeric scalar or vector giving the sample standard -#' deviation for the control group. Required for -#' \code{design = 'controlled'} or \code{'external'}; otherwise -#' \code{NULL}. -#' @param r A positive numeric scalar giving the variance scaling factor for -#' the hypothetical control. Required for \code{design = 'uncontrolled'}; -#' otherwise \code{NULL}. The hypothetical control scale is -#' \eqn{\mathrm{sd.control} = \sqrt{r} \cdot \mathrm{sd.treatment}}. -#' @param ne_t A positive integer giving the number of patients in the -#' treatment group of the external data set. Required when -#' \code{design = 'external'} and external treatment data are -#' available; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the number of patients in the -#' control group of the external data set. Required when -#' \code{design = 'external'} and external control data are available; -#' otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external treatment data. Required when external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external control data. Required when external -#' control data are used; otherwise set to \code{NULL}. -#' @param bar_ye_t A numeric scalar giving the external treatment group -#' sample mean. Required when \code{ne_t} is provided; otherwise -#' \code{NULL}. -#' @param bar_ye_c A numeric scalar giving the external control group sample -#' mean. Required when \code{ne_c} is provided; otherwise \code{NULL}. -#' @param se_t A positive numeric scalar giving the external treatment group -#' sample SD. Required when \code{ne_t} is provided; otherwise -#' \code{NULL}. -#' @param se_c A positive numeric scalar giving the external control group -#' sample SD. Required when \code{ne_c} is provided; otherwise -#' \code{NULL}. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(\mathrm{effect} \le \theta_0)}, otherwise -#' \eqn{P(\mathrm{effect} > \theta_0)}. -#' -#' @return A numeric scalar or vector in \code{[0, 1]}. When the input data -#' parameters (\code{bar_y_t}, etc.) are vectors of length \eqn{n}, -#' a vector of length \eqn{n} is returned. -#' -#' @details -#' Under the Normal-Inverse-Chi-squared (N-Inv-ChiSq) conjugate model, the -#' marginal posterior/predictive distribution of the group mean follows a -#' non-standardised t-distribution, parameterised by a location -#' \eqn{\mu_j}, a scale \eqn{\sigma_j}, and degrees of freedom \eqn{\nu_j} -#' that depend on the design and probability type. The final probability is -#' computed by one of three methods: -#' \itemize{ -#' \item \code{NI}: exact numerical integration via \code{\link{ptdiff_NI}}. -#' \item \code{MC}: Monte Carlo simulation via \code{\link{ptdiff_MC}}. -#' \item \code{MM}: Moment-Matching approximation via -#' \code{\link{ptdiff_MM}}. -#' } -#' -#' \strong{Performance note}: \code{CalcMethod = 'NI'} calls -#' \code{integrate()} once per element of the input vector, which is -#' prohibitively slow for large vectors (e.g., \code{nsim x n_scenarios}). -#' \code{CalcMethod = 'MC'} creates an \code{nMC x n} matrix internally, -#' consuming \eqn{O(nMC \cdot n)} memory. For large-scale simulation use -#' \code{CalcMethod = 'MM'}, which is fully vectorised and exact in the -#' normal limit. -#' -#' @examples -#' # Example 1: Controlled design - posterior probability with N-Inv-Chisq -#' pbayespostpred1cont( -#' prob = 'posterior', design = 'controlled', prior = 'N-Inv-Chisq', -#' CalcMethod = 'NI', theta0 = 2, n_t = 12, n_c = 12, -#' kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, -#' mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), -#' bar_y_t = 2, bar_y_c = 0, s_t = 1, s_c = 1, -#' m_t = NULL, m_c = NULL, r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' lower.tail = FALSE -#' ) -#' -#' # Example 2: Uncontrolled design - posterior probability with vague prior -#' pbayespostpred1cont( -#' prob = 'posterior', design = 'uncontrolled', prior = 'vague', -#' CalcMethod = 'MM', theta0 = 1.5, n_t = 15, n_c = NULL, -#' bar_y_t = 3.5, bar_y_c = NULL, s_t = 1.2, s_c = NULL, -#' mu0_c = 1.5, r = 1.2, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' m_t = NULL, m_c = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' lower.tail = FALSE -#' ) -#' -#' # Example 3: External design - posterior probability -#' pbayespostpred1cont( -#' prob = 'posterior', design = 'external', prior = 'N-Inv-Chisq', -#' CalcMethod = 'MM', theta0 = 2, n_t = 12, n_c = 12, -#' kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, -#' mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), -#' bar_y_t = 2.5, bar_y_c = 1, s_t = 1.1, s_c = 0.9, -#' m_t = NULL, m_c = NULL, r = NULL, -#' ne_t = 10, ne_c = 10, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' bar_ye_t = 2, bar_ye_c = 0.5, se_t = 1, se_c = 0.8, -#' lower.tail = FALSE -#' ) -#' -#' # Example 4: Controlled design - posterior predictive probability -#' pbayespostpred1cont( -#' prob = 'predictive', design = 'controlled', prior = 'N-Inv-Chisq', -#' CalcMethod = 'MM', theta0 = 1, n_t = 12, n_c = 12, -#' kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, -#' mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), -#' bar_y_t = 2, bar_y_c = 0, s_t = 1, s_c = 1, -#' m_t = 20, m_c = 20, r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' lower.tail = FALSE -#' ) -#' -#' # Example 5: Uncontrolled design - posterior predictive probability -#' pbayespostpred1cont( -#' prob = 'predictive', design = 'uncontrolled', prior = 'vague', -#' CalcMethod = 'MM', theta0 = 1.5, n_t = 15, n_c = NULL, -#' bar_y_t = 3.5, bar_y_c = NULL, s_t = 1.2, s_c = NULL, -#' mu0_c = 1.5, r = 1.2, -#' kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, -#' mu0_t = NULL, sigma0_t = NULL, sigma0_c = NULL, -#' m_t = 20, m_c = 20, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' lower.tail = FALSE -#' ) -#' -#' # Example 6: External design - posterior predictive probability -#' pbayespostpred1cont( -#' prob = 'predictive', design = 'external', prior = 'N-Inv-Chisq', -#' CalcMethod = 'MM', theta0 = 1, n_t = 12, n_c = 12, -#' kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, -#' mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), -#' bar_y_t = 2.5, bar_y_c = 1, s_t = 1.1, s_c = 0.9, -#' m_t = 20, m_c = 20, r = NULL, -#' ne_t = 10, ne_c = 10, alpha0e_t = 0.5, alpha0e_c = 0.5, -#' bar_ye_t = 2, bar_ye_c = 0.5, se_t = 1, se_c = 0.8, -#' lower.tail = FALSE -#' ) -#' -#' @export -pbayespostpred1cont <- function(prob = "posterior", design = "controlled", - prior = "vague", CalcMethod = "NI", - theta0, nMC = NULL, n_t, n_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, - nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, - sigma0_t = NULL, sigma0_c = NULL, - bar_y_t, bar_y_c = NULL, s_t, s_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - lower.tail = TRUE) { - - # --- Input validation --- - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c("posterior", "predictive")) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c("controlled", "uncontrolled", "external")) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c("vague", "N-Inv-Chisq")) { - stop("'prior' must be either 'vague' or 'N-Inv-Chisq'") - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c("NI", "MC", "MM")) { - stop("'CalcMethod' must be 'NI', 'MC', or 'MM'") - } - - if (!is.numeric(theta0) || length(theta0) != 1L || is.na(theta0)) { - stop("'theta0' must be a single numeric value") - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 1L) { - stop("'n_t' must be a single positive integer") - } - - if (design != "uncontrolled") { - if (is.null(n_c) || !is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 1L) { - stop("'n_c' must be a single positive integer for controlled or external design") - } - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # Validate vector data arguments - if (!is.numeric(bar_y_t) || length(bar_y_t) < 1L || any(is.na(bar_y_t))) { - stop("'bar_y_t' must be a numeric scalar or vector with no missing values") - } - - if (!is.numeric(s_t) || length(s_t) < 1L || any(is.na(s_t)) || any(s_t <= 0)) { - stop("'s_t' must be a positive numeric scalar or vector with no missing values") - } - - # Validate CalcMethod-specific parameters - if (CalcMethod == "MC") { - if (is.null(nMC)) { - stop("'nMC' must be specified when CalcMethod = 'MC'") - } - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer") - } - } - - # Validate prob-specific parameters - if (prob == "predictive") { - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - if (!is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer") - } - if (!is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer") - } - } - - # Validate prior-specific parameters for N-Inv-Chisq - if (prior == "N-Inv-Chisq") { - for (nm in c("kappa0_t", "nu0_t", "mu0_t", "sigma0_t")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prior = 'N-Inv-Chisq'")) - } - } - if (!is.numeric(kappa0_t) || length(kappa0_t) != 1L || is.na(kappa0_t) || kappa0_t <= 0) { - stop("'kappa0_t' must be a single positive numeric value") - } - if (!is.numeric(nu0_t) || length(nu0_t) != 1L || is.na(nu0_t) || nu0_t <= 0) { - stop("'nu0_t' must be a single positive numeric value") - } - if (!is.numeric(mu0_t) || length(mu0_t) != 1L || is.na(mu0_t)) { - stop("'mu0_t' must be a single numeric value") - } - if (!is.numeric(sigma0_t) || length(sigma0_t) != 1L || is.na(sigma0_t) || sigma0_t <= 0) { - stop("'sigma0_t' must be a single positive numeric value") - } - if (design %in% c("controlled", "external")) { - for (nm in c("kappa0_c", "nu0_c", "mu0_c", "sigma0_c")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prior = 'N-Inv-Chisq' and design = '", - design, "'")) - } - } - if (!is.numeric(kappa0_c) || length(kappa0_c) != 1L || is.na(kappa0_c) || kappa0_c <= 0) { - stop("'kappa0_c' must be a single positive numeric value") - } - if (!is.numeric(nu0_c) || length(nu0_c) != 1L || is.na(nu0_c) || nu0_c <= 0) { - stop("'nu0_c' must be a single positive numeric value") - } - if (!is.numeric(sigma0_c) || length(sigma0_c) != 1L || is.na(sigma0_c) || sigma0_c <= 0) { - stop("'sigma0_c' must be a single positive numeric value") - } - } - } - - # Validate design-specific parameters - if (design == "uncontrolled") { - if (is.null(mu0_c)) { - stop("'mu0_c' (hypothetical control mean) must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(mu0_c) || length(mu0_c) != 1L || is.na(mu0_c)) { - stop("'mu0_c' must be a single numeric value") - } - if (is.null(r)) { - stop("'r' (variance scaling factor) must be non-NULL when design = 'uncontrolled'") - } - if (!is.numeric(r) || length(r) != 1L || is.na(r) || r <= 0) { - stop("'r' must be a single positive numeric value") - } - } - - if (design == "external") { - if (is.null(ne_t) && is.null(ne_c)) { - stop("For design = 'external', at least one of 'ne_t' or 'ne_c' must be non-NULL") - } - if (!is.null(ne_t)) { - if (is.null(alpha0e_t) || is.null(bar_ye_t) || is.null(se_t)) { - stop("'alpha0e_t', 'bar_ye_t', and 'se_t' must all be non-NULL when 'ne_t' is provided") - } - if (!is.numeric(ne_t) || length(ne_t) != 1L || is.na(ne_t) || - ne_t != floor(ne_t) || ne_t < 1L) { - stop("'ne_t' must be a single positive integer") - } - if (!is.numeric(alpha0e_t) || length(alpha0e_t) != 1L || is.na(alpha0e_t) || - alpha0e_t <= 0 || alpha0e_t > 1) { - stop("'alpha0e_t' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_t) || length(bar_ye_t) != 1L || is.na(bar_ye_t)) { - stop("'bar_ye_t' must be a single numeric value") - } - if (!is.numeric(se_t) || length(se_t) != 1L || is.na(se_t) || se_t <= 0) { - stop("'se_t' must be a single positive numeric value") - } - } - if (!is.null(ne_c)) { - if (is.null(alpha0e_c) || is.null(bar_ye_c) || is.null(se_c)) { - stop("'alpha0e_c', 'bar_ye_c', and 'se_c' must all be non-NULL when 'ne_c' is provided") - } - if (!is.numeric(ne_c) || length(ne_c) != 1L || is.na(ne_c) || - ne_c != floor(ne_c) || ne_c < 1L) { - stop("'ne_c' must be a single positive integer") - } - if (!is.numeric(alpha0e_c) || length(alpha0e_c) != 1L || is.na(alpha0e_c) || - alpha0e_c <= 0 || alpha0e_c > 1) { - stop("'alpha0e_c' must be a single numeric value in (0, 1]") - } - if (!is.numeric(bar_ye_c) || length(bar_ye_c) != 1L || is.na(bar_ye_c)) { - stop("'bar_ye_c' must be a single numeric value") - } - if (!is.numeric(se_c) || length(se_c) != 1L || is.na(se_c) || se_c <= 0) { - stop("'se_c' must be a single positive numeric value") - } - } - if (!is.null(bar_y_c) && (!is.numeric(bar_y_c) || any(is.na(bar_y_c)))) { - stop("'bar_y_c' must be a numeric scalar or vector with no missing values") - } - if (!is.null(s_c) && (!is.numeric(s_c) || any(is.na(s_c)) || any(s_c <= 0))) { - stop("'s_c' must be a positive numeric scalar or vector with no missing values") - } - } - - if (design == "controlled") { - if (is.null(bar_y_c) || is.null(s_c)) { - stop("'bar_y_c' and 's_c' must be non-NULL when design = 'controlled'") - } - if (!is.numeric(bar_y_c) || any(is.na(bar_y_c))) { - stop("'bar_y_c' must be a numeric scalar or vector with no missing values") - } - if (!is.numeric(s_c) || any(is.na(s_c)) || any(s_c <= 0)) { - stop("'s_c' must be a positive numeric scalar or vector with no missing values") - } - } - - # --------------------------------------------------------------------------- - # Compute posterior t-distribution parameters (vectorised over bar_y_t, s_t, - # bar_y_c, s_c; all arithmetic operates element-wise on vectors). - # --------------------------------------------------------------------------- - - if (design == 'external') { - - if (prior == 'N-Inv-Chisq') { - - # --- External design with N-Inv-Chisq prior --- - # Power prior for normal data is conjugate with the N-Inv-Chisq prior. - # The posterior hyperparameters incorporate both the N-Inv-Chisq prior - # and the external data via the power prior weight. - - # Group 1 (Treatment): incorporate external data if available - if (!is.null(ne_t) && !is.null(alpha0e_t)) { - # Intermediate: N-Inv-Chisq prior updated with power-weighted external data - kappa_e_t <- kappa0_t + alpha0e_t * ne_t - nu_e_t <- nu0_t + alpha0e_t * ne_t - mu_e_t <- (kappa0_t * mu0_t + alpha0e_t * ne_t * bar_ye_t) / kappa_e_t - var_e_t <- (nu0_t * sigma0_t ^ 2 + alpha0e_t * (ne_t - 1) * se_t ^ 2 + - alpha0e_t * ne_t * kappa0_t * (bar_ye_t - mu0_t) ^ 2 / kappa_e_t) / nu_e_t - # Final update with PoC data - kappa_n_t <- kappa_e_t + n_t - nu_t <- nu_e_t + n_t - mu_t <- (kappa_e_t * mu_e_t + n_t * bar_y_t) / kappa_n_t - var_n_t <- (nu_e_t * var_e_t + (n_t - 1) * s_t ^ 2 + - n_t * kappa_e_t * (mu_e_t - bar_y_t) ^ 2 / kappa_n_t) / nu_t - } else { - # No external treatment data: N-Inv-Chisq prior updated with PoC data only - kappa_n_t <- kappa0_t + n_t - nu_t <- nu0_t + n_t - mu_t <- (kappa0_t * mu0_t + n_t * bar_y_t) / kappa_n_t - var_n_t <- (nu0_t * sigma0_t ^ 2 + (n_t - 1) * s_t ^ 2 + - n_t * kappa0_t * (mu0_t - bar_y_t) ^ 2 / kappa_n_t) / nu_t - } - - # Group 2 (Control): incorporate external data if available - if (!is.null(ne_c) && !is.null(alpha0e_c)) { - # Intermediate: N-Inv-Chisq prior updated with power-weighted external data - kappa_e_c <- kappa0_c + alpha0e_c * ne_c - nu_e_c <- nu0_c + alpha0e_c * ne_c - mu_e_c <- (kappa0_c * mu0_c + alpha0e_c * ne_c * bar_ye_c) / kappa_e_c - var_e_c <- (nu0_c * sigma0_c ^ 2 + alpha0e_c * (ne_c - 1) * se_c ^ 2 + - alpha0e_c * ne_c * kappa0_c * (bar_ye_c - mu0_c) ^ 2 / kappa_e_c) / nu_e_c - # Final update with PoC data - kappa_n_c <- kappa_e_c + n_c - nu_c <- nu_e_c + n_c - mu_c <- (kappa_e_c * mu_e_c + n_c * bar_y_c) / kappa_n_c - var_n_c <- (nu_e_c * var_e_c + (n_c - 1) * s_c ^ 2 + - n_c * kappa_e_c * (mu_e_c - bar_y_c) ^ 2 / kappa_n_c) / nu_c - } else { - # No external control data: N-Inv-Chisq prior updated with PoC data only - kappa_n_c <- kappa0_c + n_c - nu_c <- nu0_c + n_c - mu_c <- (kappa0_c * mu0_c + n_c * bar_y_c) / kappa_n_c - var_n_c <- (nu0_c * sigma0_c ^ 2 + (n_c - 1) * s_c ^ 2 + - n_c * kappa0_c * (mu0_c - bar_y_c) ^ 2 / kappa_n_c) / nu_c - } - - # Scale parameters depend on probability type - if (prob == 'posterior') { - sd_t <- sqrt(var_n_t / kappa_n_t) - sd_c <- sqrt(var_n_c / kappa_n_c) - } else { - sd_t <- sqrt((1 + 1 / kappa_n_t) * var_n_t / m_t) - sd_c <- sqrt((1 + 1 / kappa_n_c) * var_n_c / m_c) - } - - } else { - - # --- External design with vague prior --- - # Group 1 (Treatment): apply power prior if external data available - if (!is.null(ne_t) && !is.null(alpha0e_t)) { - mu_t <- (alpha0e_t * ne_t * bar_ye_t + n_t * bar_y_t) / (alpha0e_t * ne_t + n_t) - kappa_star_n_t <- alpha0e_t * ne_t + n_t - nu_t <- alpha0e_t * ne_t + n_t - 1 - sigma2_star_n_t <- (alpha0e_t * (ne_t - 1) * se_t ^ 2 + (n_t - 1) * s_t ^ 2 + - (alpha0e_t * ne_t * n_t * (bar_ye_t - bar_y_t) ^ 2) / - (alpha0e_t * ne_t + n_t)) / (alpha0e_t * ne_t + n_t) - } else { - # No external treatment data: use vague prior - mu_t <- bar_y_t - kappa_star_n_t <- n_t - nu_t <- n_t - 1 - sigma2_star_n_t <- s_t ^ 2 - } - - # Group 2 (Control): apply power prior if external data available - if (!is.null(ne_c) && !is.null(alpha0e_c)) { - mu_c <- (alpha0e_c * ne_c * bar_ye_c + n_c * bar_y_c) / (alpha0e_c * ne_c + n_c) - kappa_star_n_c <- alpha0e_c * ne_c + n_c - nu_c <- alpha0e_c * ne_c + n_c - 1 - sigma2_star_n_c <- (alpha0e_c * (ne_c - 1) * se_c ^ 2 + (n_c - 1) * s_c ^ 2 + - (alpha0e_c * ne_c * n_c * (bar_ye_c - bar_y_c) ^ 2) / - (alpha0e_c * ne_c + n_c)) / (alpha0e_c * ne_c + n_c) - } else { - # No external control data: use vague prior - mu_c <- bar_y_c - kappa_star_n_c <- n_c - nu_c <- n_c - 1 - sigma2_star_n_c <- s_c ^ 2 - } - - # Scale parameters depend on probability type - if (prob == 'posterior') { - sd_t <- sqrt(sigma2_star_n_t / kappa_star_n_t) - sd_c <- sqrt(sigma2_star_n_c / kappa_star_n_c) - } else { - sd_t <- sqrt((1 + 1 / kappa_star_n_t) * sigma2_star_n_t / m_t) - sd_c <- sqrt((1 + 1 / kappa_star_n_c) * sigma2_star_n_c / m_c) - } - } - - } else { - - # --- Controlled or uncontrolled designs (vague or N-Inv-Chisq prior) --- - if (prior == 'N-Inv-Chisq') { - - # Updated precision parameters - kappa_n_t <- kappa0_t + n_t - kappa_n_c <- kappa0_c + n_c - - # Updated degrees of freedom - nu_t <- nu0_t + n_t - if (design == 'controlled') { - nu_c <- nu0_c + n_c - } else { - nu_c <- nu_t - } - - # Posterior means - mu_t <- (kappa0_t * mu0_t + n_t * bar_y_t) / kappa_n_t - if (design == 'controlled') { - mu_c <- (kappa0_c * mu0_c + n_c * bar_y_c) / kappa_n_c - } else { - mu_c <- mu0_c - } - - # Posterior variance for the treatment group (vectorised over bar_y_t, s_t) - var_n_t <- (nu0_t * sigma0_t ^ 2 + (n_t - 1) * s_t ^ 2 + - n_t * kappa0_t * (mu0_t - bar_y_t) ^ 2 / kappa_n_t) / nu_t - - # Posterior variance for the control group - if (design == 'controlled') { - var_n_c <- (nu0_c * sigma0_c ^ 2 + (n_c - 1) * s_c ^ 2 + - n_c * kappa0_c * (mu0_c - bar_y_c) ^ 2 / kappa_n_c) / nu_c - } else { - var_n_c <- NULL - } - - # Scale parameters depend on probability type - if (prob == 'posterior') { - sd_t <- sqrt(var_n_t / kappa_n_t) - if (design == 'controlled') { - sd_c <- sqrt(var_n_c / kappa_n_c) - } else { - sd_c <- sqrt(r) * sd_t - } - } else { - sd_t <- sqrt((1 + 1 / kappa_n_t) * var_n_t / m_t) - if (design == 'controlled') { - sd_c <- sqrt((1 + 1 / kappa_n_c) * var_n_c / m_c) - } else { - sd_c <- sqrt(r) * sd_t - } - } - - } else { - # Vague (Jeffreys) prior - - # Degrees of freedom - nu_t <- n_t - 1 - if (design == 'controlled') { - nu_c <- n_c - 1 - } else { - nu_c <- nu_t - } - - # Posterior means (vectorised over bar_y_t, bar_y_c) - mu_t <- bar_y_t - if (design == 'controlled') { - mu_c <- bar_y_c - } else { - mu_c <- mu0_c - } - - # Scale parameters (vectorised over s_t, s_c) - if (prob == 'posterior') { - sd_t <- sqrt(s_t ^ 2 / n_t) - if (design == 'controlled') { - sd_c <- sqrt(s_c ^ 2 / n_c) - } else { - sd_c <- sqrt(r) * sd_t - } - } else { - sd_t <- sqrt((1 + 1 / n_t) * s_t ^ 2 / m_t) - if (design == 'controlled') { - sd_c <- sqrt((1 + 1 / n_c) * s_c ^ 2 / m_c) - } else { - sd_c <- sqrt(r) * sd_t - } - } - } - } - - # --------------------------------------------------------------------------- - # Compute probability using the specified method. - # mu_t, mu_c, sd_t, sd_c may be vectors of length nsim when called from - # pbayesdecisionprob1cont; each method receives the full vector and returns a - # vector of the same length (no outer loop required). - # --------------------------------------------------------------------------- - if (CalcMethod == 'NI') { - results <- ptdiff_NI(theta0, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail) - } else if (CalcMethod == 'MC') { - results <- ptdiff_MC(nMC, theta0, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail) - } else { - results <- ptdiff_MM(theta0, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail) - } - - return(results) -} diff --git a/R/pbayespostpred2bin.R b/R/pbayespostpred2bin.R deleted file mode 100644 index bdc19ea..0000000 --- a/R/pbayespostpred2bin.R +++ /dev/null @@ -1,598 +0,0 @@ -#' Bayesian Posterior or Posterior Predictive Probability for Two Binary -#' Endpoints -#' -#' Computes the Bayesian posterior probability or posterior predictive -#' probability for clinical trials with two binary endpoints under a -#' Dirichlet-multinomial conjugate model. The function returns probabilities -#' for nine decision regions (posterior) or four decision regions (predictive) -#' defined by target values (TV) and minimum acceptable values (MAV) for both -#' endpoints. Three study designs are supported: controlled, uncontrolled -#' (hypothetical control), and external (power prior). -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param theta_TV1 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 1. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV1 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 1. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_TV2 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 2. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV2 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 2. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param x_t_00 A non-negative integer giving the count of -#' \code{(0, 0)} responses in the treatment group (Endpoint 1 = 0, -#' Endpoint 2 = 0). -#' @param x_t_01 A non-negative integer giving the count of \code{(0, 1)} -#' responses in the treatment group. -#' @param x_t_10 A non-negative integer giving the count of \code{(1, 0)} -#' responses in the treatment group. -#' @param x_t_11 A non-negative integer giving the count of \code{(1, 1)} -#' responses in the treatment group. -#' @param x_c_00 A non-negative integer giving the count of \code{(0, 0)} -#' responses in the control group. Not used when -#' \code{design = 'uncontrolled'}; set to \code{NULL} in that case. -#' @param x_c_01 A non-negative integer giving the count of \code{(0, 1)} -#' responses in the control group. Not used when -#' \code{design = 'uncontrolled'}; set to \code{NULL} in that case. -#' @param x_c_10 A non-negative integer giving the count of \code{(1, 0)} -#' responses in the control group. Not used when -#' \code{design = 'uncontrolled'}; set to \code{NULL} in that case. -#' @param x_c_11 A non-negative integer giving the count of \code{(1, 1)} -#' responses in the control group. Not used when -#' \code{design = 'uncontrolled'}; set to \code{NULL} in that case. -#' @param a_t_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 0)} response pattern in the treatment -#' group. -#' @param a_t_01 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 1)} response pattern in the treatment -#' group. -#' @param a_t_10 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 0)} response pattern in the treatment -#' group. -#' @param a_t_11 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 1)} response pattern in the treatment -#' group. -#' @param a_c_00 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 0)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_01 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(0, 1)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_10 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 0)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param a_c_11 A positive numeric scalar giving the Dirichlet prior -#' parameter for the \code{(1, 1)} response pattern in the control -#' group. For \code{design = 'uncontrolled'}, serves as a -#' hyperparameter of the hypothetical control distribution. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param z00 A non-negative integer giving the hypothetical control count -#' for pattern \code{(0, 0)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z01 A non-negative integer giving the hypothetical control count -#' for pattern \code{(0, 1)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z10 A non-negative integer giving the hypothetical control count -#' for pattern \code{(1, 0)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param z11 A non-negative integer giving the hypothetical control count -#' for pattern \code{(1, 1)}. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param xe_t_00 A non-negative integer giving the external treatment group -#' count for pattern \code{(0, 0)}. Required when -#' \code{design = 'external'} and external treatment data are used; -#' otherwise \code{NULL}. -#' @param xe_t_01 A non-negative integer giving the external treatment group -#' count for pattern \code{(0, 1)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_t_10 A non-negative integer giving the external treatment group -#' count for pattern \code{(1, 0)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_t_11 A non-negative integer giving the external treatment group -#' count for pattern \code{(1, 1)}. Required for external treatment -#' data; otherwise \code{NULL}. -#' @param xe_c_00 A non-negative integer giving the external control group -#' count for pattern \code{(0, 0)}. Required when -#' \code{design = 'external'} and external control data are used; -#' otherwise \code{NULL}. -#' @param xe_c_01 A non-negative integer giving the external control group -#' count for pattern \code{(0, 1)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param xe_c_10 A non-negative integer giving the external control group -#' count for pattern \code{(1, 0)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param xe_c_11 A non-negative integer giving the external control group -#' count for pattern \code{(1, 1)}. Required for external control -#' data; otherwise \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external treatment data. Required when external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external control data. Required when external -#' control data are used; otherwise set to \code{NULL}. -#' @param nMC A positive integer giving the number of Monte Carlo draws used -#' to estimate region probabilities. Default is \code{10000}. Larger -#' values reduce Monte Carlo error at the cost of computation time. -#' -#' @return A named numeric vector of region probabilities. For -#' \code{prob = 'posterior'}: length 9, named \code{R1}, ..., -#' \code{R9}, corresponding to regions defined by TV and MAV -#' thresholds for both endpoints (row-major order: Endpoint 1 varies -#' slowest). For \code{prob = 'predictive'}: length 4, named -#' \code{R1}, ..., \code{R4}. All elements are non-negative and sum -#' to 1. -#' -#' @details -#' \strong{Model.} The four response categories are ordered as -#' \code{(0, 0)}, \code{(0, 1)}, \code{(1, 0)}, \code{(1, 1)}. For each -#' group \eqn{j}, the observed count vector follows a multinomial -#' distribution, and a conjugate Dirichlet prior is placed on the cell -#' probability vector \eqn{p_j}: -#' \deqn{p_j \sim \mathrm{Dir}(\alpha_{j,00}, \alpha_{j,01}, \alpha_{j,10}, -#' \alpha_{j,11}).} -#' The posterior is -#' \deqn{p_j \mid x_j \sim \mathrm{Dir}(\alpha_{j,00} + x_{j,00}, -#' \alpha_{j,01} + x_{j,01}, \alpha_{j,10} + x_{j,10}, -#' \alpha_{j,11} + x_{j,11}).} -#' -#' Marginal response rates are \eqn{\pi_{j1} = p_{j,10} + p_{j,11}} -#' (Endpoint 1) and \eqn{\pi_{j2} = p_{j,01} + p_{j,11}} (Endpoint 2). -#' Treatment effects are \eqn{\theta_1 = \pi_{t1} - \pi_{c1}} and -#' \eqn{\theta_2 = \pi_{t2} - \pi_{c2}}. -#' -#' \strong{Uncontrolled design.} When \code{design = 'uncontrolled'}, the -#' hypothetical control distribution is specified as a Dirichlet -#' distribution directly via the prior hyperparameters and hypothetical -#' control counts \code{z00}, \code{z01}, \code{z10}, \code{z11}. -#' -#' \strong{External design.} When \code{design = 'external'}, the power -#' prior augments the Dirichlet prior parameters. -#' -#' @examples -#' # Example 1: Controlled design - posterior probability -#' pbayespostpred2bin( -#' prob = 'posterior', design = 'controlled', -#' theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = NULL, m_c = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 2: Uncontrolled design - posterior probability -#' pbayespostpred2bin( -#' prob = 'posterior', design = 'uncontrolled', -#' theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = NULL, m_c = NULL, -#' z00 = 1, z01 = 2, z10 = 2, z11 = 1, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 3: External design - posterior probability -#' pbayespostpred2bin( -#' prob = 'posterior', design = 'external', -#' theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = NULL, m_c = NULL, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = 2, xe_t_01 = 2, xe_t_10 = 3, xe_t_11 = 1, -#' xe_c_00 = 2, xe_c_01 = 1, xe_c_10 = 2, xe_c_11 = 1, -#' alpha0e_t = 0.5, alpha0e_c = 0.5 -#' ) -#' -#' # Example 4: Controlled design - posterior predictive probability -#' pbayespostpred2bin( -#' prob = 'predictive', design = 'controlled', -#' theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.05, theta_NULL2 = 0.0, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = 20, m_c = 20, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 5: Uncontrolled design - posterior predictive probability -#' pbayespostpred2bin( -#' prob = 'predictive', design = 'uncontrolled', -#' theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.05, theta_NULL2 = 0.0, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = 20, m_c = 20, -#' z00 = 1, z01 = 2, z10 = 2, z11 = 1, -#' xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, -#' xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, -#' alpha0e_t = NULL, alpha0e_c = NULL -#' ) -#' -#' # Example 6: External design - posterior predictive probability -#' pbayespostpred2bin( -#' prob = 'predictive', design = 'external', -#' theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.05, theta_NULL2 = 0.0, -#' x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, -#' x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, -#' a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, -#' a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, -#' m_t = 20, m_c = 20, -#' z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, -#' xe_t_00 = 2, xe_t_01 = 2, xe_t_10 = 3, xe_t_11 = 1, -#' xe_c_00 = 2, xe_c_01 = 1, xe_c_10 = 2, xe_c_11 = 1, -#' alpha0e_t = 0.5, alpha0e_c = 0.5 -#' ) -#' -#' @export -pbayespostpred2bin <- function(prob = 'posterior', - design = 'controlled', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00, x_t_01, x_t_10, x_t_11, - x_c_00 = NULL, x_c_01 = NULL, - x_c_10 = NULL, x_c_11 = NULL, - a_t_00, a_t_01, a_t_10, a_t_11, - a_c_00, a_c_01, a_c_10, a_c_11, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, - z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, - xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, - xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 10000L) { - - # --------------------------------------------------------------------------- - # Section 1: Input validation - # --------------------------------------------------------------------------- - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) { - stop("'prob' must be either 'posterior' or 'predictive'") - } - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) { - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - } - - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer") - } - nMC <- as.integer(nMC) - - # --- Threshold parameters --- - if (prob == 'posterior') { - for (nm in c("theta_TV1", "theta_MAV1", "theta_TV2", "theta_MAV2")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'posterior'")) - } - if (!is.numeric(val) || length(val) != 1L || is.na(val)) { - stop(paste0("'", nm, "' must be a single numeric value")) - } - } - if (theta_TV1 <= theta_MAV1) { - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - } - if (theta_TV2 <= theta_MAV2) { - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } - } else { - for (nm in c("theta_NULL1", "theta_NULL2")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when prob = 'predictive'")) - } - if (!is.numeric(val) || length(val) != 1L || is.na(val)) { - stop(paste0("'", nm, "' must be a single numeric value")) - } - } - # Convert null thresholds: TV = MAV = NULL for predictive probability - theta_TV1 <- theta_NULL1; theta_MAV1 <- theta_NULL1 - theta_TV2 <- theta_NULL2; theta_MAV2 <- theta_NULL2 - } - - # --- Group 1 observed counts (always required) --- - for (nm in c("x_t_00", "x_t_01", "x_t_10", "x_t_11")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - - # --- Group 2 observed counts (required unless design = 'uncontrolled') --- - if (design != 'uncontrolled') { - for (nm in c("x_c_00", "x_c_01", "x_c_10", "x_c_11")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when design != 'uncontrolled'")) - } - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - } else { - # Warn if the control group data are accidentally supplied for uncontrolled design - if (!is.null(x_c_00) || !is.null(x_c_01) || - !is.null(x_c_10) || !is.null(x_c_11)) { - warning(paste0("design = 'uncontrolled': 'x_c_00', 'x_c_01', 'x_c_10', ", - "'x_c_11' are ignored. Use 'z00', 'z01', 'z10', 'z11' ", - "to specify the hypothetical control counts.")) - } - } - - # --- Dirichlet prior parameters (always required) --- - for (nm in c("a_t_00", "a_t_01", "a_t_10", "a_t_11", - "a_c_00", "a_c_01", "a_c_10", "a_c_11")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || val <= 0) { - stop(paste0("'", nm, "' must be a single positive numeric value")) - } - } - - # --- Future sample sizes (required for predictive) --- - if (prob == 'predictive') { - if (is.null(m_t) || is.null(m_c)) { - stop("'m_t' and 'm_c' must be non-NULL when prob = 'predictive'") - } - for (nm in c("m_t", "m_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) { - stop(paste0("'", nm, "' must be a single positive integer")) - } - } - m_t <- as.integer(m_t) - m_c <- as.integer(m_c) - } - - # --- Hypothetical control counts (required for uncontrolled) --- - if (design == 'uncontrolled') { - for (nm in c("z00", "z01", "z10", "z11")) { - val <- get(nm) - if (is.null(val)) { - stop(paste0("'", nm, "' must be non-NULL when design = 'uncontrolled'")) - } - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - } - - # --- External data parameters (required for external) --- - if (design == 'external') { - has_ext1 <- !is.null(xe_t_00) && !is.null(xe_t_01) && - !is.null(xe_t_10) && !is.null(xe_t_11) && !is.null(alpha0e_t) - has_ext2 <- !is.null(xe_c_00) && !is.null(xe_c_01) && - !is.null(xe_c_10) && !is.null(xe_c_11) && !is.null(alpha0e_c) - - if (!has_ext1 && !has_ext2) { - stop(paste0("For design = 'external', at least one complete set of ", - "external data (xe1_* + alpha0e_t or xe2_* + alpha0e_c) must be provided")) - } - - for (nm in c("alpha0e_t", "alpha0e_c")) { - val <- get(nm) - if (!is.null(val)) { - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val <= 0 || val > 1) { - stop(paste0("'", nm, "' must be a single numeric value in (0, 1]")) - } - } - } - - ext1_nms <- c("xe_t_00", "xe_t_01", "xe_t_10", "xe_t_11") - ext2_nms <- c("xe_c_00", "xe_c_01", "xe_c_10", "xe_c_11") - - if (has_ext1) { - for (nm in ext1_nms) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - } - if (has_ext2) { - for (nm in ext2_nms) { - val <- get(nm) - if (!is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 0L) { - stop(paste0("'", nm, "' must be a single non-negative integer")) - } - } - } - } - - # --------------------------------------------------------------------------- - # Section 2: Build posterior Dirichlet parameters - # --------------------------------------------------------------------------- - - # Group 1: base prior + observed data + optional external data (power prior) - xe_t_weight <- if (!is.null(alpha0e_t) && design == 'external') alpha0e_t else 0 - alpha_t <- c( - a_t_00 + x_t_00 + xe_t_weight * ifelse(!is.null(xe_t_00), xe_t_00, 0), - a_t_01 + x_t_01 + xe_t_weight * ifelse(!is.null(xe_t_01), xe_t_01, 0), - a_t_10 + x_t_10 + xe_t_weight * ifelse(!is.null(xe_t_10), xe_t_10, 0), - a_t_11 + x_t_11 + xe_t_weight * ifelse(!is.null(xe_t_11), xe_t_11, 0) - ) - - # Group 2: parameterisation depends on design - if (design == 'uncontrolled') { - # Hypothetical control distribution: prior augmented by pseudo-counts z* - # (Appendix A1.1.6: P_hyp(p_c) = Dir(beta_c00, ..., beta_c11) where - # beta_c** = a2_** + z**) - alpha_c <- c( - a_c_00 + z00, - a_c_01 + z01, - a_c_10 + z10, - a_c_11 + z11 - ) - } else { - # Controlled or external: posterior from observed control data - xe_c_weight <- if (!is.null(alpha0e_c) && design == 'external') alpha0e_c else 0 - alpha_c <- c( - a_c_00 + x_c_00 + xe_c_weight * ifelse(!is.null(xe_c_00), xe_c_00, 0), - a_c_01 + x_c_01 + xe_c_weight * ifelse(!is.null(xe_c_01), xe_c_01, 0), - a_c_10 + x_c_10 + xe_c_weight * ifelse(!is.null(xe_c_10), xe_c_10, 0), - a_c_11 + x_c_11 + xe_c_weight * ifelse(!is.null(xe_c_11), xe_c_11, 0) - ) - } - - # --------------------------------------------------------------------------- - # Section 3: Monte Carlo estimation - # --------------------------------------------------------------------------- - - # Draw nMC samples from the posterior (or hypothetical) Dirichlet for each group - # Columns of p_t/p_c: (p_00, p_01, p_10, p_11) - p_t <- rdirichlet(nMC, alpha_t) - p_c <- rdirichlet(nMC, alpha_c) - - if (prob == 'posterior') { - - # Marginal response rates: - # pi_k1 = p_k10 + p_k11 (Endpoint 1 success) - # pi_k2 = p_k01 + p_k11 (Endpoint 2 success) - theta1 <- (p_t[, 3L] + p_t[, 4L]) - (p_c[, 3L] + p_c[, 4L]) - theta2 <- (p_t[, 2L] + p_t[, 4L]) - (p_c[, 2L] + p_c[, 4L]) - - # Classify each draw into one of 9 regions (row-major: Endpoint 1 slowest) - # r1: 1 = theta1 > TV1, 2 = MAV1 < theta1 <= TV1, 3 = theta1 <= MAV1 - # r2: 1 = theta2 > TV2, 2 = MAV2 < theta2 <= TV2, 3 = theta2 <= MAV2 - r1 <- 3L - - as.integer(theta1 > theta_MAV1) - - as.integer(theta1 > theta_TV1) - r2 <- 3L - - as.integer(theta2 > theta_MAV2) - - as.integer(theta2 > theta_TV2) - - # Region index: 1 to 9, row-major (r1 varies slowest) - region <- (r1 - 1L) * 3L + r2 - - Pr_R <- tabulate(region, nbins = 9L) / nMC - names(Pr_R) <- paste0("R", 1:9) - - } else { - - # ------------------------------------------------------------------------- - # Posterior predictive: simulate future multinomial data from the - # Dirichlet-Multinomial distribution by sequential binomial draws. - # For each MC draw u: - # 1. Draw p_k^[u] from Dirichlet (done above). - # 2. Draw x_ek^[u] from Multinomial(m_k, p_k^[u]) via sequential - # conditional binomials: - # x_k1 ~ Bin(m_k, p_k1) - # x_k2 ~ Bin(m_k - x_k1, p_k2 / (1 - p_k1)) - # x_k3 ~ Bin(m_k - x_k1 - x_k2, p_k3 / (1 - p_k1 - p_k2)) - # x_k4 = m_k - x_k1 - x_k2 - x_k3 - # ------------------------------------------------------------------------- - - x_t_fut <- matrix(0L, nrow = nMC, ncol = 4L) - x_c_fut <- matrix(0L, nrow = nMC, ncol = 4L) - rem_t <- rep(m_t, nMC) - rem_c <- rep(m_c, nMC) - used_t <- rep(0, nMC) - used_c <- rep(0, nMC) - - for (j in seq_len(3L)) { - # Conditional probability of category j given remaining categories - denom1 <- pmax(1 - used_t, 0) - denom2 <- pmax(1 - used_c, 0) - prob1_j <- pmin(pmax(ifelse(denom1 > 0, p_t[, j] / denom1, 0), 0), 1) - prob2_j <- pmin(pmax(ifelse(denom2 > 0, p_c[, j] / denom2, 0), 0), 1) - - draw1 <- rbinom(nMC, rem_t, prob1_j) - draw2 <- rbinom(nMC, rem_c, prob2_j) - - x_t_fut[, j] <- draw1 - x_c_fut[, j] <- draw2 - rem_t <- rem_t - draw1 - rem_c <- rem_c - draw2 - used_t <- used_t + p_t[, j] - used_c <- used_c + p_c[, j] - } - # Remaining count goes to category 4 - x_t_fut[, 4L] <- rem_t - x_c_fut[, 4L] <- rem_c - - # Treatment effects based on future sample proportions - # theta_e1 = (x_et10 + x_et11) / mt - (x_ec10 + x_ec11) / mc - # theta_e2 = (x_et01 + x_et11) / mt - (x_ec01 + x_ec11) / mc - theta1 <- (x_t_fut[, 3L] + x_t_fut[, 4L]) / m_t - - (x_c_fut[, 3L] + x_c_fut[, 4L]) / m_c - theta2 <- (x_t_fut[, 2L] + x_t_fut[, 4L]) / m_t - - (x_c_fut[, 2L] + x_c_fut[, 4L]) / m_c - - # Classify each draw into one of 4 regions (Table 2 of reference) - # theta_TV1 = theta_MAV1 = NULL threshold for Endpoint 1 - # r1: 1 = theta1 > NULL1, 2 = theta1 <= NULL1 - # r2: 1 = theta2 > NULL2, 2 = theta2 <= NULL2 - r1 <- 2L - as.integer(theta1 > theta_TV1) - r2 <- 2L - as.integer(theta2 > theta_TV2) - - # Region index: row-major (r1 varies slowest) - # R1 = (1,1), R2 = (1,2), R3 = (2,1), R4 = (2,2) - region <- (r1 - 1L) * 2L + r2 - - Pr_R <- tabulate(region, nbins = 4L) / nMC - names(Pr_R) <- paste0("R", 1:4) - } - - return(Pr_R) -} diff --git a/R/pbayespostpred2cont.R b/R/pbayespostpred2cont.R deleted file mode 100644 index f0109e5..0000000 --- a/R/pbayespostpred2cont.R +++ /dev/null @@ -1,891 +0,0 @@ -#' Region Probabilities for Two Continuous Endpoints -#' -#' Computes the posterior or posterior predictive probability that the -#' bivariate treatment effect \eqn{\theta = \mu_t - \mu_c} falls in each of -#' the 9 (posterior) or 4 (predictive) rectangular regions defined by the -#' decision thresholds. -#' -#' @param prob A character string specifying the probability type. -#' Must be \code{'posterior'} or \code{'predictive'}. -#' @param design A character string specifying the trial design. -#' Must be \code{'controlled'}, \code{'uncontrolled'}, or -#' \code{'external'}. -#' @param prior A character string specifying the prior distribution. -#' Must be \code{'vague'} or \code{'N-Inv-Wishart'}. -#' @param theta_TV1 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 1. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV1 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 1. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_TV2 A numeric scalar giving the target value (TV) threshold -#' for Endpoint 2. Required when \code{prob = 'posterior'}; must -#' satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_MAV2 A numeric scalar giving the minimum acceptable value -#' (MAV) threshold for Endpoint 2. Required when -#' \code{prob = 'posterior'}; must satisfy -#' \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -#' \code{prob = 'predictive'}. -#' @param theta_NULL1 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 1. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param theta_NULL2 A numeric scalar giving the null hypothesis threshold -#' for Endpoint 2. Required when \code{prob = 'predictive'}; set to -#' \code{NULL} when \code{prob = 'posterior'}. -#' @param n_t A positive integer giving the number of patients in the -#' treatment group in the proof-of-concept (PoC) trial. -#' @param n_c A positive integer giving the number of patients in the -#' control group in the PoC trial. For \code{design = 'uncontrolled'}, -#' this is the hypothetical control sample size (required for -#' consistency with other designs). -#' @param ybar_t A numeric vector of length 2 \strong{or} a numeric matrix -#' with 2 columns giving the sample mean(s) for the treatment group. -#' When a matrix with \eqn{N} rows is supplied, the function computes -#' probabilities for all \eqn{N} observations simultaneously and -#' returns an \eqn{N \times n_{\rm regions}} matrix. -#' @param S_t A 2x2 numeric matrix giving the sum-of-squares matrix for the -#' treatment group (single observation), \strong{or} a list of \eqn{N} -#' such matrices (vectorised call). Must be consistent with -#' \code{ybar_t}: if \code{ybar_t} is a matrix, \code{S_t} must be a -#' list of the same length. -#' @param ybar_c A numeric vector of length 2, a numeric matrix with 2 -#' columns, or \code{NULL} giving the sample mean(s) for the control -#' group. Not used when \code{design = 'uncontrolled'}. -#' @param S_c A 2x2 numeric matrix, a list of 2x2 matrices, or \code{NULL} -#' giving the sum-of-squares matrix/matrices for the control group. -#' Not used when \code{design = 'uncontrolled'}. -#' @param m_t A positive integer giving the number of patients in the -#' treatment group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param m_c A positive integer giving the number of patients in the -#' control group for the future trial. Required when -#' \code{prob = 'predictive'}; otherwise set to \code{NULL}. -#' @param kappa0_t A positive numeric scalar giving the NIW prior -#' concentration parameter for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param nu0_t A numeric scalar giving the NIW prior degrees of freedom for -#' the treatment group. Must be greater than 3. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param mu0_t A numeric vector of length 2 giving the NIW prior mean for -#' the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param Lambda0_t A 2x2 positive-definite numeric matrix giving the NIW -#' prior scale matrix for the treatment group. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param kappa0_c A positive numeric scalar giving the NIW prior -#' concentration parameter for the control group. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param nu0_c A numeric scalar giving the NIW prior degrees of freedom for -#' the control group. Must be greater than 3. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param mu0_c A numeric vector of length 2 giving the NIW prior mean for -#' the control group, or the hypothetical control location when -#' \code{design = 'uncontrolled'}. Required when -#' \code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}. -#' @param Lambda0_c A 2x2 positive-definite numeric matrix giving the NIW -#' prior scale matrix for the control group. Required when -#' \code{prior = 'N-Inv-Wishart'} and -#' \code{design != 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param r A positive numeric scalar giving the variance scaling factor for -#' the hypothetical control distribution. Required when -#' \code{design = 'uncontrolled'}; otherwise set to \code{NULL}. -#' @param ne_t A positive integer giving the external treatment group sample -#' size. Required when \code{design = 'external'} and external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param ne_c A positive integer giving the external control group sample -#' size. Required when \code{design = 'external'} and external -#' control data are used; otherwise set to \code{NULL}. -#' @param alpha0e_t A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external treatment data. Required when external -#' treatment data are used; otherwise set to \code{NULL}. -#' @param alpha0e_c A numeric scalar in \code{(0, 1]} giving the power prior -#' weight for the external control data. Required when external -#' control data are used; otherwise set to \code{NULL}. -#' @param bar_ye_t A numeric vector of length 2 giving the external treatment -#' group sample mean. Required when external treatment data are used; -#' otherwise set to \code{NULL}. -#' @param bar_ye_c A numeric vector of length 2 giving the external control -#' group sample mean. Required when external control data are used; -#' otherwise set to \code{NULL}. -#' @param se_t A 2x2 numeric matrix giving the external treatment group -#' sum-of-squares matrix. Required when external treatment data are -#' used; otherwise set to \code{NULL}. -#' @param se_c A 2x2 numeric matrix giving the external control group -#' sum-of-squares matrix. Required when external control data are -#' used; otherwise set to \code{NULL}. -#' @param nMC A positive integer giving the number of Monte Carlo draws used -#' to estimate region probabilities. Default is \code{10000}. Required -#' when \code{CalcMethod = 'MC'}. May be set to \code{NULL} when -#' \code{CalcMethod = 'MM'} and \eqn{\nu_k > 4} (the MM method uses -#' \code{mvtnorm::pmvt} analytically); if \code{CalcMethod = 'MM'} but -#' \eqn{\nu_k \le 4} causes a fallback to MC, \code{nMC} must be a -#' positive integer. -#' @param CalcMethod A character string specifying the computation method. -#' Must be \code{'MC'} (Monte Carlo, default) or \code{'MM'} -#' (Moment-Matching via \code{mvtnorm::pmvt}). When -#' \code{CalcMethod = 'MM'} and \eqn{\nu_k \le 4}, a warning is issued -#' and the function falls back to \code{CalcMethod = 'MC'}. -#' -#' @return When \code{ybar_t} is a length-2 vector (single observation): a -#' named numeric vector of length 9 (\code{R1}--\code{R9}) for -#' \code{prob = 'posterior'} or length 4 (\code{R1}--\code{R4}) for -#' \code{prob = 'predictive'}. All elements are non-negative and sum -#' to 1. -#' -#' When \code{ybar_t} is an \eqn{N \times 2} matrix (vectorised call): -#' a numeric matrix with \eqn{N} rows and 9 (or 4) columns, with -#' column names \code{R1}--\code{R9} (or \code{R1}--\code{R4}). Each -#' row sums to 1. -#' -#' @details -#' \strong{Model.} -#' Both endpoints follow a bivariate Normal distribution -#' \eqn{y_{k,j} \sim N_2(\mu_k, \Sigma_k)} for group \eqn{k \in \{t, c\}}. -#' The treatment effect is \eqn{\theta = \mu_t - \mu_c}. -#' -#' \strong{Posterior distribution (vague prior).} -#' \deqn{\mu_k | Y_k \sim t_{n_k - 2}\!\left(\bar{y}_k,\; -#' \frac{S_k}{n_k(n_k - 2)}\right)} -#' -#' \strong{Posterior distribution (NIW prior).} -#' \deqn{\mu_k | Y_k \sim t_{\nu_{nk} - 1}\!\left(\mu_{nk},\; -#' \frac{\Lambda_{nk}}{\kappa_{nk}(\nu_{nk} - 1)}\right)} -#' with updated hyperparameters -#' \eqn{\kappa_{nk} = \kappa_{0k} + n_k}, -#' \eqn{\nu_{nk} = \nu_{0k} + n_k}, -#' \eqn{\mu_{nk} = (\kappa_{0k}\mu_{0k} + n_k\bar{y}_k)/\kappa_{nk}}, and -#' \eqn{\Lambda_{nk} = \Lambda_{0k} + S_k + -#' \kappa_{0k}n_k(\bar{y}_k - \mu_{0k})(\bar{y}_k - \mu_{0k})^T / \kappa_{nk}}. -#' -#' \strong{Predictive distribution.} -#' The scale matrix of a single future observation is inflated by -#' \eqn{(1 + n_k)/n_k} (vague) or \eqn{(1 + \kappa_{nk})/\kappa_{nk}} (NIW) -#' relative to the posterior. The mean of \eqn{m_k} future observations has -#' scale divided by \eqn{m_k}. -#' -#' \strong{Posterior probability regions (prob = 'posterior').} -#' Row-major 3x3 grid; Endpoint 1 varies slowest: -#' \itemize{ -#' \item R1: \eqn{\theta_1 > TV_1} AND \eqn{\theta_2 > TV_2} -#' \item R2: \eqn{\theta_1 > TV_1} AND \eqn{TV_2 \ge \theta_2 > MAV_2} -#' \item R3: \eqn{\theta_1 > TV_1} AND \eqn{\theta_2 \le MAV_2} -#' \item R4: \eqn{TV_1 \ge \theta_1 > MAV_1} AND \eqn{\theta_2 > TV_2} -#' \item R5: \eqn{TV_1 \ge \theta_1 > MAV_1} AND -#' \eqn{TV_2 \ge \theta_2 > MAV_2} -#' \item R6: \eqn{TV_1 \ge \theta_1 > MAV_1} AND \eqn{\theta_2 \le MAV_2} -#' \item R7: \eqn{\theta_1 \le MAV_1} AND \eqn{\theta_2 > TV_2} -#' \item R8: \eqn{\theta_1 \le MAV_1} AND -#' \eqn{TV_2 \ge \theta_2 > MAV_2} -#' \item R9: \eqn{\theta_1 \le MAV_1} AND \eqn{\theta_2 \le MAV_2} -#' } -#' -#' \strong{Predictive probability regions (prob = 'predictive').} -#' Row-major 2x2 grid; Endpoint 1 varies slowest: -#' \itemize{ -#' \item R1: \eqn{\tilde\theta_1 > \theta_{\rm NULL1}} AND -#' \eqn{\tilde\theta_2 > \theta_{\rm NULL2}} -#' \item R2: \eqn{\tilde\theta_1 > \theta_{\rm NULL1}} AND -#' \eqn{\tilde\theta_2 \le \theta_{\rm NULL2}} -#' \item R3: \eqn{\tilde\theta_1 \le \theta_{\rm NULL1}} AND -#' \eqn{\tilde\theta_2 > \theta_{\rm NULL2}} -#' \item R4: \eqn{\tilde\theta_1 \le \theta_{\rm NULL1}} AND -#' \eqn{\tilde\theta_2 \le \theta_{\rm NULL2}} -#' } -#' -#' \strong{Uncontrolled design.} -#' Under NIW prior: -#' \eqn{\mu_c \sim t_{\nu_{nt} - 1}(\mu_{0c},\; -#' r\Lambda_{nt} / [\kappa_{nt}(\nu_{nt} - 1)])}. -#' The parameter \code{r} allows the variance scale of the hypothetical -#' control to differ from the treatment group. -#' -#' \strong{External design.} -#' Incorporated via the power prior with NIW conjugate representation. -#' The effective posterior hyperparameters are obtained by constructing the -#' power prior from external data with weight \eqn{a_0}, then updating with -#' current PoC data (see Conjugate_power_prior.pdf, Theorem 5). -#' -#' \strong{Vectorised usage.} -#' When \code{ybar_t} is supplied as an \eqn{N \times 2} matrix and -#' \code{S_t} as a list of \eqn{N} scatter matrices, the function computes -#' region probabilities for all \eqn{N} observations in a single call, -#' returning an \eqn{N \times n_{\rm regions}} matrix. For -#' \code{CalcMethod = 'MC'}, standard normal and chi-squared variates are -#' pre-generated once (size \code{nMC}) and reused across all observations, -#' with only the Cholesky factor of the replicate-specific scale matrix -#' recomputed per observation. For \code{CalcMethod = 'MM'}, the -#' moment-matching parameters are computed per observation (since they depend -#' on the replicate-specific \eqn{V_k}) and \code{mvtnorm::pmvt} is called -#' once per region per observation. -#' -#' @examples -#' # Example 1: Controlled design - posterior probability, vague prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -#' pbayespostpred2cont( -#' prob = 'posterior', design = 'controlled', prior = 'vague', -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 12L, n_c = 12L, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = c(1.8, 1.0), S_c = S_c, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 1000L -#' ) -#' -#' # Example 2: Uncontrolled design - posterior probability, NIW prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -#' pbayespostpred2cont( -#' prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Wishart', -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 12L, n_c = NULL, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = NULL, S_c = NULL, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.5), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 1000L -#' ) -#' -#' # Example 3: External design - posterior probability, NIW prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -#' L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -#' se_c <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) -#' pbayespostpred2cont( -#' prob = 'posterior', design = 'external', prior = 'N-Inv-Wishart', -#' theta_TV1 = 1.5, theta_MAV1 = 0.5, -#' theta_TV2 = 1.0, theta_MAV2 = 0.3, -#' theta_NULL1 = NULL, theta_NULL2 = NULL, -#' n_t = 12L, n_c = 12L, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = c(1.8, 1.0), S_c = S_c, -#' m_t = NULL, m_c = NULL, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(1.0, 0.5), Lambda0_c = L0, -#' r = NULL, -#' ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = se_c, -#' nMC = 1000L -#' ) -#' -#' # Example 4: Controlled design - posterior predictive probability, vague prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -#' pbayespostpred2cont( -#' prob = 'predictive', design = 'controlled', prior = 'vague', -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 12L, n_c = 12L, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = c(1.8, 1.0), S_c = S_c, -#' m_t = 30L, m_c = 30L, -#' kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, -#' r = NULL, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 1000L -#' ) -#' -#' # Example 5: Uncontrolled design - posterior predictive probability, NIW prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -#' pbayespostpred2cont( -#' prob = 'predictive', design = 'uncontrolled', prior = 'N-Inv-Wishart', -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 12L, n_c = NULL, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = NULL, S_c = NULL, -#' m_t = 30L, m_c = 30L, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.5), Lambda0_c = NULL, -#' r = 1.0, -#' ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, -#' bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, -#' nMC = 1000L -#' ) -#' -#' # Example 6: External design - posterior predictive probability, NIW prior -#' S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -#' S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -#' L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -#' se_c <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) -#' pbayespostpred2cont( -#' prob = 'predictive', design = 'external', prior = 'N-Inv-Wishart', -#' theta_TV1 = NULL, theta_MAV1 = NULL, -#' theta_TV2 = NULL, theta_MAV2 = NULL, -#' theta_NULL1 = 0.5, theta_NULL2 = 0.3, -#' n_t = 12L, n_c = 12L, -#' ybar_t = c(3.5, 2.1), S_t = S_t, -#' ybar_c = c(1.8, 1.0), S_c = S_c, -#' m_t = 30L, m_c = 30L, -#' kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, -#' kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(1.0, 0.5), Lambda0_c = L0, -#' r = NULL, -#' ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, -#' bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = se_c, -#' nMC = 1000L -#' ) -#' -#' @importFrom stats rnorm rchisq -#' @importFrom mvtnorm pmvt -#' @export -pbayespostpred2cont <- function(prob, - design, - prior, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t, n_c = NULL, - ybar_t, S_t, - ybar_c = NULL, S_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, - mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, - mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, - se_t = NULL, se_c = NULL, - nMC = 10000L, - CalcMethod = 'MC') { - - # --------------------------------------------------------------------------- - # Section 1: Input validation - # --------------------------------------------------------------------------- - - if (!is.character(prob) || length(prob) != 1L || - !prob %in% c('posterior', 'predictive')) - stop("'prob' must be either 'posterior' or 'predictive'") - - if (!is.character(design) || length(design) != 1L || - !design %in% c('controlled', 'uncontrolled', 'external')) - stop("'design' must be 'controlled', 'uncontrolled', or 'external'") - - if (!is.character(prior) || length(prior) != 1L || - !prior %in% c('vague', 'N-Inv-Wishart')) - stop("'prior' must be 'vague' or 'N-Inv-Wishart'") - - if (prob == 'posterior') { - for (nm in c('theta_TV1', 'theta_MAV1', 'theta_TV2', 'theta_MAV2')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric when prob = 'posterior'")) - } - if (theta_TV1 <= theta_MAV1) - stop("'theta_TV1' must be strictly greater than 'theta_MAV1'") - if (theta_TV2 <= theta_MAV2) - stop("'theta_TV2' must be strictly greater than 'theta_MAV2'") - } else { - for (nm in c('theta_NULL1', 'theta_NULL2')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || is.na(val)) - stop(paste0("'", nm, "' must be a single numeric when prob = 'predictive'")) - } - for (nm in c('m_t', 'm_c')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || is.na(val) || - val != floor(val) || val < 1L) - stop(paste0("'", nm, "' must be a positive integer when prob = 'predictive'")) - } - m_t <- as.integer(m_t); m_c <- as.integer(m_c) - } - - if (!is.numeric(n_t) || length(n_t) != 1L || is.na(n_t) || - n_t != floor(n_t) || n_t < 2L) - stop("'n_t' must be a single integer >= 2") - n_t <- as.integer(n_t) - - if (design %in% c('controlled', 'external')) { - if (is.null(n_c) || !is.numeric(n_c) || length(n_c) != 1L || is.na(n_c) || - n_c != floor(n_c) || n_c < 2L) - stop("'n_c' must be a single integer >= 2 for controlled/external design") - n_c <- as.integer(n_c) - } - - # Determine whether vectorised (N > 1) or scalar call - vec_call <- is.matrix(ybar_t) && nrow(ybar_t) > 1L - if (vec_call) { - if (ncol(ybar_t) != 2L) - stop("When 'ybar_t' is a matrix it must have exactly 2 columns") - N <- nrow(ybar_t) - if (!is.list(S_t) || length(S_t) != N) - stop("When 'ybar_t' is a matrix, 'S_t' must be a list of the same length") - if (design %in% c('controlled', 'external')) { - if (is.null(ybar_c) || !is.matrix(ybar_c) || nrow(ybar_c) != N || - ncol(ybar_c) != 2L) - stop("When 'ybar_t' is a matrix, 'ybar_c' must be a matrix with the same number of rows") - if (!is.list(S_c) || length(S_c) != N) - stop("When 'ybar_t' is a matrix, 'S_c' must be a list of the same length") - } - } else { - N <- 1L - # Coerce scalar ybar_t to length-2 vector - if (!is.numeric(ybar_t) || length(ybar_t) != 2L || any(is.na(ybar_t))) - stop("'ybar_t' must be a numeric vector of length 2 or a matrix with 2 columns") - if (!is.matrix(S_t) || !is.numeric(S_t) || nrow(S_t) != 2L || ncol(S_t) != 2L) - stop("'S_t' must be a 2x2 numeric matrix (or a list for vectorised call)") - # Wrap as list for uniform handling below - ybar_t <- matrix(ybar_t, nrow = 1L) - S_t <- list(S_t) - if (design %in% c('controlled', 'external')) { - if (!is.numeric(ybar_c) || length(ybar_c) != 2L || any(is.na(ybar_c))) - stop("'ybar_c' must be a numeric vector of length 2") - if (!is.matrix(S_c) || !is.numeric(S_c) || nrow(S_c) != 2L || ncol(S_c) != 2L) - stop("'S_c' must be a 2x2 numeric matrix") - ybar_c <- matrix(ybar_c, nrow = 1L) - S_c <- list(S_c) - } - } - - if (prior == 'N-Inv-Wishart') { - for (nm in c('kappa0_t', 'nu0_t')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val <= 0) - stop(paste0("'", nm, "' must be a single positive numeric for NIW prior")) - } - if (is.null(mu0_t) || !is.numeric(mu0_t) || length(mu0_t) != 2L) - stop("'mu0_t' must be a length-2 numeric vector for NIW prior") - if (is.null(Lambda0_t) || !is.matrix(Lambda0_t) || nrow(Lambda0_t) != 2L) - stop("'Lambda0_t' must be a 2x2 numeric matrix for NIW prior") - if (design %in% c('controlled', 'external')) { - for (nm in c('kappa0_c', 'nu0_c')) { - val <- get(nm) - if (is.null(val) || !is.numeric(val) || length(val) != 1L || - is.na(val) || val <= 0) - stop(paste0("'", nm, "' must be a single positive numeric for NIW prior")) - } - if (is.null(mu0_c) || !is.numeric(mu0_c) || length(mu0_c) != 2L) - stop("'mu0_c' must be a length-2 numeric vector for NIW prior") - if (is.null(Lambda0_c) || !is.matrix(Lambda0_c) || nrow(Lambda0_c) != 2L) - stop("'Lambda0_c' must be a 2x2 numeric matrix for NIW prior") - } - } - - if (design == 'uncontrolled') { - if (is.null(r) || !is.numeric(r) || length(r) != 1L || is.na(r) || r <= 0) - stop("'r' must be a single positive numeric when design = 'uncontrolled'") - if (is.null(mu0_c) || !is.numeric(mu0_c) || length(mu0_c) != 2L) - stop("'mu0_c' must be a length-2 numeric vector when design = 'uncontrolled'") - } - - if (design == 'external') { - has_ext_t <- !is.null(ne_t) && !is.null(alpha0e_t) && - !is.null(bar_ye_t) && !is.null(se_t) - has_ext_c <- !is.null(ne_c) && !is.null(alpha0e_c) && - !is.null(bar_ye_c) && !is.null(se_c) - if (!has_ext_t && !has_ext_c) - stop(paste0("For design = 'external', at least one complete set of ", - "external data must be provided")) - if (!is.null(ne_t)) ne_t <- as.integer(ne_t) - if (!is.null(ne_c)) ne_c <- as.integer(ne_c) - # Vague prior with external design: NIW hyperparameters must not be provided - if (prior == 'vague') { - niw_args <- c('kappa0_t', 'nu0_t', 'mu0_t', 'Lambda0_t', - 'kappa0_c', 'nu0_c', 'mu0_c', 'Lambda0_c') - for (nm in niw_args) { - if (!is.null(get(nm))) - warning(paste0("'", nm, "' is ignored when prior = 'vague'")) - } - } - } - - if (!is.character(CalcMethod) || length(CalcMethod) != 1L || - !CalcMethod %in% c('MC', 'MM')) - stop("'CalcMethod' must be either 'MC' or 'MM'") - - # nMC validation: required for CalcMethod = 'MC', optional for CalcMethod = 'MM' - if (CalcMethod == 'MC') { - if (is.null(nMC)) - stop("'nMC' must be non-NULL when CalcMethod = 'MC'") - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) - stop("'nMC' must be a single positive integer") - nMC <- as.integer(nMC) - } else { - # CalcMethod == 'MM': nMC may be NULL or a positive integer - if (!is.null(nMC)) { - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) - stop("'nMC' must be a single positive integer or NULL") - nMC <- as.integer(nMC) - } - } - - # --------------------------------------------------------------------------- - # Section 2: Posterior hyperparameter helpers - # - # Each helper accepts a single (ybar_k, S_k) pair and returns list(df, mu_n, V). - # V is the posterior scale matrix (prob = 'posterior') or the single- - # observation predictive scale matrix (prob = 'predictive'); for the - # predictive mean of m_k observations it is further divided by m_k in - # Section 3. - # --------------------------------------------------------------------------- - - use_pred <- (prob == 'predictive') - - # NIW posterior update - .niw_post <- function(n_k, ybar_k, S_k, kappa0, nu0, mu0, Lambda0, - for_predictive = FALSE) { - kappa_n <- kappa0 + n_k - nu_n <- nu0 + n_k - mu_n <- (kappa0 * mu0 + n_k * ybar_k) / kappa_n - Lambda_n <- Lambda0 + S_k + - (kappa0 * n_k / kappa_n) * tcrossprod(ybar_k - mu0) - df <- nu_n - 1L - V <- if (for_predictive) { - ((1 + kappa_n) / kappa_n) * Lambda_n / (nu_n - 1L) - } else { - Lambda_n / (kappa_n * (nu_n - 1L)) - } - list(df = df, mu_n = mu_n, V = V) - } - - # Vague posterior update - .vague_post <- function(n_k, ybar_k, S_k, for_predictive = FALSE) { - df <- n_k - 2L - V <- if (for_predictive) { - ((1 + n_k) / n_k) * S_k / (n_k - 2L) - } else { - S_k / (n_k * (n_k - 2L)) - } - list(df = df, mu_n = ybar_k, V = V) - } - - # Vague power prior then PoC update (Corollary 2 of Huang et al., 2025) - .vague_ext_post <- function(n_k, ybar_k, S_k, - n_e, alpha0e, ybar_e, S_e, - for_predictive = FALSE) { - kappa_n <- alpha0e * n_e + n_k - nu_n <- alpha0e * n_e + n_k - 1L - mu_n <- (alpha0e * n_e * ybar_e + n_k * ybar_k) / kappa_n - Lambda_n <- alpha0e * S_e + S_k + - (alpha0e * n_e * n_k / kappa_n) * tcrossprod(ybar_k - ybar_e) - df <- nu_n - 1L - V <- if (for_predictive) { - ((1 + kappa_n) / kappa_n) * Lambda_n / (nu_n - 1L) - } else { - Lambda_n / (kappa_n * (nu_n - 1L)) - } - list(df = df, mu_n = mu_n, V = V) - } - - # NIW power prior then PoC update (Theorem 5) - .niw_ext_post <- function(n_k, ybar_k, S_k, kappa0, nu0, mu0, Lambda0, - n_e, alpha0e, ybar_e, S_e, - for_predictive = FALSE) { - kappa_e <- alpha0e * n_e + kappa0 - nu_e <- alpha0e * n_e + nu0 - mu_e <- (alpha0e * n_e * ybar_e + kappa0 * mu0) / kappa_e - Lambda_e <- alpha0e * S_e + Lambda0 + - (kappa0 * alpha0e * n_e / kappa_e) * tcrossprod(mu0 - ybar_e) - .niw_post(n_k, ybar_k, S_k, - kappa0 = kappa_e, nu0 = nu_e, - mu0 = mu_e, Lambda0 = Lambda_e, - for_predictive = for_predictive) - } - - # Pre-compute effective external hyperparameters (scalar, done once) - if (design == 'external') { - if (prior == 'N-Inv-Wishart') { - if (!is.null(ne_t)) { - kappa_e_t <- alpha0e_t * ne_t + kappa0_t - nu_e_t <- alpha0e_t * ne_t + nu0_t - mu_e_t <- (alpha0e_t * ne_t * bar_ye_t + kappa0_t * mu0_t) / kappa_e_t - Lambda_e_t <- alpha0e_t * se_t + Lambda0_t + - (kappa0_t * alpha0e_t * ne_t / kappa_e_t) * tcrossprod(mu0_t - bar_ye_t) - } - if (!is.null(ne_c)) { - kappa_e_c <- alpha0e_c * ne_c + kappa0_c - nu_e_c <- alpha0e_c * ne_c + nu0_c - mu_e_c <- (alpha0e_c * ne_c * bar_ye_c + kappa0_c * mu0_c) / kappa_e_c - Lambda_e_c <- alpha0e_c * se_c + Lambda0_c + - (kappa0_c * alpha0e_c * ne_c / kappa_e_c) * tcrossprod(mu0_c - bar_ye_c) - } - } - # For vague prior, external hyperparameters are computed per observation - # inside the loop via .vague_ext_post() - } - - # --------------------------------------------------------------------------- - # Section 3: MM helpers (constructed only when CalcMethod = 'MM') - # --------------------------------------------------------------------------- - - # MM: moment-matching parameters for the difference of two bivariate t's - .mm_general <- function(mu1_loc, V1, nu1, mu2_loc, V2, nu2) { - beta1 <- nu1 / (nu1 - 2) - beta2 <- nu2 / (nu2 - 2) - alpha1 <- nu1 ^ 2 / ((nu1 - 2) * (nu1 - 4)) - alpha2 <- nu2 ^ 2 / ((nu2 - 2) * (nu2 - 4)) - gamma <- 2 * nu1 * nu2 / ((nu1 - 2) * (nu2 - 2)) - - Vsum <- V1 * beta1 + V2 * beta2 - R_chol <- tryCatch(chol(Vsum), error = function(e) NULL) - A <- if (!is.null(R_chol)) chol2inv(R_chol) else solve(Vsum) - - AV1 <- A %*% V1 - AV2 <- A %*% V2 - tr_AV1 <- sum(diag(AV1)) - tr_AV2 <- sum(diag(AV2)) - tr_AV1V1 <- sum(diag(AV1 %*% AV1)) - tr_AV2V2 <- sum(diag(AV2 %*% AV2)) - tr_AV1V2 <- sum(diag(AV1 %*% AV2)) - - p <- length(mu1_loc) - Qm <- (alpha1 * (tr_AV1 ^ 2 + 2 * tr_AV1V1) + - alpha2 * (tr_AV2 ^ 2 + 2 * tr_AV2V2) + - gamma * (tr_AV1 * tr_AV2 + 2 * tr_AV1V2)) / (p * (p + 2)) - - nu_star <- (2 - 4 * Qm) / (1 - Qm) - Sigma_star <- Vsum * (nu_star - 2) / nu_star - - list(mu_diff = mu1_loc - mu2_loc, Sigma_star = Sigma_star, - nu_star = nu_star) - } - - # MM: rectangular region probability via direct lower/upper bounds - .rect_prob <- function(lo1, hi1, lo2, hi2, mm) { - sig <- mm$Sigma_star - mu_d <- mm$mu_diff - # Single pmvt call with explicit lower and upper bounds (4x faster than - # manual inclusion-exclusion with four separate pmvt calls) - val <- as.numeric(mvtnorm::pmvt( - lower = c(lo1 - mu_d[1L], lo2 - mu_d[2L]), - upper = c(hi1 - mu_d[1L], hi2 - mu_d[2L]), - delta = c(0, 0), sigma = sig, df = as.integer(round(mm$nu_star)) - )) - pmax(val, 0) - } - - # --------------------------------------------------------------------------- - # Section 4: Pre-generate raw MC variates (shared across all N observations) - # - # df is observation-invariant (depends only on n_k and prior hyperparameters). - # Z and W are drawn once and reused for every observation in the vectorised - # call, with only the Cholesky factor of V_k changing per observation. - # --------------------------------------------------------------------------- - - # Compute df (scalar, same for all observations in a vectorised call) - if (prior == 'N-Inv-Wishart') { - df_t <- as.integer(nu0_t + n_t - 1L) - if (design %in% c('controlled', 'external')) df_c <- as.integer(nu0_c + n_c - 1L) - if (design == 'uncontrolled') df_c <- df_t - } else { - df_t <- n_t - 2L - if (design %in% c('controlled', 'external')) df_c <- n_c - 2L - if (design == 'uncontrolled') df_c <- df_t - } - if (design == 'external') { - if (prior == 'N-Inv-Wishart') { - if (!is.null(ne_t)) df_t <- as.integer(nu_e_t + n_t - 1L) - if (!is.null(ne_c)) df_c <- as.integer(nu_e_c + n_c - 1L) - } else { - # Vague prior: df = (alpha0e * ne + n) - 1 - 1 = alpha0e * ne + n - 2 - if (!is.null(ne_t)) df_t <- as.integer(alpha0e_t * ne_t + n_t - 2L) - if (!is.null(ne_c)) df_c <- as.integer(alpha0e_c * ne_c + n_c - 2L) - } - } - - # Check MM feasibility - use_mm <- (CalcMethod == 'MM') - if (use_mm && (df_t <= 4L || df_c <= 4L)) { - warning( - "MM method requires df > 4 for both groups (df_t = ", df_t, - ", df_c = ", df_c, "). Falling back to CalcMethod = 'MC'." - ) - use_mm <- FALSE - } - - # Pre-generate MC raw variates (only for MC path; also used as fallback for MM) - if (!use_mm) { - if (is.null(nMC)) - stop(paste0("'nMC' must be a positive integer when CalcMethod = 'MM' falls ", - "back to MC (nu_k <= 4)")) - Z_t <- matrix(rnorm(nMC * 2L), nrow = nMC, ncol = 2L) - W_t <- rchisq(nMC, df = df_t) - sc_t <- sqrt(W_t / df_t) - - Z_c <- matrix(rnorm(nMC * 2L), nrow = nMC, ncol = 2L) - W_c <- rchisq(nMC, df = df_c) - sc_c <- sqrt(W_c / df_c) - } - - # --------------------------------------------------------------------------- - # Section 5: Region probability computation for N observations - # --------------------------------------------------------------------------- - - n_regions <- if (prob == 'posterior') 9L else 4L - Pr_R_mat <- matrix(0, nrow = N, ncol = n_regions) - - # Cut-points (fixed across all observations) - if (prob == 'posterior') { - cuts_t <- c(-Inf, theta_MAV1, theta_TV1, Inf) - cuts_c <- c(-Inf, theta_MAV2, theta_TV2, Inf) - } else { - cuts_t <- c(-Inf, theta_NULL1, Inf) - cuts_c <- c(-Inf, theta_NULL2, Inf) - } - - for (i in seq_len(N)) { - - yb_t <- ybar_t[i, ] - S_t_i <- S_t[[i]] - - # Posterior parameters for group 1 - if (design == 'external' && !is.null(ne_t) && prior == 'N-Inv-Wishart') { - post_t <- .niw_post(n_t, yb_t, S_t_i, - kappa0 = kappa_e_t, nu0 = nu_e_t, - mu0 = mu_e_t, Lambda0 = Lambda_e_t, - for_predictive = use_pred) - } else if (design == 'external' && !is.null(ne_t) && prior == 'vague') { - post_t <- .vague_ext_post(n_t, yb_t, S_t_i, - n_e = ne_t, alpha0e = alpha0e_t, - ybar_e = bar_ye_t, S_e = se_t, - for_predictive = use_pred) - } else if (prior == 'N-Inv-Wishart') { - post_t <- .niw_post(n_t, yb_t, S_t_i, - kappa0 = kappa0_t, nu0 = nu0_t, - mu0 = mu0_t, Lambda0 = Lambda0_t, - for_predictive = use_pred) - } else { - post_t <- .vague_post(n_t, yb_t, S_t_i, for_predictive = use_pred) - } - - # Posterior parameters for group 2 - if (design == 'uncontrolled') { - post_c <- list(df = post_t$df, mu_n = mu0_c, V = r * post_t$V) - } else if (design == 'external' && !is.null(ne_c) && prior == 'N-Inv-Wishart') { - yb_c <- ybar_c[i, ] - S_c_i <- S_c[[i]] - post_c <- .niw_post(n_c, yb_c, S_c_i, - kappa0 = kappa_e_c, nu0 = nu_e_c, - mu0 = mu_e_c, Lambda0 = Lambda_e_c, - for_predictive = use_pred) - } else if (design == 'external' && !is.null(ne_c) && prior == 'vague') { - yb_c <- ybar_c[i, ] - S_c_i <- S_c[[i]] - post_c <- .vague_ext_post(n_c, yb_c, S_c_i, - n_e = ne_c, alpha0e = alpha0e_c, - ybar_e = bar_ye_c, S_e = se_c, - for_predictive = use_pred) - } else if (design == 'external' && prior == 'vague') { - # External design, vague prior, no external data for this group - yb_c <- ybar_c[i, ] - S_c_i <- S_c[[i]] - post_c <- .vague_post(n_c, yb_c, S_c_i, for_predictive = use_pred) - } else if (prior == 'N-Inv-Wishart') { - yb_c <- ybar_c[i, ] - S_c_i <- S_c[[i]] - post_c <- .niw_post(n_c, yb_c, S_c_i, - kappa0 = kappa0_c, nu0 = nu0_c, - mu0 = mu0_c, Lambda0 = Lambda0_c, - for_predictive = use_pred) - } else { - yb_c <- ybar_c[i, ] - S_c_i <- S_c[[i]] - post_c <- .vague_post(n_c, yb_c, S_c_i, for_predictive = use_pred) - } - - if (!use_mm) { - - # ----------------------------------------------------------------------- - # MC path: re-use pre-generated Z and W; only chol(V) changes per obs - # ----------------------------------------------------------------------- - - V_t_use <- if (use_pred) post_t$V / m_t else post_t$V - V_c_use <- if (use_pred) post_c$V / m_c else post_c$V - - R_chol_t <- chol(V_t_use + diag(1e-10, 2L)) - R_chol_c <- chol(V_c_use + diag(1e-10, 2L)) - - mu_t <- sweep(Z_t %*% R_chol_t, 1L, sc_t, '/') + - matrix(post_t$mu_n, nrow = nMC, ncol = 2L, byrow = TRUE) - mu_c <- sweep(Z_c %*% R_chol_c, 1L, sc_c, '/') + - matrix(post_c$mu_n, nrow = nMC, ncol = 2L, byrow = TRUE) - - theta1 <- mu_t[, 1L] - mu_c[, 1L] - theta2 <- mu_t[, 2L] - mu_c[, 2L] - - if (prob == 'posterior') { - r1 <- 3L - as.integer(theta1 > theta_MAV1) - - as.integer(theta1 > theta_TV1) - r2 <- 3L - as.integer(theta2 > theta_MAV2) - - as.integer(theta2 > theta_TV2) - region <- (r1 - 1L) * 3L + r2 - Pr_R_mat[i, ] <- tabulate(region, nbins = 9L) / nMC - } else { - r1 <- 2L - as.integer(theta1 > theta_NULL1) - r2 <- 2L - as.integer(theta2 > theta_NULL2) - region <- (r1 - 1L) * 2L + r2 - Pr_R_mat[i, ] <- tabulate(region, nbins = 4L) / nMC - } - - } else { - - # ----------------------------------------------------------------------- - # MM path: moment-matching + mvtnorm::pmvt per observation - # ----------------------------------------------------------------------- - - V_t_use <- if (use_pred) post_t$V / m_t else post_t$V - V_c_use <- if (use_pred) post_c$V / m_c else post_c$V - - mm <- .mm_general(post_t$mu_n, V_t_use, post_t$df, - post_c$mu_n, V_c_use, post_c$df) - - n_bands <- length(cuts_t) - 1L - Pr_R <- numeric(n_regions) - idx <- 1L - for (ii in n_bands:1L) { - for (jj in n_bands:1L) { - Pr_R[idx] <- .rect_prob(cuts_t[ii], cuts_t[ii + 1L], - cuts_c[jj], cuts_c[jj + 1L], mm) - idx <- idx + 1L - } - } - # Normalise to correct for pmvt rounding - Pr_R_mat[i, ] <- Pr_R / sum(Pr_R) - } - } - - # --------------------------------------------------------------------------- - # Section 6: Return - # --------------------------------------------------------------------------- - - region_names <- paste0("R", seq_len(n_regions)) - colnames(Pr_R_mat) <- region_names - - if (vec_call) { - # Vectorised call: return N x n_regions matrix - Pr_R_mat - } else { - # Scalar call: return named vector (original behaviour) - out <- Pr_R_mat[1L, ] - names(out) <- region_names - out - } -} diff --git a/R/pbetabinomdiff.R b/R/pbetabinomdiff.R index de996a8..7ab0118 100644 --- a/R/pbetabinomdiff.R +++ b/R/pbetabinomdiff.R @@ -1,128 +1,87 @@ -#' Cumulative Distribution Function of the Difference Between Two -#' Independent Beta-Binomial Proportions +#' Distribution function of the difference of two Beta-binomial proportions #' -#' Calculates the cumulative distribution function (CDF) of the difference -#' between two independent Beta-Binomial proportions by exact enumeration. -#' Specifically, computes \eqn{P((Y_t / m_t) - (Y_c / m_c) \le q)} or -#' \eqn{P((Y_t / m_t) - (Y_c / m_c) > q)}, where -#' \eqn{Y_j \sim \mathrm{BetaBinomial}(m_j, \alpha_j, \beta_j)} for -#' \eqn{j \in \{t, c\}}. +#' Computes \eqn{\Pr(Y_t / m_t - Y_c / m_c \le q)} (or the upper tail +#' \eqn{\Pr(Y_t / m_t - Y_c / m_c > q)}) for independent +#' \eqn{Y_t \sim \textrm{Beta-binomial}(m_t, a_t, b_t)} and +#' \eqn{Y_c \sim \textrm{Beta-binomial}(m_c, a_c, b_c)}. This is the posterior +#' predictive probability for the difference in response proportions of a +#' future study with \eqn{m_t} and \eqn{m_c} subjects. #' -#' @param q A numeric scalar representing the quantile threshold for the -#' difference in proportions. -#' @param m_t A positive integer giving the number of future patients in the -#' treatment group. -#' @param m_c A positive integer giving the number of future patients in the -#' control group. -#' @param alpha_t A positive numeric scalar giving the first shape parameter -#' of the Beta mixing distribution for the treatment group. -#' @param alpha_c A positive numeric scalar giving the first shape parameter -#' of the Beta mixing distribution for the control group. -#' @param beta_t A positive numeric scalar giving the second shape parameter -#' of the Beta mixing distribution for the treatment group. -#' @param beta_c A positive numeric scalar giving the second shape parameter -#' of the Beta mixing distribution for the control group. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P((Y_t / m_t) - (Y_c / m_c) \le q)}, otherwise -#' \eqn{P((Y_t / m_t) - (Y_c / m_c) > q)}. +#' The probability is an exact finite sum. The probability mass functions are +#' computed on the log scale, so large values of \eqn{m_t} and \eqn{m_c} do not +#' cause overflow. Each difference is compared with \code{q} after a single +#' division of the exact integer numerator \eqn{m_c Y_t - m_t Y_c} by +#' \eqn{m_t m_c}, so differences that are mathematically equal to a decimal +#' \code{q} are classified correctly (they belong to the lower tail). #' -#' @return A numeric scalar in \code{[0, 1]}. +#' @param q Numeric vector of quantiles. +#' @param m_t,m_c Numbers of future subjects in the treatment and control +#' groups (whole numbers of at least 1). +#' @param a_t,b_t Positive shape parameters of the treatment group. +#' @param a_c,b_c Positive shape parameters of the control group. +#' @param lower.tail Logical; if \code{TRUE} (default), probabilities are +#' \eqn{\Pr(Y_t / m_t - Y_c / m_c \le q)}, otherwise +#' \eqn{\Pr(Y_t / m_t - Y_c / m_c > q)}. #' -#' @details -#' The probability mass function of -#' \eqn{Y_j \sim \mathrm{BetaBinomial}(m_j, \alpha_j, \beta_j)} is: -#' \deqn{P(Y_j = k) = \binom{m_j}{k} -#' \frac{B(k + \alpha_j,\; m_j - k + \beta_j)}{B(\alpha_j, \beta_j)}, -#' \quad k = 0, \ldots, m_j} -#' where \eqn{B(\cdot, \cdot)} is the Beta function. -#' -#' The exact CDF is obtained by enumerating all -#' \eqn{(m_t + 1)(m_c + 1)} outcome combinations and summing the joint -#' probabilities for which the proportion difference satisfies the specified -#' condition. Computation time therefore grows quadratically in \eqn{m_t} and -#' \eqn{m_c}; for large future sample sizes consider a normal approximation. -#' -#' The Beta-Binomial distribution arises when the success probability in a -#' Binomial model follows a Beta prior, making it appropriate for -#' posterior predictive calculations in Bayesian binary-endpoint trials. +#' @return A numeric vector of probabilities. The arguments \code{q}, +#' \code{a_t}, \code{b_t}, \code{a_c} and \code{b_c} are recycled to a common +#' length; each must have length 1 or the common length. #' +#' @family distributions #' @examples -#' # P((Y_t/12) - (Y_c/12) > 0.2) with symmetric Beta(0.5, 0.5) priors -#' pbetabinomdiff(0.2, 12, 12, 0.5, 0.5, 0.5, 0.5, lower.tail = FALSE) -#' -#' # P((Y_t/20) - (Y_c/15) > 0.1) with different future sample sizes -#' pbetabinomdiff(0.1, 20, 15, 1, 1, 1, 1, lower.tail = FALSE) -#' -#' # P((Y_t/10) - (Y_c/10) > 0) with informative priors -#' pbetabinomdiff(0, 10, 10, 2, 3, 3, 2, lower.tail = FALSE) -#' -#' # Lower tail: P((Y_t/15) - (Y_c/15) <= 0.05) with vague priors -#' pbetabinomdiff(0.05, 15, 15, 1, 1, 1, 1, lower.tail = TRUE) -#' +#' # Predictive probability that the future difference exceeds 0, with +#' # Jeffreys priors, 7/12 versus 4/12 responders and 20 future subjects per +#' # group +#' pbetabinomdiff(0, m_t = 20, a_t = 7.5, b_t = 5.5, m_c = 20, a_c = 4.5, +#' b_c = 8.5, lower.tail = FALSE) #' @export -pbetabinomdiff <- function(q, m_t, m_c, alpha_t, alpha_c, beta_t, beta_c, +pbetabinomdiff <- function(q, m_t, a_t, b_t, m_c, a_c, b_c, lower.tail = TRUE) { - - # --- Input validation --- - if (!is.numeric(q) || length(q) != 1L || is.na(q)) { - stop("'q' must be a single numeric value") - } - - if (!is.numeric(m_t) || length(m_t) != 1L || is.na(m_t) || - m_t != floor(m_t) || m_t < 1L) { - stop("'m_t' must be a single positive integer") - } - - if (!is.numeric(m_c) || length(m_c) != 1L || is.na(m_c) || - m_c != floor(m_c) || m_c < 1L) { - stop("'m_c' must be a single positive integer") - } - - if (!is.numeric(alpha_t) || length(alpha_t) != 1L || is.na(alpha_t) || alpha_t <= 0) { - stop("'alpha_t' must be a single positive numeric value") - } - - if (!is.numeric(alpha_c) || length(alpha_c) != 1L || is.na(alpha_c) || alpha_c <= 0) { - stop("'alpha_c' must be a single positive numeric value") - } - - if (!is.numeric(beta_t) || length(beta_t) != 1L || is.na(beta_t) || beta_t <= 0) { - stop("'beta_t' must be a single positive numeric value") - } - - if (!is.numeric(beta_c) || length(beta_c) != 1L || is.na(beta_c) || beta_c <= 0) { - stop("'beta_c' must be a single positive numeric value") - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # --- Compute Beta-Binomial PMFs --- - # PMF for Y_t ~ BetaBinomial(m_t, alpha_t, beta_t) + check_numeric(q, "q", len = NULL) + check_numeric(m_t, "m_t", lower = 1, integer = TRUE) + check_numeric(m_c, "m_c", lower = 1, integer = TRUE) + check_numeric(a_t, "a_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(b_t, "b_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(a_c, "a_c", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(b_c, "b_c", len = NULL, lower = 0, lower_open = TRUE) + check_flag(lower.tail, "lower.tail") + args <- recycle_common(list(q = q, a_t = a_t, b_t = b_t, a_c = a_c, + b_c = b_c)) + m_t <- round(m_t) + m_c <- round(m_c) k_t <- 0:m_t - dbetabinom_t <- choose(m_t, k_t) * - beta(k_t + alpha_t, m_t - k_t + beta_t) / beta(alpha_t, beta_t) - - # PMF for Y_c ~ BetaBinomial(m_c, alpha_c, beta_c) k_c <- 0:m_c - dbetabinom_c <- choose(m_c, k_c) * - beta(k_c + alpha_c, m_c - k_c + beta_c) / beta(alpha_c, beta_c) - - # --- Enumerate all (m_t+1) x (m_c+1) outcome combinations --- - # Proportion difference: (k_t/m_t) - (k_c/m_c) = (m_c*k_t - m_t*k_c) / (m_t*m_c) - # Use integer arithmetic via outer() to avoid floating-point comparison issues. - diff_numer <- outer(m_c * k_t, m_t * k_c, "-") # numerator matrix (m_c*k_t - m_t*k_c) - denom <- m_t * m_c - - if (lower.tail) { - I <- (diff_numer / denom <= q) - } else { - I <- (diff_numer / denom > q) + # Numerators m_c * k_t of the differences on the common denominator + # m_t * m_c (exact in double precision) + num_t <- m_c * k_t + den <- m_t * m_c + out <- numeric(length(args$q)) + for (i in seq_along(out)) { + # The differences lie in [-1, 1], so values of q outside [-2, 2] give + # the same result as -2 or 2 (and would lose precision below) + q_i <- min(max(args$q[i], -2), 2) + # For each k_t, the largest k_c with (m_c * k_t - m_t * k_c) / den > q_i. + # The difference decreases in k_c, so the estimate below is within one of + # the exact value; the three neighbouring candidates are checked with the + # exact comparison. + k_est <- floor((num_t - q_i * den) / m_t) + k_max <- rep(-1, length(k_t)) + for (shift in c(-1, 0, 1)) { + cand <- k_est + shift + ok <- (num_t - m_t * cand) / den > q_i + k_max <- ifelse(ok & cand > k_max, cand, k_max) + } + k_max <- pmin(pmax(k_max, -1), m_c) + p_t <- dbetabinom(k_t, m_t, args$a_t[i], args$b_t[i]) + p_c <- dbetabinom(k_c, m_c, args$a_c[i], args$b_c[i]) + if (lower.tail) { + # P(Y_c >= k_max + 1), with P(Y_c >= m_c + 1) = 0 + tail_c <- c(rev(cumsum(rev(p_c))), 0) + } else { + # P(Y_c <= k_max), with P(Y_c <= -1) = 0 + tail_c <- c(0, cumsum(p_c)) + } + out[i] <- sum(p_t * tail_c[k_max + 2]) } - - # Sum joint probabilities over outcome pairs satisfying the condition - result <- as.numeric(crossprod(dbetabinom_t[row(I)[I]], dbetabinom_c[col(I)[I]])) - - return(result) + pmin(pmax(out, 0), 1) } diff --git a/R/pbetadiff.R b/R/pbetadiff.R index 2b46be4..42a3405 100644 --- a/R/pbetadiff.R +++ b/R/pbetadiff.R @@ -1,99 +1,58 @@ -#' Cumulative Distribution Function of the Difference Between Two -#' Independent Beta Variables -#' -#' Calculates the cumulative distribution function (CDF) of the difference -#' between two independent Beta-distributed random variables. Specifically, -#' computes \eqn{P(\pi_t - \pi_c \le q)} or \eqn{P(\pi_t - \pi_c > q)}, where -#' \eqn{\pi_j \sim \mathrm{Beta}(\alpha_j, \beta_j)} for -#' \eqn{j \in \{t, c\}}. -#' -#' @param q A numeric scalar in \code{[-1, 1]} representing the quantile -#' threshold for the difference in proportions. -#' @param alpha_t A positive numeric scalar giving the first shape parameter -#' of the Beta distribution for the treatment group. -#' @param alpha_c A positive numeric scalar giving the first shape parameter -#' of the Beta distribution for the control group. -#' @param beta_t A positive numeric scalar giving the second shape parameter -#' of the Beta distribution for the treatment group. -#' @param beta_c A positive numeric scalar giving the second shape parameter -#' of the Beta distribution for the control group. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(\pi_t - \pi_c \le q)}, otherwise -#' \eqn{P(\pi_t - \pi_c > q)}. -#' -#' @return A numeric scalar in \code{[0, 1]}. -#' -#' @details -#' The upper-tail probability is obtained via the convolution formula: -#' \deqn{P(\pi_t - \pi_c > q) -#' = \int_0^1 F_{\mathrm{Beta}(\alpha_c, \beta_c)}(x - q)\, -#' f_{\mathrm{Beta}(\alpha_t, \beta_t)}(x)\, dx} -#' where \eqn{f_{\mathrm{Beta}(\alpha_t, \beta_t)}} is the density of -#' \eqn{\pi_t} and \eqn{F_{\mathrm{Beta}(\alpha_c, \beta_c)}} is the CDF of -#' \eqn{\pi_c}. Boundary cases are handled automatically by \code{pbeta} -#' (\eqn{0} for \eqn{x - q \le 0}, \eqn{1} for \eqn{x - q \ge 1}), so -#' integrating over \code{[0, 1]} is safe. -#' -#' This single-integral convolution replaces an equivalent double-integral -#' formulation based on Appell's F1 hypergeometric function, yielding the -#' same result with lower computational cost because both \code{pbeta} and -#' \code{dbeta} are implemented in compiled C code. -#' +#' Distribution function of the difference of two Beta variables +#' +#' Computes \eqn{\Pr(\pi_t - \pi_c \le q)} (or the upper tail +#' \eqn{\Pr(\pi_t - \pi_c > q)}) for independent +#' \eqn{\pi_t \sim \textrm{Beta}(a_t, b_t)} and +#' \eqn{\pi_c \sim \textrm{Beta}(a_c, b_c)}. This is the posterior probability +#' used for a single binary endpoint. +#' +#' The upper tail is computed as +#' \deqn{\Pr(\pi_t - \pi_c > q) = \Pr(\pi_c < -q) + +#' \int f_c(x) \Pr(\pi_t > x + q) \, dx,} +#' where the integral runs over the values of \eqn{x} with +#' \eqn{0 \le x + q \le 1}, and the first term is zero for +#' \eqn{q \ge 0}. The integral is evaluated by adaptive Gauss-Kronrod +#' quadrature (the QUADPACK routine used by \code{\link[stats]{integrate}}), +#' with the range split at quantiles of both Beta distributions so that +#' concentrated distributions are integrated accurately. When the density of +#' \eqn{\pi_c} is unbounded at 0 (\eqn{a_c < 1}) or at 1 (\eqn{b_c < 1}), the +#' integral on that side of the median of \eqn{\pi_c} is evaluated in the +#' variable \eqn{s = x^{a_c}} or \eqn{s = (1 - x)^{b_c}}, in which the +#' integrand is bounded. The lower tail is +#' computed directly from the same formula with the roles of the two groups +#' exchanged, so both tails are accurate near 0. +#' +#' @param q Numeric vector of quantiles. +#' @param a_t,b_t Positive shape parameters of the treatment group. +#' @param a_c,b_c Positive shape parameters of the control group. +#' @param lower.tail Logical; if \code{TRUE} (default), probabilities are +#' \eqn{\Pr(\pi_t - \pi_c \le q)}, otherwise \eqn{\Pr(\pi_t - \pi_c > q)}. +#' +#' @return A numeric vector of probabilities. All arguments except +#' \code{lower.tail} are recycled to a common length; each must have length +#' 1 or the common length. +#' +#' @family distributions #' @examples -#' # P(pi_t - pi_c > 0.2) with symmetric Beta(0.5, 0.5) priors -#' pbetadiff(0.2, 0.5, 0.5, 0.5, 0.5, lower.tail = FALSE) -#' -#' # P(pi_t - pi_c > -0.1) with informative priors -#' pbetadiff(-0.1, 2, 1, 3, 4, lower.tail = FALSE) -#' -#' # P(pi_t - pi_c > 0) with equal priors -- should be approximately 0.5 -#' pbetadiff(0, 1, 1, 1, 1, lower.tail = FALSE) -#' -#' # Lower tail: P(pi_t - pi_c <= 0.1) with symmetric priors -#' pbetadiff(0.1, 2, 2, 2, 2, lower.tail = TRUE) -#' -#' @importFrom stats dbeta integrate pbeta +#' # Posterior probability that the response rate difference exceeds 0.1, +#' # with Jeffreys priors and 7/12 versus 4/12 responders +#' pbetadiff(0.1, a_t = 7.5, b_t = 5.5, a_c = 4.5, b_c = 8.5, +#' lower.tail = FALSE) #' @export -pbetadiff <- function(q, alpha_t, alpha_c, beta_t, beta_c, lower.tail = TRUE) { - - # --- Input validation --- - if (!is.numeric(q) || length(q) != 1L || is.na(q) || q < -1 || q > 1) { - stop("'q' must be a single numeric value in [-1, 1]") - } - - if (!is.numeric(alpha_t) || length(alpha_t) != 1L || is.na(alpha_t) || alpha_t <= 0) { - stop("'alpha_t' must be a single positive numeric value") - } - - if (!is.numeric(alpha_c) || length(alpha_c) != 1L || is.na(alpha_c) || alpha_c <= 0) { - stop("'alpha_c' must be a single positive numeric value") - } - - if (!is.numeric(beta_t) || length(beta_t) != 1L || is.na(beta_t) || beta_t <= 0) { - stop("'beta_t' must be a single positive numeric value") - } - - if (!is.numeric(beta_c) || length(beta_c) != 1L || is.na(beta_c) || beta_c <= 0) { - stop("'beta_c' must be a single positive numeric value") - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") +pbetadiff <- function(q, a_t, b_t, a_c, b_c, lower.tail = TRUE) { + check_numeric(q, "q", len = NULL) + check_numeric(a_t, "a_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(b_t, "b_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(a_c, "a_c", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(b_c, "b_c", len = NULL, lower = 0, lower_open = TRUE) + check_flag(lower.tail, "lower.tail") + args <- recycle_common(list(q = q, a_t = a_t, b_t = b_t, a_c = a_c, + b_c = b_c)) + if (lower.tail) { + # P(pi_t - pi_c <= q) = P(pi_c - pi_t >= -q), the upper tail with the + # groups exchanged (the distribution is continuous). + cpp_pbetadiff_upper(-args$q, args$a_c, args$b_c, args$a_t, args$b_t) + } else { + cpp_pbetadiff_upper(args$q, args$a_t, args$b_t, args$a_c, args$b_c) } - - # --- Compute P(X_t - X_c > q) via convolution --- - # Integrand: f_Beta(alpha_t, beta_t)(x) * F_Beta(alpha_c, beta_c)(x - q) - # pbeta handles x - q outside [0, 1] automatically. - result <- integrate( - function(x) pbeta(x - q, alpha_c, beta_c) * dbeta(x, alpha_t, beta_t), - lower = 0, - upper = 1 - )[["value"]] - - # Convert to lower tail if requested: - # lower.tail = TRUE -> P(X_t - X_c <= q) = 1 - P(X_t - X_c > q) - # lower.tail = FALSE -> P(X_t - X_c > q) - result <- lower.tail + c(1, -1)[lower.tail + 1] * result - - return(result) } diff --git a/R/plot.getgamma1bin.R b/R/plot.getgamma1bin.R deleted file mode 100644 index beb8ea3..0000000 --- a/R/plot.getgamma1bin.R +++ /dev/null @@ -1,187 +0,0 @@ -#' Plot Method for getgamma1bin Objects -#' -#' Displays calibration curves of marginal Go and NoGo probabilities against -#' the threshold grid \eqn{\gamma} for results returned by -#' \code{\link{getgamma1bin}}. -#' -#' The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -#' The y-axis represents the marginal probability: -#' \itemize{ -#' \item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -#' under the Go-calibration scenario (typically the Null scenario). -#' \item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -#' evaluated under the NoGo-calibration scenario (typically the -#' Alternative scenario). -#' } -#' -#' Horizontal reference lines are drawn at \code{target_go} and -#' \code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -#' thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -#' and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -#' with their values shown in the legend. -#' If either optimal threshold is \code{NA}, the corresponding point is omitted. -#' -#' @param x An object of class \code{getgamma1bin}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_point geom_hline annotate -#' scale_color_manual scale_linetype_manual scale_fill_manual -#' scale_x_continuous scale_y_continuous guides guide_legend -#' labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @importFrom stats setNames -#' @export -plot.getgamma1bin <- function(x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ...) { - - # --- Input validation --- - if (!inherits(x, "getgamma1bin")) { - stop("'x' must be an object of class 'getgamma1bin'") - } - - # --- Extract target values stored in x --- - target_go <- x$target_go - target_nogo <- x$target_nogo - - # --- Extract grid results --- - df <- x$grid_results - gamma_go <- x$gamma_go - gamma_nogo <- x$gamma_nogo - - # --- Reshape to long format --- - plot_long <- data.frame( - gamma = rep(df$gamma_grid, 2L), - prob = c(df$PrGo_grid, df$PrNoGo_grid), - Scenario = rep(c("Go", "NoGo"), each = nrow(df)) - ) - plot_long$Scenario <- factor(plot_long$Scenario, levels = c("Go", "NoGo")) - - # --- Axis limits --- - x_min <- min(df$gamma_grid) - x_max <- max(df$gamma_grid) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(df$gamma_grid, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Build data frame for optimal threshold points --- - # Points are placed at (gamma_go, PrGo_opt) and (gamma_nogo, PrNoGo_opt). - # The 'fill' aesthetic drives a separate legend with expression labels. - go_val <- if (is.na(gamma_go)) "NA" else sprintf("%.2f", gamma_go) - nogo_val <- if (is.na(gamma_nogo)) "NA" else sprintf("%.2f", gamma_nogo) - - pt_labels <- c( - paste0("gamma[go]==", go_val), - paste0("gamma[nogo]==", nogo_val) - ) - - pt_df <- data.frame( - gamma = c(gamma_go, gamma_nogo), - prob = c(x$PrGo_opt, x$PrNoGo_opt), - pt_col = c(col_go, col_nogo), - pt_grp = factor(pt_labels, levels = pt_labels) - ) - # Remove rows where the optimal threshold is NA - pt_df <- pt_df[!is.na(pt_df$gamma), ] - - # Named colour vector for scale_fill_manual - pt_col_vals <- stats::setNames(pt_df$pt_col, as.character(pt_df$pt_grp)) - - # --- Base plot --- - p <- ggplot2::ggplot(plot_long, - ggplot2::aes(x = gamma, y = prob, - color = Scenario, - linetype = Scenario)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Horizontal reference lines --- - p <- p + - ggplot2::geom_hline(yintercept = target_go, - color = col_go, linetype = "dotted", - linewidth = 1.5) + - ggplot2::geom_hline(yintercept = target_nogo, - color = col_nogo, linetype = "dotted", - linewidth = 1.5) - - # --- Optimal threshold points --- - if (nrow(pt_df) > 0L) { - p <- p + - ggplot2::geom_point( - data = pt_df, - mapping = ggplot2::aes(x = gamma, y = prob, fill = pt_grp), - color = pt_df$pt_col, - shape = 21, - size = 5, - stroke = 1.5, - inherit.aes = FALSE - ) + - ggplot2::scale_fill_manual( - values = pt_col_vals, - labels = lapply(names(pt_col_vals), function(lb) parse(text = lb)[[1L]]) - ) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = expression(gamma), - y = "Probability", - color = "Scenario", - linetype = "Scenario", - fill = "Optimal threshold" - ) + - ggplot2::guides( - color = ggplot2::guide_legend(order = 1), - linetype = ggplot2::guide_legend(order = 1), - fill = ggplot2::guide_legend(order = 2, - override.aes = list(size = 5)) - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.getgamma1cont.R b/R/plot.getgamma1cont.R deleted file mode 100644 index cb71677..0000000 --- a/R/plot.getgamma1cont.R +++ /dev/null @@ -1,187 +0,0 @@ -#' Plot Method for getgamma1cont Objects -#' -#' Displays calibration curves of marginal Go and NoGo probabilities against -#' the threshold grid \eqn{\gamma} for results returned by -#' \code{\link{getgamma1cont}}. -#' -#' The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -#' The y-axis represents the marginal probability: -#' \itemize{ -#' \item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -#' under the Go-calibration scenario (typically the Null scenario). -#' \item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -#' evaluated under the NoGo-calibration scenario (typically the -#' Alternative scenario). -#' } -#' -#' Horizontal reference lines are drawn at \code{target_go} and -#' \code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -#' thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -#' and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -#' with their values shown in the legend. -#' If either optimal threshold is \code{NA}, the corresponding point is omitted. -#' -#' @param x An object of class \code{getgamma1cont}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_point geom_hline annotate -#' scale_color_manual scale_linetype_manual scale_fill_manual -#' scale_x_continuous scale_y_continuous guides guide_legend -#' labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @importFrom stats setNames -#' @export -plot.getgamma1cont <- function(x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ...) { - - # --- Input validation --- - if (!inherits(x, "getgamma1cont")) { - stop("'x' must be an object of class 'getgamma1cont'") - } - - # --- Extract target values stored in x --- - target_go <- x$target_go - target_nogo <- x$target_nogo - - # --- Extract grid results --- - df <- x$grid_results - gamma_go <- x$gamma_go - gamma_nogo <- x$gamma_nogo - - # --- Reshape to long format --- - plot_long <- data.frame( - gamma = rep(df$gamma_grid, 2L), - prob = c(df$PrGo_grid, df$PrNoGo_grid), - Scenario = rep(c("Go", "NoGo"), each = nrow(df)) - ) - plot_long$Scenario <- factor(plot_long$Scenario, levels = c("Go", "NoGo")) - - # --- Axis limits --- - x_min <- min(df$gamma_grid) - x_max <- max(df$gamma_grid) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(df$gamma_grid, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Build data frame for optimal threshold points --- - # Points are placed at (gamma_go, PrGo_opt) and (gamma_nogo, PrNoGo_opt). - # The 'fill' aesthetic drives a separate legend with expression labels. - go_val <- if (is.na(gamma_go)) "NA" else sprintf("%.2f", gamma_go) - nogo_val <- if (is.na(gamma_nogo)) "NA" else sprintf("%.2f", gamma_nogo) - - pt_labels <- c( - paste0("gamma[go]==", go_val), - paste0("gamma[nogo]==", nogo_val) - ) - - pt_df <- data.frame( - gamma = c(gamma_go, gamma_nogo), - prob = c(x$PrGo_opt, x$PrNoGo_opt), - pt_col = c(col_go, col_nogo), - pt_grp = factor(pt_labels, levels = pt_labels) - ) - # Remove rows where the optimal threshold is NA - pt_df <- pt_df[!is.na(pt_df$gamma), ] - - # Named colour vector for scale_fill_manual - pt_col_vals <- stats::setNames(pt_df$pt_col, as.character(pt_df$pt_grp)) - - # --- Base plot --- - p <- ggplot2::ggplot(plot_long, - ggplot2::aes(x = gamma, y = prob, - color = Scenario, - linetype = Scenario)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Horizontal reference lines --- - p <- p + - ggplot2::geom_hline(yintercept = target_go, - color = col_go, linetype = "dotted", - linewidth = 1.5) + - ggplot2::geom_hline(yintercept = target_nogo, - color = col_nogo, linetype = "dotted", - linewidth = 1.5) - - # --- Optimal threshold points --- - if (nrow(pt_df) > 0L) { - p <- p + - ggplot2::geom_point( - data = pt_df, - mapping = ggplot2::aes(x = gamma, y = prob, fill = pt_grp), - color = pt_df$pt_col, - shape = 21, - size = 5, - stroke = 1.5, - inherit.aes = FALSE - ) + - ggplot2::scale_fill_manual( - values = pt_col_vals, - labels = lapply(names(pt_col_vals), function(lb) parse(text = lb)[[1L]]) - ) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = expression(gamma), - y = "Probability", - color = "Scenario", - linetype = "Scenario", - fill = "Optimal threshold" - ) + - ggplot2::guides( - color = ggplot2::guide_legend(order = 1), - linetype = ggplot2::guide_legend(order = 1), - fill = ggplot2::guide_legend(order = 2, - override.aes = list(size = 5)) - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.getgamma2bin.R b/R/plot.getgamma2bin.R deleted file mode 100644 index 40706ce..0000000 --- a/R/plot.getgamma2bin.R +++ /dev/null @@ -1,187 +0,0 @@ -#' Plot Method for getgamma2bin Objects -#' -#' Displays calibration curves of marginal Go and NoGo probabilities against -#' the threshold grid \eqn{\gamma} for results returned by -#' \code{\link{getgamma2bin}}. -#' -#' The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -#' The y-axis represents the marginal probability: -#' \itemize{ -#' \item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -#' under the Go-calibration scenario (typically the Null scenario). -#' \item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -#' evaluated under the NoGo-calibration scenario (typically the -#' Alternative scenario). -#' } -#' -#' Horizontal reference lines are drawn at \code{target_go} and -#' \code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -#' thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -#' and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -#' with their values shown in the legend. -#' If either optimal threshold is \code{NA}, the corresponding point is omitted. -#' -#' @param x An object of class \code{getgamma2bin}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_point geom_hline annotate -#' scale_color_manual scale_linetype_manual scale_fill_manual -#' scale_x_continuous scale_y_continuous guides guide_legend -#' labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @importFrom stats setNames -#' @export -plot.getgamma2bin <- function(x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ...) { - - # --- Input validation --- - if (!inherits(x, "getgamma2bin")) { - stop("'x' must be an object of class 'getgamma2bin'") - } - - # --- Extract target values stored in x --- - target_go <- x$target_go - target_nogo <- x$target_nogo - - # --- Extract grid results --- - df <- x$grid_results - gamma_go <- x$gamma_go - gamma_nogo <- x$gamma_nogo - - # --- Reshape to long format --- - plot_long <- data.frame( - gamma = rep(df$gamma_grid, 2L), - prob = c(df$PrGo_grid, df$PrNoGo_grid), - Scenario = rep(c("Go", "NoGo"), each = nrow(df)) - ) - plot_long$Scenario <- factor(plot_long$Scenario, levels = c("Go", "NoGo")) - - # --- Axis limits --- - x_min <- min(df$gamma_grid) - x_max <- max(df$gamma_grid) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(df$gamma_grid, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Build data frame for optimal threshold points --- - # Points are placed at (gamma_go, PrGo_opt) and (gamma_nogo, PrNoGo_opt). - # The 'fill' aesthetic drives a separate legend with expression labels. - go_val <- if (is.na(gamma_go)) "NA" else sprintf("%.2f", gamma_go) - nogo_val <- if (is.na(gamma_nogo)) "NA" else sprintf("%.2f", gamma_nogo) - - pt_labels <- c( - paste0("gamma[go]==", go_val), - paste0("gamma[nogo]==", nogo_val) - ) - - pt_df <- data.frame( - gamma = c(gamma_go, gamma_nogo), - prob = c(x$PrGo_opt, x$PrNoGo_opt), - pt_col = c(col_go, col_nogo), - pt_grp = factor(pt_labels, levels = pt_labels) - ) - # Remove rows where the optimal threshold is NA - pt_df <- pt_df[!is.na(pt_df$gamma), ] - - # Named colour vector for scale_fill_manual - pt_col_vals <- stats::setNames(pt_df$pt_col, as.character(pt_df$pt_grp)) - - # --- Base plot --- - p <- ggplot2::ggplot(plot_long, - ggplot2::aes(x = gamma, y = prob, - color = Scenario, - linetype = Scenario)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Horizontal reference lines --- - p <- p + - ggplot2::geom_hline(yintercept = target_go, - color = col_go, linetype = "dotted", - linewidth = 1.5) + - ggplot2::geom_hline(yintercept = target_nogo, - color = col_nogo, linetype = "dotted", - linewidth = 1.5) - - # --- Optimal threshold points --- - if (nrow(pt_df) > 0L) { - p <- p + - ggplot2::geom_point( - data = pt_df, - mapping = ggplot2::aes(x = gamma, y = prob, fill = pt_grp), - color = pt_df$pt_col, - shape = 21, - size = 5, - stroke = 1.5, - inherit.aes = FALSE - ) + - ggplot2::scale_fill_manual( - values = pt_col_vals, - labels = lapply(names(pt_col_vals), function(lb) parse(text = lb)[[1L]]) - ) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = expression(gamma), - y = "Probability", - color = "Scenario", - linetype = "Scenario", - fill = "Optimal threshold" - ) + - ggplot2::guides( - color = ggplot2::guide_legend(order = 1), - linetype = ggplot2::guide_legend(order = 1), - fill = ggplot2::guide_legend(order = 2, - override.aes = list(size = 5)) - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.getgamma2cont.R b/R/plot.getgamma2cont.R deleted file mode 100644 index 6aa6bc0..0000000 --- a/R/plot.getgamma2cont.R +++ /dev/null @@ -1,187 +0,0 @@ -#' Plot Method for getgamma2cont Objects -#' -#' Displays calibration curves of marginal Go and NoGo probabilities against -#' the threshold grid \eqn{\gamma} for results returned by -#' \code{\link{getgamma2cont}}. -#' -#' The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -#' The y-axis represents the marginal probability: -#' \itemize{ -#' \item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -#' under the Go-calibration scenario (typically the Null scenario). -#' \item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -#' evaluated under the NoGo-calibration scenario (typically the -#' Alternative scenario). -#' } -#' -#' Horizontal reference lines are drawn at \code{target_go} and -#' \code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -#' thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -#' and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -#' with their values shown in the legend. -#' If either optimal threshold is \code{NA}, the corresponding point is omitted. -#' -#' @param x An object of class \code{getgamma2cont}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_point geom_hline annotate -#' scale_color_manual scale_linetype_manual scale_fill_manual -#' scale_x_continuous scale_y_continuous guides guide_legend -#' labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @importFrom stats setNames -#' @export -plot.getgamma2cont <- function(x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ...) { - - # --- Input validation --- - if (!inherits(x, "getgamma2cont")) { - stop("'x' must be an object of class 'getgamma2cont'") - } - - # --- Extract target values stored in x --- - target_go <- x$target_go - target_nogo <- x$target_nogo - - # --- Extract grid results --- - df <- x$grid_results - gamma_go <- x$gamma_go - gamma_nogo <- x$gamma_nogo - - # --- Reshape to long format --- - plot_long <- data.frame( - gamma = rep(df$gamma_grid, 2L), - prob = c(df$PrGo_grid, df$PrNoGo_grid), - Scenario = rep(c("Go", "NoGo"), each = nrow(df)) - ) - plot_long$Scenario <- factor(plot_long$Scenario, levels = c("Go", "NoGo")) - - # --- Axis limits --- - x_min <- min(df$gamma_grid) - x_max <- max(df$gamma_grid) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(df$gamma_grid, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Build data frame for optimal threshold points --- - # Points are placed at (gamma_go, PrGo_opt) and (gamma_nogo, PrNoGo_opt). - # The 'fill' aesthetic drives a separate legend with expression labels. - go_val <- if (is.na(gamma_go)) "NA" else sprintf("%.2f", gamma_go) - nogo_val <- if (is.na(gamma_nogo)) "NA" else sprintf("%.2f", gamma_nogo) - - pt_labels <- c( - paste0("gamma[go]==", go_val), - paste0("gamma[nogo]==", nogo_val) - ) - - pt_df <- data.frame( - gamma = c(gamma_go, gamma_nogo), - prob = c(x$PrGo_opt, x$PrNoGo_opt), - pt_col = c(col_go, col_nogo), - pt_grp = factor(pt_labels, levels = pt_labels) - ) - # Remove rows where the optimal threshold is NA - pt_df <- pt_df[!is.na(pt_df$gamma), ] - - # Named colour vector for scale_fill_manual - pt_col_vals <- stats::setNames(pt_df$pt_col, as.character(pt_df$pt_grp)) - - # --- Base plot --- - p <- ggplot2::ggplot(plot_long, - ggplot2::aes(x = gamma, y = prob, - color = Scenario, - linetype = Scenario)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Horizontal reference lines --- - p <- p + - ggplot2::geom_hline(yintercept = target_go, - color = col_go, linetype = "dotted", - linewidth = 1.5) + - ggplot2::geom_hline(yintercept = target_nogo, - color = col_nogo, linetype = "dotted", - linewidth = 1.5) - - # --- Optimal threshold points --- - if (nrow(pt_df) > 0L) { - p <- p + - ggplot2::geom_point( - data = pt_df, - mapping = ggplot2::aes(x = gamma, y = prob, fill = pt_grp), - color = pt_df$pt_col, - shape = 21, - size = 5, - stroke = 1.5, - inherit.aes = FALSE - ) + - ggplot2::scale_fill_manual( - values = pt_col_vals, - labels = lapply(names(pt_col_vals), function(lb) parse(text = lb)[[1L]]) - ) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = expression(gamma), - y = "Probability", - color = "Scenario", - linetype = "Scenario", - fill = "Optimal threshold" - ) + - ggplot2::guides( - color = ggplot2::guide_legend(order = 1), - linetype = ggplot2::guide_legend(order = 1), - fill = ggplot2::guide_legend(order = 2, - override.aes = list(size = 5)) - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.pbayesdecisionprob1bin.R b/R/plot.pbayesdecisionprob1bin.R deleted file mode 100644 index 2348bfe..0000000 --- a/R/plot.pbayesdecisionprob1bin.R +++ /dev/null @@ -1,199 +0,0 @@ -#' Plot Method for pbayesdecisionprob1bin Objects -#' -#' Displays an operating characteristics curve of Go/NoGo/Gray decision -#' probabilities against the true treatment effect for binary endpoint results -#' returned by \code{\link{pbayesdecisionprob1bin}}. -#' -#' For \code{design = 'controlled'} or \code{design = 'external'}, the -#' x-axis represents the treatment-minus-control difference -#' \eqn{\theta = \pi_t - \bar{\pi}_c}, where \eqn{\bar{\pi}_c} is the mean -#' of the supplied \code{pi_c} values. For \code{design = 'uncontrolled'}, -#' the x-axis represents \eqn{\pi_t} directly. -#' -#' Vertical reference lines are drawn at the decision thresholds: -#' \itemize{ -#' \item When \code{prob = 'posterior'}: lines at \eqn{\theta_{TV}} and -#' \eqn{\theta_{MAV}} (converted to the x-axis scale). -#' \item When \code{prob = 'predictive'}: a single line at \eqn{\theta_{NULL}}. -#' } -#' -#' @param x An object of class \code{pbayesdecisionprob1bin}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param xlab A character string or expression for the x-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param col_gray A character string specifying the colour for the Gray curve. -#' Default is \code{"#939597"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_vline annotate -#' scale_color_manual scale_linetype_manual scale_x_continuous -#' scale_y_continuous labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @export -plot.pbayesdecisionprob1bin <- function(x, - title = NULL, - xlab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ...) { - - # --- Validate minimum number of scenarios --- - if (nrow(x) < 2L) { - stop("'x' must contain at least 2 scenarios (rows) to produce a line plot") - } - - # --- Extract attributes --- - design <- attr(x, "design") - prob <- attr(x, "prob") - theta_TV <- attr(x, "theta_TV") - theta_MAV <- attr(x, "theta_MAV") - theta_NULL <- attr(x, "theta_NULL") - - # --- Build x-axis variable --- - if (design %in% c("controlled", "external")) { - # Use the mean of pi_c as the reference for the difference scale - pi_c_mean <- mean(x$pi_c) - theta <- x$pi_t - pi_c_mean - x_label <- if (is.null(xlab)) { - expression(theta == pi[t] - pi[c]) - } else { - xlab - } - } else { - # Uncontrolled: x-axis is pi_t directly - theta <- x$pi_t - x_label <- if (is.null(xlab)) expression(pi[t]) else xlab - } - - # --- Reshape to long format --- - oc_long <- data.frame( - theta = rep(theta, 3L), - prob = c(x$Go, x$NoGo, x$Gray), - Decision = rep(c("Go", "NoGo", "Gray"), each = nrow(x)) - ) - oc_long$Decision <- factor(oc_long$Decision, levels = c("Go", "NoGo", "Gray")) - - # --- Compute axis limits with a small margin --- - x_min <- min(theta) - x_max <- max(theta) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(theta, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Compute threshold positions on the x-axis --- - # theta_TV, theta_MAV, and theta_NULL are already on the difference scale - # (pi_t - pi_c), so they map directly to the x-axis without adjustment. - if (prob == "posterior") { - vline_TV <- theta_TV - vline_MAV <- theta_MAV - } else { - vline_NULL <- theta_NULL - } - - # --- Annotation y position: slightly below the top of the plot --- - annot_y <- 0.95 - - # --- Compute horizontal offset for annotation text --- - # Use 2% of the x range so the label clears the vline regardless of scale - x_offset <- (x_max - x_min) * 0.02 - - # --- Base plot --- - p <- ggplot2::ggplot(oc_long, - ggplot2::aes(x = theta, y = prob, - color = Decision, - linetype = Decision)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Add threshold vertical lines and labels --- - if (prob == "posterior") { - p <- p + - ggplot2::geom_vline(xintercept = vline_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::geom_vline(xintercept = vline_TV, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::annotate("text", - x = vline_MAV - x_offset, - y = annot_y, - label = "theta[MAV]", - parse = TRUE, - color = "gray30", - hjust = 1, - size = base_size / 3) + - ggplot2::annotate("text", - x = vline_TV + x_offset, - y = annot_y, - label = "theta[TV]", - parse = TRUE, - color = "gray30", - hjust = 0, - size = base_size / 3) - } else { - p <- p + - ggplot2::geom_vline(xintercept = vline_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::annotate("text", - x = vline_NULL + x_offset, - y = annot_y, - label = "theta[NULL]", - parse = TRUE, - color = "gray30", - hjust = 0, - size = base_size / 3) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo, "Gray" = col_gray) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash", "Gray" = "dashed") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = x_label, - y = "Probability", - color = "Decision", - linetype = "Decision" - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.pbayesdecisionprob1cont.R b/R/plot.pbayesdecisionprob1cont.R deleted file mode 100644 index 8915570..0000000 --- a/R/plot.pbayesdecisionprob1cont.R +++ /dev/null @@ -1,198 +0,0 @@ -#' Plot Method for pbayesdecisionprob1cont Objects -#' -#' Displays an operating characteristics curve of Go/NoGo/Gray decision -#' probabilities against the true treatment effect for continuous endpoint -#' results returned by \code{\link{pbayesdecisionprob1cont}}. -#' -#' For \code{design = 'controlled'} or \code{design = 'external'}, the -#' x-axis represents the treatment-minus-control difference -#' \eqn{\theta = \mu_t - \bar{\mu}_c}, where \eqn{\bar{\mu}_c} is the mean -#' of the supplied \code{mu_c} values. For \code{design = 'uncontrolled'}, -#' the x-axis represents \eqn{\mu_t} directly. -#' -#' Vertical reference lines are drawn at the decision thresholds: -#' \itemize{ -#' \item When \code{prob = 'posterior'}: lines at \eqn{\theta_{TV}} and -#' \eqn{\theta_{MAV}} (converted to the x-axis scale). -#' \item When \code{prob = 'predictive'}: a single line at \eqn{\theta_{NULL}}. -#' } -#' -#' @param x An object of class \code{pbayesdecisionprob1cont}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param xlab A character string or expression for the x-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param col_go A character string specifying the colour for the Go curve. -#' Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the colour for the NoGo curve. -#' Default is \code{"#D91E49"}. -#' @param col_gray A character string specifying the colour for the Gray curve. -#' Default is \code{"#939597"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object. -#' -#' @importFrom ggplot2 ggplot aes geom_line geom_vline annotate -#' scale_color_manual scale_linetype_manual scale_x_continuous -#' scale_y_continuous labs theme_bw theme element_text element_line -#' element_blank margin unit -#' @export -plot.pbayesdecisionprob1cont <- function(x, - title = NULL, - xlab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ...) { - - # --- Validate minimum number of scenarios --- - if (nrow(x) < 2L) { - stop("'x' must contain at least 2 scenarios (rows) to produce a line plot") - } - - # --- Extract attributes --- - design <- attr(x, "design") - prob <- attr(x, "prob") - theta_TV <- attr(x, "theta_TV") - theta_MAV <- attr(x, "theta_MAV") - theta_NULL <- attr(x, "theta_NULL") - - # --- Build x-axis variable --- - if (design %in% c("controlled", "external")) { - # Use the mean of mu_c as the reference for the difference scale - mu_c_mean <- mean(x$mu_c) - theta <- x$mu_t - mu_c_mean - x_label <- if (is.null(xlab)) { - expression(theta == mu[t] - mu[c]) - } else { - xlab - } - } else { - # Uncontrolled: x-axis is mu_t directly - theta <- x$mu_t - x_label <- if (is.null(xlab)) expression(mu[t]) else xlab - } - - # --- Reshape to long format --- - oc_long <- data.frame( - theta = rep(theta, 3L), - prob = c(x$Go, x$NoGo, x$Gray), - Decision = rep(c("Go", "NoGo", "Gray"), each = nrow(x)) - ) - oc_long$Decision <- factor(oc_long$Decision, levels = c("Go", "NoGo", "Gray")) - - # --- Compute axis limits --- - x_min <- min(theta) - x_max <- max(theta) - x_pad <- (x_max - x_min) * 0.02 - x_rng <- c(x_min - x_pad, x_max + x_pad) - - x_breaks <- pretty(theta, n = 6L) - x_breaks <- x_breaks[x_breaks >= x_min & x_breaks <= x_max] - - # --- Compute threshold positions on the x-axis --- - # theta_TV, theta_MAV, and theta_NULL are already on the difference scale - # (mu_t - mu_c), so they map directly to the x-axis without adjustment. - if (prob == "posterior") { - vline_TV <- theta_TV - vline_MAV <- theta_MAV - } else { - vline_NULL <- theta_NULL - } - - # --- Annotation y position: slightly below the top of the plot --- - annot_y <- 0.95 - - # --- Horizontal offset: 2% of x range so labels clear the vline --- - x_offset <- (x_max - x_min) * 0.02 - - # --- Base plot --- - p <- ggplot2::ggplot(oc_long, - ggplot2::aes(x = theta, y = prob, - color = Decision, - linetype = Decision)) + - ggplot2::geom_line(linewidth = 1.5) - - # --- Add threshold vertical lines and labels --- - if (prob == "posterior") { - p <- p + - ggplot2::geom_vline(xintercept = vline_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::geom_vline(xintercept = vline_TV, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::annotate("text", - x = vline_MAV - x_offset, - y = annot_y, - label = "theta[MAV]", - parse = TRUE, - color = "gray30", - hjust = 1, - size = base_size / 3) + - ggplot2::annotate("text", - x = vline_TV + x_offset, - y = annot_y, - label = "theta[TV]", - parse = TRUE, - color = "gray30", - hjust = 0, - size = base_size / 3) - } else { - p <- p + - ggplot2::geom_vline(xintercept = vline_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.2) + - ggplot2::annotate("text", - x = vline_NULL + x_offset, - y = annot_y, - label = "theta[NULL]", - parse = TRUE, - color = "gray30", - hjust = 0, - size = base_size / 3) - } - - # --- Scales, labels, and theme --- - p <- p + - ggplot2::scale_color_manual( - values = c("Go" = col_go, "NoGo" = col_nogo, "Gray" = col_gray) - ) + - ggplot2::scale_linetype_manual( - values = c("Go" = "solid", "NoGo" = "twodash", "Gray" = "dashed") - ) + - ggplot2::scale_x_continuous( - limits = x_rng, - breaks = x_breaks, - expand = c(0, 0) - ) + - ggplot2::scale_y_continuous( - limits = c(0, 1), - breaks = seq(0, 1, by = 0.2), - expand = c(0, 0) - ) + - ggplot2::labs( - title = title, - x = x_label, - y = "Probability", - color = "Decision", - linetype = "Decision" - ) + - ggplot2::theme_bw(base_size = base_size) + - ggplot2::theme( - legend.position = "bottom", - legend.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.box.margin = ggplot2::margin(t = -10, r = 0, b = 0, l = 0), - legend.spacing.y = ggplot2::unit(0, "cm"), - legend.text = ggplot2::element_text(size = base_size * 0.54), - legend.title = ggplot2::element_blank(), - legend.key.width = ggplot2::unit(2, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", linewidth = 0.8) - ) - - print(p) - invisible(p) -} diff --git a/R/plot.pbayesdecisionprob2bin.R b/R/plot.pbayesdecisionprob2bin.R deleted file mode 100644 index 328c1a4..0000000 --- a/R/plot.pbayesdecisionprob2bin.R +++ /dev/null @@ -1,485 +0,0 @@ -#' Plot Method for pbayesdecisionprob2bin Objects -#' -#' Displays operating characteristics for two-binary-endpoint results returned -#' by \code{\link{pbayesdecisionprob2bin}}. -#' -#' When the input scenarios form a regular grid over -#' \code{(pi_t1, pi_t2)} (i.e., every combination of the unique values of -#' \code{pi_t1} and \code{pi_t2} is present) and \code{rho_t} is constant, -#' the function produces a \strong{filled tile plot}: each panel (Go, Gray, -#' NoGo) is coloured by its own probability on a continuous gradient (white to -#' the panel colour), so intensity directly reflects the probability magnitude. -#' A solid white contour line is overlaid at the corresponding decision -#' threshold (\code{gamma_go} for the Go panel, \code{gamma_nogo} for the -#' NoGo panel, and their mean for the Gray panel) to mark the boundary where -#' the probability equals the threshold. Otherwise the function falls back to -#' a \strong{scatter plot} in which point colour encodes the decision -#' probability on a continuous scale. -#' -#' When \code{which = "all"}, the three panels are arranged side-by-side using -#' \code{gridExtra::grid.arrange}, so each panel retains its own independent -#' colour scale. This requires the \pkg{gridExtra} package. -#' -#' For \code{design = 'controlled'} or \code{design = 'external'}, both axes -#' are expressed as treatment-minus-control differences: -#' \eqn{\theta_1 = \pi_{t1} - \bar{\pi}_{c1}} and -#' \eqn{\theta_2 = \pi_{t2} - \bar{\pi}_{c2}}, -#' where \eqn{\bar{\pi}_{c1}} and \eqn{\bar{\pi}_{c2}} are the means of the -#' supplied \code{pi_c1} and \code{pi_c2} vectors. -#' For \code{design = 'uncontrolled'}, the axes represent \eqn{\pi_{t1}} and -#' \eqn{\pi_{t2}} directly. -#' -#' Vertical and horizontal reference lines are drawn at the decision thresholds: -#' \itemize{ -#' \item When \code{prob = 'posterior'}: vertical lines at \eqn{\theta_{TV1}} -#' and \eqn{\theta_{MAV1}} (x-axis) and horizontal lines at -#' \eqn{\theta_{TV2}} and \eqn{\theta_{MAV2}} (y-axis). -#' \item When \code{prob = 'predictive'}: a single vertical line at -#' \eqn{\theta_{NULL1}} and a single horizontal line at -#' \eqn{\theta_{NULL2}}. -#' } -#' -#' @param x An object of class \code{pbayesdecisionprob2bin}. -#' @param which A character string specifying which decision probability to -#' plot. Must be one of \code{"Go"}, \code{"Gray"}, \code{"NoGo"}, -#' \code{"all"}, or \code{"overlay"}. Default is \code{"Go"}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param xlab A character string or expression for the x-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param ylab A character string or expression for the y-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param col_go A character string specifying the high-end fill colour for the -#' Go probability gradient. Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the high-end fill colour for -#' the NoGo probability gradient. Default is \code{"#D91E49"}. -#' @param col_gray A character string specifying the high-end fill colour for -#' the Gray probability gradient. Default is \code{"#939597"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object (single panel) or a -#' \code{gtable} object (\code{which = "all"}). -#' -#' @importFrom ggplot2 ggplot aes geom_tile geom_vline geom_hline annotate -#' scale_fill_gradient scale_fill_stepsn scale_fill_manual -#' scale_x_continuous scale_y_continuous -#' coord_cartesian labs theme_bw theme element_text element_line element_blank -#' margin unit geom_point scale_color_gradient scale_color_stepsn geom_text -#' guide_colorsteps -#' @importFrom grDevices col2rgb rgb -#' @importFrom gridExtra grid.arrange -#' @export -plot.pbayesdecisionprob2bin <- function(x, - which = "Go", - title = NULL, - xlab = NULL, - ylab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ...) { - - # --- Input validation --- - if (!which %in% c("Go", "Gray", "NoGo", "all", "overlay")) { - stop("'which' must be one of \"Go\", \"Gray\", \"NoGo\", \"all\", or \"overlay\"") - } - if (nrow(x) < 2L) { - stop("'x' must contain at least 2 scenarios (rows) to produce a plot") - } - - # --- Extract attributes --- - design <- attr(x, "design") - prob <- attr(x, "prob") - theta_TV1 <- attr(x, "theta_TV1") - theta_MAV1 <- attr(x, "theta_MAV1") - theta_TV2 <- attr(x, "theta_TV2") - theta_MAV2 <- attr(x, "theta_MAV2") - theta_NULL1 <- attr(x, "theta_NULL1") - theta_NULL2 <- attr(x, "theta_NULL2") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - - # --- Build x/y axis variables --- - if (design %in% c("controlled", "external")) { - pi_c1_mean <- mean(x$pi_c1) - pi_c2_mean <- mean(x$pi_c2) - ax1 <- x$pi_t1 - pi_c1_mean - ax2 <- x$pi_t2 - pi_c2_mean - x_label <- if (is.null(xlab)) expression(theta[1] == pi[t1] - pi[c1]) else xlab - y_label <- if (is.null(ylab)) expression(theta[2] == pi[t2] - pi[c2]) else ylab - } else { - pi_c1_mean <- NULL - pi_c2_mean <- NULL - ax1 <- x$pi_t1 - ax2 <- x$pi_t2 - x_label <- if (is.null(xlab)) expression(pi[t1]) else xlab - y_label <- if (is.null(ylab)) expression(pi[t2]) else ylab - } - - # --- Determine threshold positions on each axis --- - # Threshold values are used directly as axis coordinates (no transformation). - if (prob == "posterior") { - vx_TV <- theta_TV1; vx_MAV <- theta_MAV1 - vy_TV <- theta_TV2; vy_MAV <- theta_MAV2 - } else { - vx_NULL <- theta_NULL1 - vy_NULL <- theta_NULL2 - } - - # --- Detect grid layout and constant rho_t --- - u1 <- sort(unique(ax1)) - u2 <- sort(unique(ax2)) - is_grid <- (length(u1) * length(u2) == nrow(x)) && - (length(unique(x$rho_t)) == 1L) - - # --- Helper: axis breaks --- - axis_breaks <- function(vals) { - b <- pretty(vals, n = 6L) - eps <- 1e-9 - b[b >= (min(vals) - eps) & b <= (max(vals) + eps)] - } - - # --- Helper: add threshold reference lines and labels --- - add_thresholds <- function(p, x_rng, y_rng, bs) { - off_x <- diff(x_rng) * 0.02 - off_y <- diff(y_rng) * 0.02 - if (prob == "posterior") { - p <- p + - ggplot2::geom_vline(xintercept = vx_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_vline(xintercept = vx_TV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_TV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::annotate("text", - x = vx_MAV - off_x, y = y_rng[2], - label = "theta[MAV1]", parse = TRUE, - color = "gray30", hjust = 1, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = vx_TV + off_x, y = y_rng[2], - label = "theta[TV1]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_MAV - off_y, - label = "theta[MAV2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_TV + off_y, - label = "theta[TV2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 0, - size = bs / 3) - } else { - p <- p + - ggplot2::geom_vline(xintercept = vx_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::annotate("text", - x = vx_NULL + off_x, y = y_rng[2], - label = "theta[NULL1]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_NULL + off_y, - label = "theta[NULL2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 0, - size = bs / 3) - } - p - } - - # --- Helper: common theme --- - common_theme <- function(bs) { - ggplot2::theme_bw(base_size = bs) + - ggplot2::theme( - legend.position = "right", - legend.margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 10), - legend.box.margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5), - legend.text = ggplot2::element_text(size = bs * 0.74), - legend.title = ggplot2::element_text(size = bs * 0.74, - hjust = 0), - legend.key.height = ggplot2::unit(bs * 0.04, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", - linewidth = 0.8), - strip.text = ggplot2::element_text(size = bs * 0.64, - face = "bold") - ) - } - - # --------------------------------------------------------------------------- - # OVERLAY MODE - # --------------------------------------------------------------------------- - if (which == "overlay") { - - if (!is_grid) { - stop("'which = \"overlay\"' requires a regular grid input.") - } - if (!requireNamespace("gridExtra", quietly = TRUE)) { - stop("Package 'gridExtra' is required for which = \"overlay\".") - } - - tile_w_ov <- if (length(unique(ax1)) > 1L) min(diff(sort(unique(ax1)))) / 2 else 0.05 - tile_h_ov <- if (length(unique(ax2)) > 1L) min(diff(sort(unique(ax2)))) / 2 else 0.05 - x_rng_ov <- c(min(ax1) - tile_w_ov, max(ax1) + tile_w_ov) - y_rng_ov <- c(min(ax2) - tile_h_ov, max(ax2) + tile_h_ov) - - df_ov <- data.frame(ax1 = ax1, ax2 = ax2, - Go = x[["Go"]], Gray = x[["Gray"]], NoGo = x[["NoGo"]]) - df_ov$dominant <- apply(df_ov[, c("Go","Gray","NoGo")], 1L, function(r) { - if (any(is.na(r))) return(NA_character_) - c("Go","Gray","NoGo")[which.max(r)] - }) - df_ov$max_prob <- apply(df_ov[, c("Go","Gray","NoGo")], 1L, function(r) { - if (any(is.na(r))) return(NA_real_) - max(r, na.rm = TRUE) - }) - bin_labels <- c("< 0.50","0.50-0.60","0.60-0.70","0.70-0.80","> 0.80") - df_ov$prob_bin <- cut(df_ov$max_prob, - breaks = c(0, 0.50, 0.60, 0.70, 0.80, 1.001), - labels = bin_labels, include.lowest = TRUE, right = FALSE) - - make_shades <- function(base_col, n = 5L) { - alphas <- seq(0.20, 1.00, length.out = n) - sapply(alphas, function(a) { - v <- col2rgb(base_col) / 255 - rgb(1 - a*(1-v[1]), 1 - a*(1-v[2]), 1 - a*(1-v[3])) - }) - } - go_sh <- make_shades(col_go); names(go_sh) <- bin_labels - gray_sh <- make_shades(col_gray); names(gray_sh) <- bin_labels - nogo_sh <- make_shades(col_nogo); names(nogo_sh) <- bin_labels - - df_ov$fill_col <- mapply(function(dom, bin) { - if (is.na(dom) || is.na(bin)) return("white") - b <- as.character(bin) - if (dom == "Go") return(unname(go_sh[b])) - if (dom == "Gray") return(unname(gray_sh[b])) - if (dom == "NoGo") return(unname(nogo_sh[b])) - "white" - }, df_ov$dominant, df_ov$prob_bin) - - p_main <- ggplot2::ggplot(df_ov, ggplot2::aes(x = ax1, y = ax2)) + - ggplot2::geom_tile(ggplot2::aes(fill = I(fill_col)), color = "gray50", - linewidth = 0.3) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), expand = c(0, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), expand = c(0, 0)) + - ggplot2::coord_cartesian(xlim = x_rng_ov, ylim = y_rng_ov) + - ggplot2::labs(title = title, x = x_label, y = y_label) + - common_theme(base_size) + - ggplot2::theme(legend.position = "none", - plot.margin = ggplot2::margin(t = 10, r = 5, b = 5, l = 5)) - - df_na <- df_ov[is.na(df_ov$dominant), , drop = FALSE] - if (nrow(df_na) > 0L) { - p_main <- p_main + - ggplot2::geom_text(data = df_na, - mapping = ggplot2::aes(x = ax1, y = ax2, label = "NA"), - color = "gray50", size = base_size * 0.35, inherit.aes = FALSE) - } - p_main <- add_thresholds(p_main, x_rng_ov, y_rng_ov, base_size) - - gray_5 <- make_shades("#808080") - leg_df <- data.frame( - y = c(7, 6, 5, 3, 2, 1, 0, -1), - col = c(unname(go_sh[5L]), unname(gray_sh[5L]), unname(nogo_sh[5L]), - unname(gray_5)), - lab = c("Go", "Grey", "NoGo", bin_labels), - stringsAsFactors = FALSE - ) - p_leg <- ggplot2::ggplot(leg_df, ggplot2::aes(x = 0, y = y)) + - ggplot2::geom_tile(ggplot2::aes(fill = I(col)), width = 0.8, height = 0.8) + - ggplot2::geom_text(ggplot2::aes(x = 0.6, label = lab), - hjust = 0, size = base_size * 0.26) + - ggplot2::annotate("text", x = -0.4, y = 8.0, label = "Decision", - hjust = 0, fontface = "bold", size = base_size * 0.35) + - ggplot2::annotate("text", x = -0.4, y = 4.0, label = "Probability", - hjust = 0, fontface = "bold", size = base_size * 0.35) + - ggplot2::scale_x_continuous(limits = c(-0.5, 4.0), expand = c(0, 0)) + - ggplot2::scale_y_continuous(limits = c(-1.6, 8.5), expand = c(0, 0)) + - ggplot2::coord_fixed(ratio = 1) + - ggplot2::theme_void() + - ggplot2::theme(plot.margin = ggplot2::margin(t = 2, r = 2, b = 2, l = 2)) - - out <- gridExtra::grid.arrange( - p_main, p_leg, ncol = 2L, widths = c(6, 1) - ) - return(invisible(out)) - } - - # --------------------------------------------------------------------------- - # CONTOUR MODE - # --------------------------------------------------------------------------- - if (is_grid) { - - tile_w <- if (length(u1) > 1L) min(diff(u1)) / 2 else 0.05 - tile_h <- if (length(u2) > 1L) min(diff(u2)) / 2 else 0.05 - x_rng <- c(min(ax1) - tile_w, max(ax1) + tile_w) - y_rng <- c(min(ax2) - tile_h, max(ax2) + tile_h) - - # Helper: build a single gradient tile panel - # - prob_col : column name in x ("Go", "Gray", "NoGo") - # - high_col : colour for high-probability end of the gradient - # - gamma_thr : threshold value at which the white contour line is drawn - make_tile_panel <- function(prob_col, high_col, gamma_thr, - panel_title, bs) { - df <- data.frame(ax1 = ax1, - ax2 = ax2, - prob_val = x[[prob_col]]) - - legend_label <- switch(prob_col, - Go = "Pr(Go)", - NoGo = "Pr(NoGo)", - Gray = "Pr(Gray)") - - p <- ggplot2::ggplot(df, ggplot2::aes(x = ax1, y = ax2)) + - ggplot2::geom_tile(ggplot2::aes(fill = prob_val), - color = "gray50", linewidth = 0.5) + - ggplot2::scale_fill_stepsn( - name = legend_label, - colors = c("white", high_col), - breaks = seq(0.1, 0.9, by = 0.1), - limits = c(0, 1), - guide = ggplot2::guide_colorsteps( - title.position = "top", - title.hjust = 0, - barheight = ggplot2::unit(bs * 0.50, "cm"), - barwidth = ggplot2::unit(bs * 0.06, "cm"), - direction = "vertical", - show.limits = TRUE - ) - ) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), - expand = c(0, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), - expand = c(0, 0)) + - ggplot2::coord_cartesian(xlim = x_rng, ylim = y_rng) + - ggplot2::labs(title = panel_title, x = x_label, y = y_label) + - common_theme(bs) - - # Overlay white tiles and "NA" text on missing cells - df_na_tile <- df[is.na(df$prob_val), , drop = FALSE] - if (nrow(df_na_tile) > 0L) { - p <- p + - ggplot2::geom_tile(data = df_na_tile, - mapping = ggplot2::aes(x = ax1, y = ax2), - fill = "white", color = "gray50", - linewidth = 0.5, inherit.aes = FALSE) + - ggplot2::geom_text(data = df_na_tile, - mapping = ggplot2::aes(x = ax1, y = ax2, label = "NA"), - color = "gray50", size = bs * 0.35, - inherit.aes = FALSE) - } - - p <- add_thresholds(p, x_rng, y_rng, bs) - p - } - - if (which == "all") { - # Build three independent panels with panel-specific gradients and - # arrange them side-by-side; gridExtra is required - if (!requireNamespace("gridExtra", quietly = TRUE)) { - stop("Package 'gridExtra' is required for which = \"all\". ", - "Please install it with install.packages(\"gridExtra\").") - } - p_go <- make_tile_panel("Go", col_go, gamma_go, "Go", base_size) - p_gray <- make_tile_panel("Gray", col_gray, - (gamma_go + gamma_nogo) / 2, "Gray", base_size) - p_nogo <- make_tile_panel("NoGo", col_nogo, gamma_nogo, "NoGo", base_size) - - out <- gridExtra::grid.arrange( - p_go, p_gray, p_nogo, - nrow = 1L, - top = if (!is.null(title)) title else "" - ) - return(invisible(out)) - - } else { - high_col <- switch(which, Go = col_go, Gray = col_gray, NoGo = col_nogo) - gamma_thr <- switch(which, - Go = gamma_go, - NoGo = gamma_nogo, - Gray = (gamma_go + gamma_nogo) / 2) - p <- make_tile_panel(which, high_col, gamma_thr, title, base_size) - } - - # --------------------------------------------------------------------------- - # SCATTER MODE (non-grid or multiple rho_t values) - # --------------------------------------------------------------------------- - } else { - - prob_col <- if (which == "all") { - message("Non-grid input: 'which = \"all\"' shows Go probability only.") - "Go" - } else { - which - } - - high_col <- switch(prob_col, - Go = col_go, - NoGo = col_nogo, - Gray = col_gray) - prob_vals <- x[[prob_col]] - x_rng <- range(ax1) - y_rng <- range(ax2) - - df_scatter <- data.frame(ax1 = ax1, ax2 = ax2, prob_val = prob_vals) - - legend_label <- switch(prob_col, - Go = "Pr(Go)", - NoGo = "Pr(NoGo)", - Gray = "Pr(Gray)") - - p <- ggplot2::ggplot(df_scatter, - ggplot2::aes(x = ax1, y = ax2, color = prob_val)) + - ggplot2::geom_point(size = 4) + - ggplot2::scale_color_stepsn( - name = legend_label, - colors = c("white", high_col), - breaks = seq(0.1, 0.9, by = 0.1), - limits = c(0, 1), - guide = ggplot2::guide_colorsteps( - title.position = "top", - title.hjust = 0, - barheight = ggplot2::unit(base_size * 0.50, "cm"), - barwidth = ggplot2::unit(base_size * 0.06, "cm"), - direction = "vertical", - ticks = TRUE, - ticks.colour = "white", - ticks.linewidth = 1.5 - ) - ) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), - expand = c(0.05, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), - expand = c(0.05, 0)) + - ggplot2::labs(title = title, x = x_label, y = y_label) + - common_theme(base_size) - - df_na_sc <- df_scatter[is.na(df_scatter$prob_val), , drop = FALSE] - if (nrow(df_na_sc) > 0L) { - p <- p + - ggplot2::geom_text(data = df_na_sc, - mapping = ggplot2::aes(x = ax1, y = ax2, label = "NA"), - color = "gray50", size = base_size * 0.35, - inherit.aes = FALSE) - } - - p <- add_thresholds(p, x_rng, y_rng, base_size) - } - - print(p) - invisible(p) -} diff --git a/R/plot.pbayesdecisionprob2cont.R b/R/plot.pbayesdecisionprob2cont.R deleted file mode 100644 index 19267a2..0000000 --- a/R/plot.pbayesdecisionprob2cont.R +++ /dev/null @@ -1,457 +0,0 @@ -#' Plot Method for pbayesdecisionprob2cont Objects -#' -#' Displays operating characteristics for two-continuous-endpoint results -#' returned by \code{\link{pbayesdecisionprob2cont}}. -#' -#' When the input scenarios form a regular grid over -#' \code{(mu_t1, mu_t2)} (i.e., every combination of the unique values of -#' \code{mu_t1} and \code{mu_t2} is present) and \code{rho_t} is constant, -#' the function produces a \strong{filled tile plot}: each panel (Go, Gray, -#' NoGo) is coloured by its own probability on a continuous gradient (white to -#' the panel colour), so intensity directly reflects the probability magnitude. -#' Otherwise the function falls back to a \strong{scatter plot} in which point -#' colour encodes the decision probability on a continuous scale. -#' -#' When \code{which = "all"}, the three panels are arranged side-by-side using -#' \code{gridExtra::grid.arrange}, so each panel retains its own independent -#' colour scale. This requires the \pkg{gridExtra} package. -#' -#' For \code{design = 'controlled'} or \code{design = 'external'}, both axes -#' are expressed as treatment-minus-control differences: -#' \eqn{\theta_1 = \mu_{t1} - \bar{\mu}_{c1}} and -#' \eqn{\theta_2 = \mu_{t2} - \bar{\mu}_{c2}}, -#' where \eqn{\bar{\mu}_{c1}} and \eqn{\bar{\mu}_{c2}} are the means of the -#' supplied \code{mu_c1} and \code{mu_c2} vectors. -#' For \code{design = 'uncontrolled'}, the axes represent \eqn{\mu_{t1}} and -#' \eqn{\mu_{t2}} directly. -#' -#' Vertical and horizontal reference lines are drawn at the decision thresholds: -#' \itemize{ -#' \item When \code{prob = 'posterior'}: vertical lines at \eqn{\theta_{TV1}} -#' and \eqn{\theta_{MAV1}} (x-axis) and horizontal lines at -#' \eqn{\theta_{TV2}} and \eqn{\theta_{MAV2}} (y-axis). -#' \item When \code{prob = 'predictive'}: a single vertical line at -#' \eqn{\theta_{NULL1}} and a single horizontal line at -#' \eqn{\theta_{NULL2}}. -#' } -#' -#' @param x An object of class \code{pbayesdecisionprob2cont}. -#' @param which A character string specifying which decision probability to -#' plot. Must be one of \code{"Go"}, \code{"Gray"}, \code{"NoGo"}, -#' \code{"all"}, or \code{"overlay"}. Default is \code{"Go"}. -#' @param title A character string for the plot title. Defaults to -#' \code{NULL} (no title displayed). -#' @param xlab A character string or expression for the x-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param ylab A character string or expression for the y-axis label. -#' Defaults to \code{NULL}, which auto-generates a label based on -#' \code{design}. -#' @param col_go A character string specifying the high-end fill colour for the -#' Go probability gradient. Default is \code{"#658D1B"}. -#' @param col_nogo A character string specifying the high-end fill colour for -#' the NoGo probability gradient. Default is \code{"#D91E49"}. -#' @param col_gray A character string specifying the high-end fill colour for -#' the Gray probability gradient. Default is \code{"#939597"}. -#' @param base_size A positive numeric scalar specifying the base font size -#' (in points) passed to \code{theme_bw()}. Default is \code{28}. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns a \code{ggplot} object (single panel) or a -#' \code{gtable} object (\code{which = "all"}). -#' -#' @importFrom ggplot2 ggplot aes geom_tile geom_vline geom_hline annotate -#' scale_fill_gradient scale_fill_stepsn scale_fill_manual -#' scale_x_continuous scale_y_continuous -#' coord_cartesian labs theme_bw theme element_text element_line element_blank -#' margin unit geom_point scale_color_gradient scale_color_stepsn geom_text -#' guide_colorsteps -#' @importFrom grDevices col2rgb rgb -#' @importFrom gridExtra grid.arrange -#' @export -plot.pbayesdecisionprob2cont <- function(x, - which = "Go", - title = NULL, - xlab = NULL, - ylab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ...) { - - # --- Input validation --- - if (!which %in% c("Go", "Gray", "NoGo", "all", "overlay")) { - stop("'which' must be one of \"Go\", \"Gray\", \"NoGo\", \"all\", or \"overlay\"") - } - if (nrow(x) < 2L) { - stop("'x' must contain at least 2 scenarios (rows) to produce a plot") - } - - # --- Extract attributes --- - design <- attr(x, "design") - prob <- attr(x, "prob") - theta_TV1 <- attr(x, "theta_TV1") - theta_MAV1 <- attr(x, "theta_MAV1") - theta_TV2 <- attr(x, "theta_TV2") - theta_MAV2 <- attr(x, "theta_MAV2") - theta_NULL1 <- attr(x, "theta_NULL1") - theta_NULL2 <- attr(x, "theta_NULL2") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - - # --- Build x/y axis variables --- - if (design %in% c("controlled", "external")) { - mu_c1_mean <- mean(x$mu_c1) - mu_c2_mean <- mean(x$mu_c2) - ax1 <- x$mu_t1 - mu_c1_mean - ax2 <- x$mu_t2 - mu_c2_mean - x_label <- if (is.null(xlab)) expression(theta[1] == mu[t1] - mu[c1]) else xlab - y_label <- if (is.null(ylab)) expression(theta[2] == mu[t2] - mu[c2]) else ylab - } else { - mu_c1_mean <- NULL - mu_c2_mean <- NULL - ax1 <- x$mu_t1 - ax2 <- x$mu_t2 - x_label <- if (is.null(xlab)) expression(mu[t1]) else xlab - y_label <- if (is.null(ylab)) expression(mu[t2]) else ylab - } - - # --- Determine threshold positions on each axis --- - # Threshold values are used directly as axis coordinates (no transformation). - if (prob == "posterior") { - vx_TV <- theta_TV1; vx_MAV <- theta_MAV1 - vy_TV <- theta_TV2; vy_MAV <- theta_MAV2 - } else { - vx_NULL <- theta_NULL1 - vy_NULL <- theta_NULL2 - } - - # --- Detect grid layout and constant rho_t --- - u1 <- sort(unique(ax1)) - u2 <- sort(unique(ax2)) - is_grid <- (length(u1) * length(u2) == nrow(x)) - - # --- Helper: axis breaks --- - axis_breaks <- function(vals) { - b <- pretty(vals, n = 6L) - eps <- 1e-9 - b[b >= (min(vals) - eps) & b <= (max(vals) + eps)] - } - - # --- Helper: add threshold reference lines and labels --- - add_thresholds <- function(p, x_rng, y_rng, bs) { - off_x <- diff(x_rng) * 0.02 - off_y <- diff(y_rng) * 0.02 - if (prob == "posterior") { - p <- p + - ggplot2::geom_vline(xintercept = vx_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_vline(xintercept = vx_TV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_MAV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_TV, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::annotate("text", - x = vx_MAV - off_x, y = y_rng[2], - label = "theta[MAV1]", parse = TRUE, - color = "gray30", hjust = 1, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = vx_TV + off_x, y = y_rng[2], - label = "theta[TV1]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_MAV - off_y, - label = "theta[MAV2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_TV + off_y, - label = "theta[TV2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 0, - size = bs / 3) - } else { - p <- p + - ggplot2::geom_vline(xintercept = vx_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::geom_hline(yintercept = vy_NULL, color = "gray30", - linetype = "dotted", linewidth = 1.0) + - ggplot2::annotate("text", - x = vx_NULL + off_x, y = y_rng[2], - label = "theta[NULL1]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 1, - size = bs / 3) + - ggplot2::annotate("text", - x = x_rng[1], y = vy_NULL + off_y, - label = "theta[NULL2]", parse = TRUE, - color = "gray30", hjust = 0, vjust = 0, - size = bs / 3) - } - p - } - - # --- Helper: common theme --- - common_theme <- function(bs) { - ggplot2::theme_bw(base_size = bs) + - ggplot2::theme( - legend.position = "right", - legend.margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 10), - legend.box.margin = ggplot2::margin(t = 0, r = 0, b = 0, l = 5), - legend.text = ggplot2::element_text(size = bs * 0.74), - legend.title = ggplot2::element_text(size = bs * 0.74, - hjust = 0), - legend.key.height = ggplot2::unit(bs * 0.04, "cm"), - panel.grid.minor = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.border = ggplot2::element_blank(), - axis.line = ggplot2::element_line(color = "black", - linewidth = 0.8), - strip.text = ggplot2::element_text(size = bs * 0.64, - face = "bold") - ) - } - - # --------------------------------------------------------------------------- - # OVERLAY MODE - # --------------------------------------------------------------------------- - if (which == "overlay") { - - if (!is_grid) { - stop("'which = \"overlay\"' requires a regular grid input.") - } - if (!requireNamespace("gridExtra", quietly = TRUE)) { - stop("Package 'gridExtra' is required for which = \"overlay\".") - } - - tile_w_ov <- if (length(unique(ax1)) > 1L) min(diff(sort(unique(ax1)))) / 2 else 0.05 - tile_h_ov <- if (length(unique(ax2)) > 1L) min(diff(sort(unique(ax2)))) / 2 else 0.05 - x_rng_ov <- c(min(ax1) - tile_w_ov, max(ax1) + tile_w_ov) - y_rng_ov <- c(min(ax2) - tile_h_ov, max(ax2) + tile_h_ov) - - df_ov <- data.frame(ax1 = ax1, ax2 = ax2, - Go = x[["Go"]], Gray = x[["Gray"]], NoGo = x[["NoGo"]]) - df_ov$dominant <- apply(df_ov[, c("Go","Gray","NoGo")], 1L, function(r) { - if (any(is.na(r))) return(NA_character_) - c("Go","Gray","NoGo")[which.max(r)] - }) - df_ov$max_prob <- apply(df_ov[, c("Go","Gray","NoGo")], 1L, function(r) { - if (any(is.na(r))) return(NA_real_) - max(r, na.rm = TRUE) - }) - bin_labels <- c("< 0.50","0.50-0.60","0.60-0.70","0.70-0.80","> 0.80") - df_ov$prob_bin <- cut(df_ov$max_prob, - breaks = c(0, 0.50, 0.60, 0.70, 0.80, 1.001), - labels = bin_labels, include.lowest = TRUE, right = FALSE) - - make_shades <- function(base_col, n = 5L) { - alphas <- seq(0.20, 1.00, length.out = n) - sapply(alphas, function(a) { - v <- col2rgb(base_col) / 255 - rgb(1 - a*(1-v[1]), 1 - a*(1-v[2]), 1 - a*(1-v[3])) - }) - } - go_sh <- make_shades(col_go); names(go_sh) <- bin_labels - gray_sh <- make_shades(col_gray); names(gray_sh) <- bin_labels - nogo_sh <- make_shades(col_nogo); names(nogo_sh) <- bin_labels - - df_ov$fill_col <- mapply(function(dom, bin) { - if (is.na(dom) || is.na(bin)) return("white") - b <- as.character(bin) - if (dom == "Go") return(unname(go_sh[b])) - if (dom == "Gray") return(unname(gray_sh[b])) - if (dom == "NoGo") return(unname(nogo_sh[b])) - "white" - }, df_ov$dominant, df_ov$prob_bin) - - p_main <- ggplot2::ggplot(df_ov, ggplot2::aes(x = ax1, y = ax2)) + - ggplot2::geom_tile(ggplot2::aes(fill = I(fill_col)), color = "gray50", - linewidth = 0.3) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), expand = c(0, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), expand = c(0, 0)) + - ggplot2::coord_cartesian(xlim = x_rng_ov, ylim = y_rng_ov) + - ggplot2::labs(title = title, x = x_label, y = y_label) + - common_theme(base_size) + - ggplot2::theme(legend.position = "none", - plot.margin = ggplot2::margin(t = 10, r = 5, b = 5, l = 5)) - - df_na <- df_ov[is.na(df_ov$dominant), , drop = FALSE] - if (nrow(df_na) > 0L) { - p_main <- p_main + - ggplot2::geom_text(data = df_na, - mapping = ggplot2::aes(x = ax1, y = ax2, label = "NA"), - color = "gray50", size = base_size / 10, inherit.aes = FALSE) - } - p_main <- add_thresholds(p_main, x_rng_ov, y_rng_ov, base_size) - - gray_5 <- make_shades("#808080") - leg_df <- data.frame( - y = c(7, 6, 5, 3, 2, 1, 0, -1), - col = c(unname(go_sh[5L]), unname(gray_sh[5L]), unname(nogo_sh[5L]), - unname(gray_5)), - lab = c("Go", "Grey", "NoGo", bin_labels), - stringsAsFactors = FALSE - ) - p_leg <- ggplot2::ggplot(leg_df, ggplot2::aes(x = 0, y = y)) + - ggplot2::geom_tile(ggplot2::aes(fill = I(col)), width = 0.8, height = 0.8) + - ggplot2::geom_text(ggplot2::aes(x = 0.6, label = lab), - hjust = 0, size = base_size * 0.26) + - ggplot2::annotate("text", x = -0.4, y = 8.0, label = "Decision", - hjust = 0, fontface = "bold", size = base_size * 0.28) + - ggplot2::annotate("text", x = -0.4, y = 4.0, label = "Probability", - hjust = 0, fontface = "bold", size = base_size * 0.28) + - ggplot2::scale_x_continuous(limits = c(-0.5, 4.0), expand = c(0, 0)) + - ggplot2::scale_y_continuous(limits = c(-1.6, 8.5), expand = c(0, 0)) + - ggplot2::coord_fixed(ratio = 1) + - ggplot2::theme_void() + - ggplot2::theme(plot.margin = ggplot2::margin(t = 2, r = 2, b = 2, l = 2)) - - out <- gridExtra::grid.arrange( - p_main, p_leg, ncol = 2L, widths = c(6, 1) - ) - return(invisible(out)) - } - - # --------------------------------------------------------------------------- - # CONTOUR MODE - # --------------------------------------------------------------------------- - if (is_grid) { - - tile_w <- if (length(u1) > 1L) min(diff(u1)) / 2 else 0.05 - tile_h <- if (length(u2) > 1L) min(diff(u2)) / 2 else 0.05 - x_rng <- c(min(ax1) - tile_w, max(ax1) + tile_w) - y_rng <- c(min(ax2) - tile_h, max(ax2) + tile_h) - - # Helper: build a single gradient tile panel - # - prob_col : column name in x ("Go", "Gray", "NoGo") - # - high_col : colour for high-probability end of the gradient - # - gamma_thr : threshold value at which the white contour line is drawn - make_tile_panel <- function(prob_col, high_col, gamma_thr, - panel_title, bs) { - df <- data.frame(ax1 = ax1, - ax2 = ax2, - prob_val = x[[prob_col]]) - - legend_label <- switch(prob_col, - Go = "Pr(Go)", - NoGo = "Pr(NoGo)", - Gray = "Pr(Gray)") - - p <- ggplot2::ggplot(df, ggplot2::aes(x = ax1, y = ax2)) + - ggplot2::geom_tile(ggplot2::aes(fill = prob_val), - color = "gray50", linewidth = 0.5) + - ggplot2::scale_fill_stepsn( - name = legend_label, - colors = c("white", high_col), - breaks = seq(0.1, 0.9, by = 0.1), - limits = c(0, 1), - guide = ggplot2::guide_colorsteps( - title.position = "top", - title.hjust = 0, - barheight = ggplot2::unit(bs * 0.50, "cm"), - barwidth = ggplot2::unit(bs * 0.06, "cm"), - direction = "vertical", - show.limits = TRUE - ) - ) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), - expand = c(0, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), - expand = c(0, 0)) + - ggplot2::coord_cartesian(xlim = x_rng, ylim = y_rng) + - ggplot2::labs(title = panel_title, x = x_label, y = y_label) + - common_theme(bs) - - p <- add_thresholds(p, x_rng, y_rng, bs) - p - } - - if (which == "all") { - # Build three independent panels with panel-specific gradients and - # arrange them side-by-side; gridExtra is required - if (!requireNamespace("gridExtra", quietly = TRUE)) { - stop("Package 'gridExtra' is required for which = \"all\". ", - "Please install it with install.packages(\"gridExtra\").") - } - p_go <- make_tile_panel("Go", col_go, gamma_go, "Go", base_size) - p_gray <- make_tile_panel("Gray", col_gray, - (gamma_go + gamma_nogo) / 2, "Gray", base_size) - p_nogo <- make_tile_panel("NoGo", col_nogo, gamma_nogo, "NoGo", base_size) - - out <- gridExtra::grid.arrange( - p_go, p_gray, p_nogo, - nrow = 1L, - top = if (!is.null(title)) title else "" - ) - return(invisible(out)) - - } else { - high_col <- switch(which, Go = col_go, Gray = col_gray, NoGo = col_nogo) - gamma_thr <- switch(which, - Go = gamma_go, - NoGo = gamma_nogo, - Gray = (gamma_go + gamma_nogo) / 2) - p <- make_tile_panel(which, high_col, gamma_thr, title, base_size) - } - - # --------------------------------------------------------------------------- - # SCATTER MODE (non-grid or multiple rho_t values) - # --------------------------------------------------------------------------- - } else { - - prob_col <- if (which == "all") { - message("Non-grid input: 'which = \"all\"' shows Go probability only.") - "Go" - } else { - which - } - - high_col <- switch(prob_col, - Go = col_go, - NoGo = col_nogo, - Gray = col_gray) - prob_vals <- x[[prob_col]] - x_rng <- range(ax1) - y_rng <- range(ax2) - - df_scatter <- data.frame(ax1 = ax1, ax2 = ax2, prob_val = prob_vals) - - legend_label <- switch(prob_col, - Go = "Pr(Go)", - NoGo = "Pr(NoGo)", - Gray = "Pr(Gray)") - - p <- ggplot2::ggplot(df_scatter, - ggplot2::aes(x = ax1, y = ax2, color = prob_val)) + - ggplot2::geom_point(size = 4) + - ggplot2::scale_color_stepsn( - name = legend_label, - colors = c("white", high_col), - breaks = seq(0.1, 0.9, by = 0.1), - limits = c(0, 1), - guide = ggplot2::guide_colorsteps( - title.position = "top", - title.hjust = 0, - barheight = ggplot2::unit(base_size * 0.50, "cm"), - barwidth = ggplot2::unit(base_size * 0.06, "cm"), - direction = "vertical", - ticks = TRUE, - ticks.colour = "white", - ticks.linewidth = 1.5 - ) - ) + - ggplot2::scale_x_continuous(breaks = axis_breaks(ax1), - expand = c(0.05, 0)) + - ggplot2::scale_y_continuous(breaks = axis_breaks(ax2), - expand = c(0.05, 0)) + - ggplot2::labs(title = title, x = x_label, y = y_label) + - common_theme(base_size) - - p <- add_thresholds(p, x_rng, y_rng, base_size) - } - - print(p) - invisible(p) -} diff --git a/R/plot.qdm_boundary.R b/R/plot.qdm_boundary.R new file mode 100644 index 0000000..98efa87 --- /dev/null +++ b/R/plot.qdm_boundary.R @@ -0,0 +1,52 @@ +#' Plot a decision boundary +#' +#' Draws the decision (Go, NoGo, Gray, or Miss if it occurs) at each point of +#' the grid computed by \code{\link{qdm_boundary}} as a tile filled by the +#' decision. The edges between regions of different decisions are the +#' decision boundaries of the design. +#' +#' The plot is a \code{ggplot} object, so it can be changed further by adding +#' \pkg{ggplot2} functions, for example \code{ggplot2::labs()}, +#' \code{ggplot2::theme()} and \code{ggplot2::scale_fill_manual()}. +#' +#' @inheritParams plot.qdm_oc +#' @param x An object of class \code{"qdm_boundary"}. +#' @param ... Not used; arguments given here are ignored with a warning. +#' +#' @return A \code{ggplot} object. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' b <- qdm_boundary(des) +#' plot(b) +#' plot(b, col_gray = "gray80", base_size = 14, legend_position = "right") +#' @export +plot.qdm_boundary <- function(x, col_go = "#658D1B", col_nogo = "#D91E49", + col_gray = "#939597", col_miss = "#E69F00", + base_size = 11, legend_position = "bottom", + ...) { + axes <- attr(x, "axes") + if (is.null(axes)) { + stop("'x' must be an unmodified result of qdm_boundary().", + call. = FALSE) + } + warn_unused_dots(list(...), "plot.qdm_boundary") + cols <- decision_colors(col_go = col_go, col_nogo = col_nogo, + col_gray = col_gray, col_miss = col_miss) + style <- plot_style(base_size = base_size, + legend_position = legend_position) + d <- data.frame(x = x[[axes$x]], y = x[[axes$y]], decision = x$decision) + ggplot2::ggplot(d, ggplot2::aes(x = .data$x, y = .data$y, + fill = .data$decision)) + + ggplot2::geom_tile() + + ggplot2::scale_fill_manual(values = cols, drop = TRUE) + + ggplot2::labs(x = axes$xlab, y = axes$ylab, fill = "Decision", + caption = axes$caption) + + style$theme + + ggplot2::theme(panel.grid = ggplot2::element_blank()) +} diff --git a/R/plot.qdm_calibration.R b/R/plot.qdm_calibration.R new file mode 100644 index 0000000..17613ce --- /dev/null +++ b/R/plot.qdm_calibration.R @@ -0,0 +1,76 @@ +#' Plot a calibration +#' +#' Draws the probability that the Go criterion is met under +#' \code{scenario_go} and the probability that the NoGo criterion is met under +#' \code{scenario_nogo} against the threshold, with the targets (horizontal +#' lines) and the chosen thresholds (vertical lines). +#' +#' The plot is a \code{ggplot} object, so it can be changed further by adding +#' \pkg{ggplot2} functions, for example \code{ggplot2::labs()} and +#' \code{ggplot2::theme()}. +#' +#' @inheritParams plot.qdm_oc +#' @param x An object of class \code{"qdm_calibration"}. +#' @param col_go,col_nogo Colors of the curves, targets and thresholds of the +#' Go and NoGo criteria: color names or hexadecimal codes. The defaults +#' are green and red. +#' @param linewidth Width of the calibration curves, in the units of the +#' \code{linewidth} aesthetic of \pkg{ggplot2}. +#' @param base_size Base font size of \code{ggplot2::theme_bw()}, in points, +#' which sets the size of the axis labels, tick labels and legend. +#' @param ... Not used; arguments given here are ignored with a warning. +#' +#' @return A \code{ggplot} object. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' cal <- qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), +#' data.frame(pi_t = 0.7, pi_c = 0.4), +#' target_go = 0.05, target_nogo = 0.2) +#' plot(cal) +#' plot(cal, linewidth = 0.6, base_size = 14, legend_position = "top") +#' @export +plot.qdm_calibration <- function(x, col_go = "#658D1B", col_nogo = "#D91E49", + linewidth = 1, base_size = 11, + legend_position = "bottom", ...) { + warn_unused_dots(list(...), "plot.qdm_calibration") + cols <- decision_colors(col_go = col_go, col_nogo = col_nogo) + style <- plot_style(linewidth = linewidth, base_size = base_size, + legend_position = legend_position) + labels <- c("Go criterion met under scenario_go", + "NoGo criterion met under scenario_nogo") + long <- data.frame( + gamma = rep(x$curve$gamma, 2L), + prob = c(x$curve$prob_go, x$curve$prob_nogo), + event = factor(rep(labels, each = nrow(x$curve)), levels = labels) + ) + cols <- stats::setNames(unname(cols), labels) + targets <- data.frame(y = c(x$target_go, x$target_nogo), + event = factor(labels, levels = labels)) + chosen <- data.frame(x = c(x$gamma_go, x$gamma_nogo), + event = factor(labels, levels = labels)) + chosen <- chosen[!is.na(chosen$x), , drop = FALSE] + ggplot2::ggplot(long, ggplot2::aes(x = .data$gamma, y = .data$prob, + colour = .data$event)) + + ggplot2::geom_hline(data = targets, + ggplot2::aes(yintercept = .data$y, + colour = .data$event), + linetype = "dashed") + + ggplot2::geom_vline(data = chosen, + ggplot2::aes(xintercept = .data$x, + colour = .data$event), + linetype = "dotted") + + ggplot2::geom_step(linewidth = style$linewidth) + + ggplot2::scale_colour_manual(values = cols) + + ggplot2::scale_y_continuous(limits = c(0, 1), + breaks = seq(0, 1, by = 0.2)) + + ggplot2::labs(x = expression(gamma), y = "Probability", colour = NULL) + + style$theme + + ggplot2::theme(legend.direction = "vertical", + panel.grid.minor = ggplot2::element_blank()) +} diff --git a/R/plot.qdm_oc.R b/R/plot.qdm_oc.R new file mode 100644 index 0000000..9afe2c6 --- /dev/null +++ b/R/plot.qdm_oc.R @@ -0,0 +1,126 @@ +#' Plot operating characteristics +#' +#' Draws the probabilities of Go, NoGo and Gray decisions (and Miss decisions +#' if they have positive probability) against the true treatment effect of +#' the scenarios. For a time-to-event endpoint, the effect is the difference +#' of the milestone survival probabilities \eqn{\exp(-\log(2) t_0 / m)} +#' given by the median survival times \eqn{m} of the scenarios. For a design +#' without a concurrent control group, the horizontal axis is the true +#' response rate (binary endpoint), mean (continuous endpoint) or milestone +#' survival probability (time-to-event endpoint) of the treatment group, and +#' the thresholds of the criterion are shifted by the fixed control value, or +#' otherwise by the mean (binary and time-to-event) or location (continuous) +#' of the distribution of the control group. The scenarios must have +#' distinct values on the horizontal axis, so scenarios with the same effect +#' (for example, with several standard deviations or control parameters) are +#' plotted separately. +#' +#' For two endpoints, the plot has one heat map per decision, with the true +#' treatment effects of the two endpoints (or the true parameters of the +#' treatment group without a concurrent control group) on the axes and the +#' probability of the decision in each cell; scenarios that are not evaluable +#' are marked "NE". The scenarios must have distinct values on the axes, so +#' scenarios with several correlations (or several parameters of the control +#' group) are plotted separately. Each panel is shaded from white +#' (probability 0) to the color of its decision (probability 1); the heat maps +#' have no legend. +#' +#' The plot is a \code{ggplot} object, so it can be changed further by adding +#' \pkg{ggplot2} functions, for example \code{ggplot2::labs()} for the title +#' and the axis labels, \code{ggplot2::theme()} for the text and the legend, +#' and \code{ggplot2::scale_colour_manual()} or +#' \code{ggplot2::scale_linetype_manual()} for the curves of one endpoint. +#' The colors of the heat maps are set by the color arguments. +#' +#' @param x An object of class \code{"qdm_oc"}. +#' @param col_go,col_nogo,col_gray,col_miss Colors of the Go, NoGo, Gray and +#' Miss decisions: color names or hexadecimal codes. The defaults are +#' green, red, gray and orange. Transparency (an alpha value in the code) +#' is not used in the heat maps. +#' @param linewidth Width of the curves, in the units of the \code{linewidth} +#' aesthetic of \pkg{ggplot2}. +#' @param point_size Size of the points, in millimeters. +#' @param label_size Size of the text drawn in the plot, in millimeters: the +#' labels of the thresholds, or the probabilities in the cells of the heat +#' maps. \code{NULL} (the default) gives the size of the axis tick labels, +#' \code{0.8 * base_size / ggplot2::.pt}. +#' @param base_size Base font size of \code{ggplot2::theme_bw()}, in points, +#' which sets the size of the axis labels, tick labels, legend and caption. +#' @param legend_position Position of the legend: \code{"bottom"} (the +#' default), \code{"top"}, \code{"left"}, \code{"right"} or \code{"none"}. +#' To place the legend inside the plot, add \code{ggplot2::theme()}. +#' @param ... Not used; arguments given here are ignored with a warning. +#' +#' @return A \code{ggplot} object. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' oc <- qdm_oc(des, data.frame(pi_t = seq(0.2, 0.9, by = 0.05), pi_c = 0.4)) +#' plot(oc) +#' +#' # Other colors, thinner lines, larger text and the legend on the right, +#' # with a title added by ggplot2 +#' plot(oc, col_go = "darkgreen", col_nogo = "firebrick", linewidth = 0.6, +#' base_size = 14, legend_position = "right") + +#' ggplot2::labs(title = "Operating characteristics") +#' @export +plot.qdm_oc <- function(x, col_go = "#658D1B", col_nogo = "#D91E49", + col_gray = "#939597", col_miss = "#E69F00", + linewidth = 1, point_size = 1.5, label_size = NULL, + base_size = 11, legend_position = "bottom", ...) { + design <- attr(x, "design") + if (is.null(design)) { + stop("'x' must be an unmodified result of qdm_oc().", call. = FALSE) + } + warn_unused_dots(list(...), "plot.qdm_oc") + cols <- decision_colors(col_go = col_go, col_nogo = col_nogo, + col_gray = col_gray, col_miss = col_miss) + style <- plot_style(linewidth = linewidth, point_size = point_size, + label_size = label_size, base_size = base_size, + legend_position = legend_position) + if (design$criterion$n_endpoints == 2L) { + return(plot_oc_two(x, design, cols, style)) + } + axis <- oc_axis(design, x) + if (anyDuplicated(round(axis$x, 10)) > 0L) { + stop(paste("The scenarios must have distinct values on the horizontal", + "axis; plot scenarios with the same value separately."), + call. = FALSE) + } + decisions <- c("Go", "NoGo", "Gray", "Miss") + if (all(x$Miss <= 0)) { + decisions <- decisions[1:3] + } + ord <- order(axis$x) + long <- data.frame( + x = rep(axis$x[ord], length(decisions)), + prob = unlist(lapply(decisions, function(d) x[[d]][ord]), + use.names = FALSE), + decision = factor(rep(decisions, each = nrow(x)), levels = decisions) + ) + ltys <- c(Go = "solid", NoGo = "twodash", Gray = "dashed", + Miss = "dotted")[decisions] + ggplot2::ggplot(long, ggplot2::aes(x = .data$x, y = .data$prob, + colour = .data$decision, + linetype = .data$decision)) + + ggplot2::geom_vline(xintercept = axis$lines, colour = "gray40", + linetype = "dotted") + + ggplot2::annotate("text", x = axis$lines, y = 1, label = axis$labels, + parse = TRUE, hjust = -0.15, vjust = 1, + colour = "gray30", size = style$label_size) + + ggplot2::geom_line(linewidth = style$linewidth) + + ggplot2::geom_point(size = style$point_size) + + ggplot2::scale_colour_manual(values = cols[decisions]) + + ggplot2::scale_linetype_manual(values = ltys) + + ggplot2::scale_y_continuous(limits = c(0, 1), + breaks = seq(0, 1, by = 0.2)) + + ggplot2::labs(x = axis$xlab, y = "Probability", colour = "Decision", + linetype = "Decision", caption = axis$caption) + + style$theme + + ggplot2::theme(panel.grid.minor = ggplot2::element_blank()) +} diff --git a/R/plot_oc_two.R b/R/plot_oc_two.R new file mode 100644 index 0000000..2576d57 --- /dev/null +++ b/R/plot_oc_two.R @@ -0,0 +1,64 @@ +#' Heat maps of operating characteristics of two endpoints +#' +#' Draws one panel per decision with the scenarios on a grid of the true +#' treatment effects of the two endpoints (or the true parameters of the +#' treatment group for a design without a concurrent control group). Each +#' cell shows the probability of the decision and is shaded from white +#' (probability 0) to the color of the decision (probability 1); scenarios +#' that are not evaluable are white and marked "NE". +#' +#' @param x An object of class \code{"qdm_oc"}. +#' @param design The design of \code{x}, with two endpoints. +#' @param cols Colors of the decisions, named by decision. +#' @param style Result of \code{plot_style()}. +#' +#' @return A \code{ggplot} object. +#' @noRd +plot_oc_two <- function(x, design, cols, style) { + par <- switch(design$endpoint, + binary2 = c("pi_t1", "pi_t2", "pi_c1", "pi_c2"), + continuous2 = c("mu_t1", "mu_t2", "mu_c1", "mu_c2")) + concurrent <- design$control == "concurrent" + if (concurrent) { + ax1 <- x[[par[1L]]] - x[[par[3L]]] + ax2 <- x[[par[2L]]] - x[[par[4L]]] + labs <- c("Treatment effect on endpoint 1", + "Treatment effect on endpoint 2") + } else { + ax1 <- x[[par[1L]]] + ax2 <- x[[par[2L]]] + labs <- c("Treatment group, endpoint 1", "Treatment group, endpoint 2") + } + ax1 <- round(ax1, 10) + ax2 <- round(ax2, 10) + if (anyDuplicated(data.frame(ax1, ax2)) > 0L) { + stop(paste("The scenarios must have distinct values on the axes; plot", + "the scenarios with different correlations or control", + "parameters separately."), call. = FALSE) + } + decisions <- c("Go", "NoGo", "Gray", "Miss") + if (all(x$Miss <= 0, na.rm = TRUE)) { + decisions <- decisions[1:3] + } + lev1 <- sort(unique(ax1)) + lev2 <- sort(unique(ax2)) + long <- data.frame( + x = factor(rep(ax1, length(decisions)), levels = lev1, + labels = format(lev1, trim = TRUE)), + y = factor(rep(ax2, length(decisions)), levels = lev2, + labels = format(lev2, trim = TRUE)), + decision = factor(rep(decisions, each = nrow(x)), levels = decisions), + prob = unlist(lapply(decisions, function(d) x[[d]]), use.names = FALSE) + ) + long$label <- ifelse(is.na(long$prob), "NE", sprintf("%.2f", long$prob)) + long$fill <- shade_color(long$prob, cols[as.character(long$decision)]) + ggplot2::ggplot(long, ggplot2::aes(x = .data$x, y = .data$y)) + + ggplot2::geom_tile(ggplot2::aes(fill = .data$fill), colour = "white") + + ggplot2::geom_text(ggplot2::aes(label = .data$label), + size = style$label_size) + + ggplot2::facet_wrap(ggplot2::vars(.data$decision)) + + ggplot2::scale_fill_identity() + + ggplot2::labs(x = labs[1L], y = labs[2L]) + + style$theme + + ggplot2::theme(panel.grid = ggplot2::element_blank()) +} diff --git a/R/plot_style.R b/R/plot_style.R new file mode 100644 index 0000000..fa430b6 --- /dev/null +++ b/R/plot_style.R @@ -0,0 +1,41 @@ +#' Line widths, sizes, text and legend of a plot +#' +#' Validates the style arguments of a \code{plot()} method and builds the +#' theme of the plot (\code{ggplot2::theme_bw()} with the given base size and +#' legend position). +#' +#' @param linewidth Width of the lines of the probabilities, in the units of +#' the \code{linewidth} aesthetic of \pkg{ggplot2}. +#' @param point_size Size of the points, in millimeters. +#' @param label_size Size of the text drawn in the plot, in millimeters, or +#' \code{NULL} for the size of the axis tick labels, +#' \code{0.8 * base_size / .pt}. +#' @param base_size Base font size of the theme, in points. +#' @param legend_position One of \code{"bottom"}, \code{"top"}, +#' \code{"left"}, \code{"right"} and \code{"none"}. +#' +#' @return A list with elements \code{linewidth}, \code{point_size}, +#' \code{label_size} and \code{theme}. +#' @noRd +plot_style <- function(linewidth = 1, point_size = 1.5, label_size = NULL, + base_size = 11, legend_position = "bottom") { + check_numeric(linewidth, "linewidth", lower = 0) + check_numeric(point_size, "point_size", lower = 0) + check_numeric(base_size, "base_size", lower = 0, lower_open = TRUE) + if (is.null(label_size)) { + label_size <- 0.8 * base_size / ggplot2::.pt + } else { + check_numeric(label_size, "label_size", lower = 0) + } + positions <- c("bottom", "top", "left", "right", "none") + if (!is.character(legend_position) || length(legend_position) != 1L || + !(legend_position %in% positions)) { + stop(paste0("'legend_position' must be one of \"bottom\", \"top\", ", + "\"left\", \"right\" and \"none\"; use ggplot2::theme() ", + "to place the legend inside the plot."), call. = FALSE) + } + theme <- ggplot2::theme_bw(base_size = base_size) + + ggplot2::theme(legend.position = legend_position) + list(linewidth = linewidth, point_size = point_size, + label_size = label_size, theme = theme) +} diff --git a/R/posterior_binary.R b/R/posterior_binary.R new file mode 100644 index 0000000..0146f41 --- /dev/null +++ b/R/posterior_binary.R @@ -0,0 +1,34 @@ +#' Posterior Beta parameters for a binary endpoint +#' +#' Combines a Beta prior, external data borrowed through a power prior, +#' hypothetical control data and the current data into the parameters of the +#' Beta posterior distribution of the response rate. With prior +#' Beta(a_p, b_p), external data (n_e, y_e) with weight a_0, hypothetical +#' data (n_h, y_h) and current data (n, y), the posterior is Beta(a, b) with +#' a = a_p + a_0 y_e + y_h + y and +#' b = b_p + a_0 (n_e - y_e) + (n_h - y_h) + (n - y). +#' +#' @param prior An object of class \code{"qdm_prior_beta"}. +#' @param n Number of subjects in the current data (0 if there are none). +#' @param y Numeric vector of numbers of responders in the current data. +#' @param external An object of class \code{"qdm_borrow"} or \code{NULL}. +#' @param hypothetical An object of class \code{"qdm_hypothetical"} with +#' binary data, or \code{NULL}. +#' +#' @return A list with numeric vectors \code{a} and \code{b} of the same +#' length as \code{y}. +#' @noRd +posterior_binary <- function(prior, n, y, external = NULL, + hypothetical = NULL) { + a <- prior$a + y + b <- prior$b + (n - y) + if (!is.null(external)) { + a <- a + external$a0 * external$data$y + b <- b + external$a0 * (external$data$n - external$data$y) + } + if (!is.null(hypothetical)) { + a <- a + hypothetical$data$y + b <- b + (hypothetical$data$n - hypothetical$data$y) + } + list(a = a, b = b) +} diff --git a/R/posterior_binary2.R b/R/posterior_binary2.R new file mode 100644 index 0000000..27099c0 --- /dev/null +++ b/R/posterior_binary2.R @@ -0,0 +1,34 @@ +#' Posterior Dirichlet parameters for two binary endpoints +#' +#' Combines a Dirichlet prior, external data borrowed through a power prior +#' and hypothetical control data with the counts of the current data. With +#' prior Dir(alpha), external counts x_e with weight a_0, hypothetical counts +#' x_h and current counts x, the posterior distribution is +#' Dir(alpha + a_0 x_e + x_h + x) (Yamaguchi et al., submitted, Appendix +#' A.1.5). +#' +#' @param prior An object of class \code{"qdm_prior_dirichlet"}. +#' @param counts Integer matrix of current counts with one row per outcome +#' (or a vector of length 4). +#' @param external An object of class \code{"qdm_borrow"} or \code{NULL}. +#' @param hypothetical An object of class \code{"qdm_hypothetical"} with data +#' for two binary endpoints, or \code{NULL}. +#' +#' @return A numeric matrix of Dirichlet parameters with one row per row of +#' \code{counts} and the columns \code{"00"}, \code{"01"}, \code{"10"} and +#' \code{"11"}. +#' @noRd +posterior_binary2 <- function(prior, counts, external = NULL, + hypothetical = NULL) { + counts <- matrix(as.numeric(counts), ncol = 4L) + add <- prior$alpha + if (!is.null(external)) { + add <- add + external$a0 * external$data$counts + } + if (!is.null(hypothetical)) { + add <- add + hypothetical$data$counts + } + out <- counts + rep(as.numeric(add), each = nrow(counts)) + dimnames(out) <- list(NULL, c("00", "01", "10", "11")) + out +} diff --git a/R/posterior_continuous.R b/R/posterior_continuous.R new file mode 100644 index 0000000..9dac09c --- /dev/null +++ b/R/posterior_continuous.R @@ -0,0 +1,62 @@ +#' Posterior parameters for a continuous endpoint +#' +#' Combines a Normal-Inverse-chi-squared prior (or the vague prior), external +#' data borrowed through a power prior and the current data into the +#' parameters of the Normal-Inverse-chi-squared posterior distribution of the +#' mean and variance of one group. Data with \eqn{m} subjects, sample mean +#' \eqn{\bar y} and sample standard deviation \eqn{s}, entered with weight +#' \eqn{w} (\eqn{w = a_0} for external data and 1 for current data), update +#' the parameters as +#' \deqn{\kappa' = \kappa + w m, \quad \nu' = \nu + w m, \quad +#' \mu' = (\kappa \mu + w m \bar y) / \kappa',} +#' \deqn{\nu' \sigma'^2 = \nu \sigma^2 + w (m - 1) s^2 + +#' w m \kappa (\bar y - \mu)^2 / \kappa'.} +#' The vague prior \eqn{p(\mu, \sigma^2) \propto \sigma^{-2}} corresponds to +#' \eqn{\kappa = 0}, \eqn{\nu = -1} and \eqn{\nu \sigma^2 = 0}, which gives the +#' posterior distribution of Huang et al. (submitted, Theorem 4) with external +#' data and \eqn{\mu \mid D \sim t_{n - 1}(\bar y, s^2 / n)} without. The +#' marginal posterior distribution of the mean is +#' \eqn{t_{\nu}(\mu, \sigma^2 / \kappa)}. +#' +#' @param prior An object of class \code{"qdm_prior_nix"} or +#' \code{"qdm_prior_vague"}. +#' @param n Number of subjects in the current data (0 if there are none). +#' @param mean,sd Numeric vectors of sample means and sample standard +#' deviations of the current data (not used when \code{n} is 0). +#' @param external An object of class \code{"qdm_borrow"} or \code{NULL}. +#' +#' @return A list with elements \code{mu} and \code{sigma2} (numeric vectors +#' of the length of \code{mean}, or of length 1 when \code{n} is 0), +#' \code{kappa} and \code{nu} (numbers). +#' @noRd +posterior_continuous <- function(prior, n, mean = 0, sd = 0, + external = NULL) { + if (inherits(prior, "qdm_prior_vague")) { + mu <- 0 + kappa <- 0 + nu <- -1 + ss <- 0 + } else { + mu <- prior$mu0 + kappa <- prior$kappa0 + nu <- prior$nu0 + ss <- prior$nu0 * prior$sigma0 ^ 2 + } + updates <- list() + if (!is.null(external) && external$a0 > 0) { + updates <- list(list(w = external$a0, m = external$data$n, + ybar = external$data$mean, s = external$data$sd)) + } + if (n > 0) { + updates <- c(updates, list(list(w = 1, m = n, ybar = mean, s = sd))) + } + for (u in updates) { + kappa_new <- kappa + u$w * u$m + ss <- ss + u$w * (u$m - 1) * u$s ^ 2 + + u$w * u$m * kappa * (u$ybar - mu) ^ 2 / kappa_new + mu <- (kappa * mu + u$w * u$m * u$ybar) / kappa_new + nu <- nu + u$w * u$m + kappa <- kappa_new + } + list(mu = mu, kappa = kappa, nu = nu, sigma2 = ss / nu) +} diff --git a/R/posterior_continuous2.R b/R/posterior_continuous2.R new file mode 100644 index 0000000..5e5a3f4 --- /dev/null +++ b/R/posterior_continuous2.R @@ -0,0 +1,73 @@ +#' Posterior parameters of two continuous endpoints +#' +#' Updates the Normal-Inverse-Wishart parameters +#' \eqn{(\mu, \kappa, \nu, \Lambda)} with the external data (weight +#' \eqn{a_0}) and then with the current data (Yamaguchi et al., submitted, +#' equation A.10 and Section A.2.5). The vague prior +#' \eqn{|\Sigma|^{-3/2}} corresponds to \eqn{\kappa = 0}, \eqn{\nu = -1} +#' and \eqn{\Lambda = 0}. The current data can be given for many simulated +#' studies at once. +#' +#' @param prior An object of class \code{"qdm_prior_niw"} or +#' \code{"qdm_prior_vague"}. +#' @param n Number of subjects of the current data (0 for none). +#' @param mean Sample means: a vector of length 2 or a matrix with two +#' columns (one row per study). +#' @param cov Sample covariance matrices: a 2 x 2 matrix, or a matrix with +#' the columns \code{c11}, \code{c12} and \code{c22} (one row per study). +#' @param external An object of class \code{"qdm_borrow"} with data of two +#' continuous endpoints, or \code{NULL}. +#' +#' @return A list with elements \code{mu} (matrix with two columns), +#' \code{kappa}, \code{nu} (numbers) and \code{Lambda} (matrix with the +#' columns \code{L11}, \code{L12} and \code{L22}), one row per study. +#' @noRd +posterior_continuous2 <- function(prior, n, mean = c(0, 0), + cov = matrix(0, 2L, 2L), external = NULL) { + sym3 <- function(m) { + if (is.matrix(m) && nrow(m) == 2L && ncol(m) == 2L) { + matrix(c(m[1L, 1L], m[1L, 2L], m[2L, 2L]), 1L) + } else { + matrix(m, ncol = 3L) + } + } + mean <- matrix(mean, ncol = 2L) + cov <- sym3(cov) + if (inherits(prior, "qdm_prior_vague")) { + mu <- matrix(0, 1L, 2L) + kappa <- 0 + nu <- -1 + lam <- matrix(0, 1L, 3L) + } else { + mu <- matrix(prior$mu0, 1L, 2L) + kappa <- prior$kappa0 + nu <- prior$nu0 + lam <- sym3(prior$Lambda0) + } + updates <- list() + if (!is.null(external) && external$a0 > 0) { + updates <- list(list(w = external$a0, m = external$data$n, + ybar = matrix(external$data$mean, 1L), + s = sym3(external$data$cov))) + } + if (n > 0) { + updates <- c(updates, list(list(w = 1, m = n, ybar = mean, s = cov))) + } + for (u in updates) { + kappa_new <- kappa + u$w * u$m + nr <- max(nrow(mu), nrow(u$ybar)) + d <- u$ybar[rep_len(seq_len(nrow(u$ybar)), nr), , drop = FALSE] - + mu[rep_len(seq_len(nrow(mu)), nr), , drop = FALSE] + f <- u$w * u$m * kappa / kappa_new + lam <- lam[rep_len(seq_len(nrow(lam)), nr), , drop = FALSE] + + u$w * (u$m - 1) * u$s[rep_len(seq_len(nrow(u$s)), nr), , drop = FALSE] + + f * cbind(d[, 1L] ^ 2, d[, 1L] * d[, 2L], d[, 2L] ^ 2) + mu <- mu[rep_len(seq_len(nrow(mu)), nr), , drop = FALSE] + + u$w * u$m / kappa_new * d + nu <- nu + u$w * u$m + kappa <- kappa_new + } + dimnames(mu) <- NULL + dimnames(lam) <- list(NULL, c("L11", "L12", "L22")) + list(mu = mu, kappa = kappa, nu = nu, Lambda = lam) +} diff --git a/R/posterior_tte.R b/R/posterior_tte.R new file mode 100644 index 0000000..a9e40b4 --- /dev/null +++ b/R/posterior_tte.R @@ -0,0 +1,32 @@ +#' Posterior distribution of the hazard of a time-to-event endpoint +#' +#' With the Gamma prior of shape \eqn{a} and rate \eqn{b}, external data of +#' \eqn{d_e} events and total observed time \eqn{E_e} with power prior weight +#' \eqn{a_0}, hypothetical data \eqn{(d_h, E_h)} and current data +#' \eqn{(d, E)}, the posterior distribution of the hazard is the Gamma +#' distribution with shape \eqn{a + a_0 d_e + d_h + d} and rate +#' \eqn{b + a_0 E_e + E_h + E}. +#' +#' @param prior An object of class \code{"qdm_prior_gamma"}. +#' @param events,exposure Numeric vectors of current numbers of events and +#' total observed times (0 for none). +#' @param external External data (\code{"qdm_borrow"}) or \code{NULL}. +#' @param hypothetical Hypothetical control (\code{"qdm_hypothetical"}) or +#' \code{NULL}. +#' +#' @return A list with numeric vectors \code{shape} and \code{rate}. +#' @noRd +posterior_tte <- function(prior, events, exposure, external = NULL, + hypothetical = NULL) { + shape <- prior$shape + events + rate <- prior$rate + exposure + if (!is.null(external)) { + shape <- shape + external$a0 * external$data$events + rate <- rate + external$a0 * external$data$exposure + } + if (!is.null(hypothetical)) { + shape <- shape + hypothetical$data$events + rate <- rate + hypothetical$data$exposure + } + list(shape = shape, rate = rate) +} diff --git a/R/ppred_fixed_binary.R b/R/ppred_fixed_binary.R new file mode 100644 index 0000000..d2095f2 --- /dev/null +++ b/R/ppred_fixed_binary.R @@ -0,0 +1,28 @@ +#' Posterior predictive distribution of a future effect with a fixed control +#' +#' Probability that the future effect \eqn{Y / m - v} exceeds (or does not +#' exceed) \code{q}, where \eqn{Y} has the Beta-binomial distribution with +#' \code{m} trials and parameters \code{a} and \code{b}, and \eqn{v} is the +#' fixed control response rate. A future effect that differs from \code{q} by +#' less than \eqn{10^{-10}} is treated as equal to \code{q}, so that ties +#' such as \eqn{3 / 10 - 0.3 = 0} are not decided by rounding errors. +#' +#' @param q Null value of the future effect. +#' @param m Number of future subjects. +#' @param a,b Numeric vectors of Beta parameters. +#' @param value Fixed control response rate. +#' @param lower.tail Logical; if \code{TRUE}, \eqn{P(Y / m - v \le q)}, +#' otherwise \eqn{P(Y / m - v > q)}. +#' +#' @return A numeric vector of probabilities, one per element of \code{a}. +#' @noRd +ppred_fixed_binary <- function(q, m, a, b, value, lower.tail = TRUE) { + k <- 0:m + above <- (k / m - value) - q > 1e-10 + args <- recycle_common(list(a = a, b = b)) + out <- vapply(seq_along(args$a), function(i) { + p <- dbetabinom(k, m, args$a[i], args$b[i]) + sum(p[if (lower.tail) !above else above]) + }, numeric(1)) + pmin(pmax(out, 0), 1) +} diff --git a/R/print.pbayesdecisionprob1bin.R b/R/print.pbayesdecisionprob1bin.R deleted file mode 100644 index f522f28..0000000 --- a/R/print.pbayesdecisionprob1bin.R +++ /dev/null @@ -1,112 +0,0 @@ -#' Print Method for pbayesdecisionprob1bin Objects -#' -#' Displays a formatted summary of Go/NoGo/Gray decision probabilities -#' for binary endpoint results returned by \code{\link{pbayesdecisionprob1bin}}. -#' -#' @param x An object of class \code{pbayesdecisionprob1bin}. -#' @param digits A positive integer specifying the number of decimal places -#' for probability values. Default is 4. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns \code{x}. -#' -#' @export -print.pbayesdecisionprob1bin <- function(x, digits = 4, ...) { - # Helper: format value as string (NULL -> "NULL") - fmt <- function(v) if (is.null(v)) "NULL" else as.character(v) - - # Extract metadata from attributes - prob <- attr(x, "prob") - design <- attr(x, "design") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - n_t <- attr(x, "n_t") - n_c <- attr(x, "n_c") - a_t <- attr(x, "a_t") - a_c <- attr(x, "a_c") - b_t <- attr(x, "b_t") - b_c <- attr(x, "b_c") - z <- attr(x, "z") - m_t <- attr(x, "m_t") - m_c <- attr(x, "m_c") - ne_t <- attr(x, "ne_t") - ne_c <- attr(x, "ne_c") - ye_t <- attr(x, "ye_t") - ye_c <- attr(x, "ye_c") - alpha0e_t <- attr(x, "alpha0e_t") - alpha0e_c <- attr(x, "alpha0e_c") - error_if_Miss <- attr(x, "error_if_Miss") - Gray_inc_Miss <- attr(x, "Gray_inc_Miss") - - # Build threshold string based on probability type - if (prob == "posterior") { - theta_str <- sprintf("TV = %s, MAV = %s", - fmt(attr(x, "theta_TV")), fmt(attr(x, "theta_MAV"))) - } else { - theta_str <- sprintf("NULL = %s", fmt(attr(x, "theta_NULL"))) - } - - # Prior label depends on probability type - prior_label <- if (prob == "posterior") "Prior (Beta) " else "Prior (Beta-bin)" - - # Build info lines with fixed label width (lw) for consistent alignment - lw <- 17L # label field width - pad <- " " # left margin - - lines <- character(0) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Probability type", prob)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Design", design)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Threshold(s)", theta_str)) - lines <- c(lines, sprintf("%s%-*s: gamma_go = %s", - pad, lw, "Go threshold", fmt(gamma_go))) - lines <- c(lines, sprintf("%s%-*s: gamma_nogo = %s", - pad, lw, "NoGo threshold", fmt(gamma_nogo))) - lines <- c(lines, sprintf("%s%-*s: n_t = %s, n_c = %s", - pad, lw, "Sample size", fmt(n_t), fmt(n_c))) - lines <- c(lines, sprintf("%s%-*s: a_t = %s, a_c = %s, b_t = %s, b_c = %s", - pad, lw, prior_label, - fmt(a_t), fmt(a_c), fmt(b_t), fmt(b_c))) - if (design == "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: z = %s", - pad, lw, "Uncontrolled", fmt(z))) - } - if (prob == "predictive") { - lines <- c(lines, sprintf("%s%-*s: m_t = %s, m_c = %s", - pad, lw, "Future trial", fmt(m_t), fmt(m_c))) - } - if (design == "external") { - # Split external parameters across two lines to avoid overflow - lines <- c(lines, sprintf("%s%-*s: ne_t = %s, ne_c = %s, ye_t = %s, ye_c = %s", - pad, lw, "External data", - fmt(ne_t), fmt(ne_c), fmt(ye_t), fmt(ye_c))) - lines <- c(lines, sprintf("%s%-*s alpha0e_t = %s, alpha0e_c = %s", - pad, lw, "", fmt(alpha0e_t), fmt(alpha0e_c))) - } - lines <- c(lines, sprintf("%s%-*s: error_if_Miss = %s, Gray_inc_Miss = %s", - pad, lw, "Miss handling", - fmt(error_if_Miss), fmt(Gray_inc_Miss))) - - # Determine separator width dynamically from the longest line - title <- "Go/NoGo/Gray Decision Probabilities (Single Binary Endpoint)" - sep_width <- max(nchar(title), max(nchar(lines))) - sep <- strrep("-", sep_width) - - # Print header block - cat(title, "\n") - cat(sep, "\n") - for (ln in lines) cat(ln, "\n") - cat(sep, "\n") - - # Format probability columns only (not pi_t / pi_c) - prob_cols <- names(x)[!names(x) %in% c("pi_t", "pi_c")] - x_print <- x - x_print[prob_cols] <- lapply(x[prob_cols], function(col) { - formatC(col, digits = digits, format = "f") - }) - - # Print table without row names (explicit call to avoid recursion) - print.data.frame(x_print, row.names = FALSE, quote = FALSE) - cat(sep, "\n") - - invisible(x) -} diff --git a/R/print.pbayesdecisionprob1cont.R b/R/print.pbayesdecisionprob1cont.R deleted file mode 100644 index af3e203..0000000 --- a/R/print.pbayesdecisionprob1cont.R +++ /dev/null @@ -1,134 +0,0 @@ -#' Print Method for pbayesdecisionprob1cont Objects -#' -#' Displays a formatted summary of Go/NoGo/Gray decision probabilities -#' for continuous endpoint results returned by \code{\link{pbayesdecisionprob1cont}}. -#' -#' @param x An object of class \code{pbayesdecisionprob1cont}. -#' @param digits A positive integer specifying the number of decimal places -#' for probability values. Default is 4. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns \code{x}. -#' -#' @export -print.pbayesdecisionprob1cont <- function(x, digits = 4, ...) { - # Helper to format a value as string (NULL -> "NULL") - fmt <- function(v) if (is.null(v)) "NULL" else as.character(v) - - # Extract metadata from attributes - prob <- attr(x, "prob") - design <- attr(x, "design") - prior <- attr(x, "prior") - CalcMethod <- attr(x, "CalcMethod") - nsim <- attr(x, "nsim") - nMC <- attr(x, "nMC") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - n_t <- attr(x, "n_t") - n_c <- attr(x, "n_c") - sigma_t <- attr(x, "sigma_t") - sigma_c <- attr(x, "sigma_c") - r <- attr(x, "r") - m_t <- attr(x, "m_t") - m_c <- attr(x, "m_c") - kappa0_t <- attr(x, "kappa0_t") - kappa0_c <- attr(x, "kappa0_c") - nu0_t <- attr(x, "nu0_t") - nu0_c <- attr(x, "nu0_c") - mu0_t <- attr(x, "mu0_t") - mu0_c <- attr(x, "mu0_c") - sigma0_t <- attr(x, "sigma0_t") - sigma0_c <- attr(x, "sigma0_c") - ne_t <- attr(x, "ne_t") - ne_c <- attr(x, "ne_c") - alpha0e_t <- attr(x, "alpha0e_t") - alpha0e_c <- attr(x, "alpha0e_c") - bar_ye_t <- attr(x, "bar_ye_t") - bar_ye_c <- attr(x, "bar_ye_c") - se_t <- attr(x, "se_t") - se_c <- attr(x, "se_c") - error_if_Miss <- attr(x, "error_if_Miss") - Gray_inc_Miss <- attr(x, "Gray_inc_Miss") - seed <- attr(x, "seed") - - # Build threshold string based on probability type - if (prob == "posterior") { - theta_str <- sprintf("TV = %s, MAV = %s", - fmt(attr(x, "theta_TV")), fmt(attr(x, "theta_MAV"))) - } else { - theta_str <- sprintf("NULL = %s", fmt(attr(x, "theta_NULL"))) - } - - # Build info lines with fixed label width (lw) for consistent alignment - lw <- 17L # label field width - pad <- " " # left margin - - lines <- character(0) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Probability type", prob)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Design", design)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Prior", prior)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Calc method", CalcMethod)) - lines <- c(lines, sprintf("%s%-*s: nsim = %s", pad, lw, "Simulations", fmt(nsim))) - if (!is.null(nMC)) { - lines <- c(lines, sprintf("%s%-*s: nMC = %s", pad, lw, "MC draws", fmt(nMC))) - } - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Threshold(s)", theta_str)) - lines <- c(lines, sprintf("%s%-*s: gamma_go = %s", pad, lw, "Go threshold", fmt(gamma_go))) - lines <- c(lines, sprintf("%s%-*s: gamma_nogo = %s", pad, lw, "NoGo threshold", fmt(gamma_nogo))) - lines <- c(lines, sprintf("%s%-*s: n_t = %s, n_c = %s", - pad, lw, "Sample size", fmt(n_t), fmt(n_c))) - lines <- c(lines, sprintf("%s%-*s: sigma_t = %s, sigma_c = %s", - pad, lw, "True SD", fmt(sigma_t), fmt(sigma_c))) - if (design == "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: r = %s", pad, lw, "Variance ratio", fmt(r))) - } - if (!is.null(m_t) || !is.null(m_c)) { - lines <- c(lines, sprintf("%s%-*s: m_t = %s, m_c = %s", - pad, lw, "Future size", fmt(m_t), fmt(m_c))) - } - if (prior == "N-Inv-Chisq") { - # Split treatment and control prior parameters across two lines - lines <- c(lines, sprintf("%s%-*s: kappa0_t = %s, nu0_t = %s, mu0_t = %s, sigma0_t = %s", - pad, lw, "Prior (treatment)", - fmt(kappa0_t), fmt(nu0_t), fmt(mu0_t), fmt(sigma0_t))) - lines <- c(lines, sprintf("%s%-*s: kappa0_c = %s, nu0_c = %s, mu0_c = %s, sigma0_c = %s", - pad, lw, "Prior (control) ", - fmt(kappa0_c), fmt(nu0_c), fmt(mu0_c), fmt(sigma0_c))) - } - if (design == "external") { - # Split treatment and control external parameters across two lines each - lines <- c(lines, sprintf("%s%-*s: ne_t = %s, alpha0e_t = %s, bar_ye_t = %s, se_t = %s", - pad, lw, "External (treat.)", - fmt(ne_t), fmt(alpha0e_t), fmt(bar_ye_t), fmt(se_t))) - lines <- c(lines, sprintf("%s%-*s: ne_c = %s, alpha0e_c = %s, bar_ye_c = %s, se_c = %s", - pad, lw, "External (cont.) ", - fmt(ne_c), fmt(alpha0e_c), fmt(bar_ye_c), fmt(se_c))) - } - lines <- c(lines, sprintf("%s%-*s: error_if_Miss = %s, Gray_inc_Miss = %s", - pad, lw, "Miss handling", - fmt(error_if_Miss), fmt(Gray_inc_Miss))) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Seed", fmt(seed))) - - # Determine separator width dynamically from the longest line - title <- "Go/NoGo/Gray Decision Probabilities (Single Continuous Endpoint)" - sep_width <- max(nchar(title), max(nchar(lines))) - sep <- strrep("-", sep_width) - - # Print header block - cat(title, "\n") - cat(sep, "\n") - for (ln in lines) cat(ln, "\n") - cat(sep, "\n") - - # Format probability columns only (not mu_t / mu_c) - df_print <- as.data.frame(x) - prob_cols <- names(df_print)[!names(df_print) %in% c("mu_t", "mu_c")] - df_print[prob_cols] <- lapply(df_print[prob_cols], - function(col) round(col, digits)) - - # Print table without row names (explicit call to avoid recursion) - print.data.frame(df_print, row.names = FALSE) - cat(sep, "\n") - - invisible(x) -} diff --git a/R/print.pbayesdecisionprob2bin.R b/R/print.pbayesdecisionprob2bin.R deleted file mode 100644 index 67cba44..0000000 --- a/R/print.pbayesdecisionprob2bin.R +++ /dev/null @@ -1,168 +0,0 @@ -#' Print Method for pbayesdecisionprob2bin Objects -#' -#' Displays a formatted summary of Go/NoGo/Gray decision probabilities for -#' two-binary-endpoint results returned by \code{\link{pbayesdecisionprob2bin}}. -#' -#' @param x An object of class \code{pbayesdecisionprob2bin}. -#' @param digits A positive integer specifying the number of decimal places -#' for probability values. Default is 4. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns \code{x}. -#' -#' @export -print.pbayesdecisionprob2bin <- function(x, digits = 4, ...) { - - # Helper: format a value as string (NULL -> "NULL") - fmt <- function(v) if (is.null(v)) "NULL" else as.character(v) - - # Extract metadata - prob <- attr(x, "prob") - design <- attr(x, "design") - GoRegions <- attr(x, "GoRegions") - NoGoRegions <- attr(x, "NoGoRegions") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - n_t <- attr(x, "n_t") - n_c <- attr(x, "n_c") - a_t_00 <- attr(x, "a_t_00") - a_t_01 <- attr(x, "a_t_01") - a_t_10 <- attr(x, "a_t_10") - a_t_11 <- attr(x, "a_t_11") - a_c_00 <- attr(x, "a_c_00") - a_c_01 <- attr(x, "a_c_01") - a_c_10 <- attr(x, "a_c_10") - a_c_11 <- attr(x, "a_c_11") - m_t <- attr(x, "m_t") - m_c <- attr(x, "m_c") - theta_TV1 <- attr(x, "theta_TV1") - theta_MAV1 <- attr(x, "theta_MAV1") - theta_TV2 <- attr(x, "theta_TV2") - theta_MAV2 <- attr(x, "theta_MAV2") - theta_NULL1 <- attr(x, "theta_NULL1") - theta_NULL2 <- attr(x, "theta_NULL2") - z00 <- attr(x, "z00") - z01 <- attr(x, "z01") - z10 <- attr(x, "z10") - z11 <- attr(x, "z11") - xe_t_00 <- attr(x, "xe_t_00") - xe_t_01 <- attr(x, "xe_t_01") - xe_t_10 <- attr(x, "xe_t_10") - xe_t_11 <- attr(x, "xe_t_11") - xe_c_00 <- attr(x, "xe_c_00") - xe_c_01 <- attr(x, "xe_c_01") - xe_c_10 <- attr(x, "xe_c_10") - xe_c_11 <- attr(x, "xe_c_11") - alpha0e_t <- attr(x, "alpha0e_t") - alpha0e_c <- attr(x, "alpha0e_c") - nMC <- attr(x, "nMC") - nsim <- attr(x, "nsim") - CalcMethod <- attr(x, "CalcMethod") - error_if_Miss <- attr(x, "error_if_Miss") - Gray_inc_Miss <- attr(x, "Gray_inc_Miss") - - # Build info lines with fixed label width (lw) for consistent alignment - lw <- 17L # label field width - pad <- " " # left margin - - lines <- character(0) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Probability type", prob)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Design", design)) - - # Threshold(s): split posterior across two lines to avoid overflow - if (prob == "posterior") { - lines <- c(lines, sprintf("%s%-*s: TV1 = %s, MAV1 = %s", - pad, lw, "Threshold(s)", - fmt(theta_TV1), fmt(theta_MAV1))) - lines <- c(lines, sprintf("%s%-*s TV2 = %s, MAV2 = %s", - pad, lw, "", - fmt(theta_TV2), fmt(theta_MAV2))) - } else { - lines <- c(lines, sprintf("%s%-*s: NULL1 = %s, NULL2 = %s", - pad, lw, "Threshold(s)", - fmt(theta_NULL1), fmt(theta_NULL2))) - } - - lines <- c(lines, sprintf("%s%-*s: gamma_go = %s", - pad, lw, "Go threshold", fmt(gamma_go))) - lines <- c(lines, sprintf("%s%-*s: gamma_nogo = %s", - pad, lw, "NoGo threshold", fmt(gamma_nogo))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "Go regions", - paste(GoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "NoGo regions", - paste(NoGoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: n_t = %s, n_c = %s", - pad, lw, "Sample size", fmt(n_t), fmt(n_c))) - - # Dirichlet prior: treatment and control on separate lines - lines <- c(lines, sprintf( - "%s%-*s: a_t = (%s, %s, %s, %s) [a_00, a_01, a_10, a_11]", - pad, lw, "Prior (treatment)", - fmt(a_t_00), fmt(a_t_01), fmt(a_t_10), fmt(a_t_11))) - lines <- c(lines, sprintf( - "%s%-*s: a_c = (%s, %s, %s, %s) [a_00, a_01, a_10, a_11]", - pad, lw, "Prior (control) ", - fmt(a_c_00), fmt(a_c_01), fmt(a_c_10), fmt(a_c_11))) - - if (design == "uncontrolled") { - lines <- c(lines, sprintf( - "%s%-*s: z = (%s, %s, %s, %s) [z00, z01, z10, z11]", - pad, lw, "Hyp. control", - fmt(z00), fmt(z01), fmt(z10), fmt(z11))) - } - if (prob == "predictive") { - lines <- c(lines, sprintf("%s%-*s: m_t = %s, m_c = %s", - pad, lw, "Future trial", fmt(m_t), fmt(m_c))) - } - if (design == "external") { - # External data: treatment and control counts on separate lines, - # followed by power prior weights - lines <- c(lines, sprintf( - "%s%-*s: xe_t = (%s, %s, %s, %s) [xe_00, xe_01, xe_10, xe_11]", - pad, lw, "External (treat.)", - fmt(xe_t_00), fmt(xe_t_01), fmt(xe_t_10), fmt(xe_t_11))) - lines <- c(lines, sprintf( - "%s%-*s: xe_c = (%s, %s, %s, %s) [xe_00, xe_01, xe_10, xe_11]", - pad, lw, "External (cont.) ", - fmt(xe_c_00), fmt(xe_c_01), fmt(xe_c_10), fmt(xe_c_11))) - lines <- c(lines, sprintf("%s%-*s: alpha0e_t = %s, alpha0e_c = %s", - pad, lw, "Power prior", - fmt(alpha0e_t), fmt(alpha0e_c))) - } - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Method", fmt(CalcMethod))) - lines <- c(lines, sprintf("%s%-*s: nMC = %s", pad, lw, "MC draws", fmt(nMC))) - if (CalcMethod == "MC") { - lines <- c(lines, sprintf("%s%-*s: nsim = %s", pad, lw, "Sim size", fmt(nsim))) - } - lines <- c(lines, sprintf("%s%-*s: error_if_Miss = %s, Gray_inc_Miss = %s", - pad, lw, "Miss handling", - fmt(error_if_Miss), fmt(Gray_inc_Miss))) - - # Determine separator width dynamically from the longest line - title <- "Go/NoGo/Gray Decision Probabilities (Two Binary Endpoints)" - sep_width <- max(nchar(title), max(nchar(lines))) - sep <- strrep("-", sep_width) - - # Print header block - cat(title, "\n") - cat(sep, "\n") - for (ln in lines) cat(ln, "\n") - cat(sep, "\n") - - # Format probability columns only (not scenario columns) - scenario_cols <- c("pi_t1", "pi_t2", "rho_t", "pi_c1", "pi_c2", "rho_c") - prob_cols <- names(x)[!names(x) %in% scenario_cols] - - x_print <- x - x_print[prob_cols] <- lapply(x[prob_cols], function(col) { - formatC(col, digits = digits, format = "f") - }) - - # Print table without row names (explicit call to avoid recursion) - print.data.frame(x_print, row.names = FALSE, quote = FALSE) - cat(sep, "\n") - - invisible(x) -} diff --git a/R/print.pbayesdecisionprob2cont.R b/R/print.pbayesdecisionprob2cont.R deleted file mode 100644 index 0200819..0000000 --- a/R/print.pbayesdecisionprob2cont.R +++ /dev/null @@ -1,190 +0,0 @@ -#' Print Method for pbayesdecisionprob2cont Objects -#' -#' Displays a formatted summary of Go/NoGo/Gray decision probabilities for -#' two-continuous-endpoint results returned by -#' \code{\link{pbayesdecisionprob2cont}}. -#' -#' @param x An object of class \code{pbayesdecisionprob2cont}. -#' @param digits A positive integer specifying the number of decimal places -#' for probability values. Default is 4. -#' @param ... Further arguments passed to or from other methods (ignored). -#' -#' @return Invisibly returns \code{x}. -#' -#' @export -print.pbayesdecisionprob2cont <- function(x, digits = 4, ...) { - - # Helper: format a scalar/vector/NULL as string - fmt <- function(v) { - if (is.null(v)) return("NULL") - if (length(v) > 1) return(paste0("(", paste(v, collapse = ", "), ")")) - as.character(v) - } - - # Helper: format a 2x2 matrix as "[r1c1, r1c2; r2c1, r2c2]" - fmt_mat <- function(m) { - if (is.null(m)) return("NULL") - sprintf("[%s, %s; %s, %s]", m[1,1], m[1,2], m[2,1], m[2,2]) - } - - # Extract metadata from attributes - prob <- attr(x, "prob") - design <- attr(x, "design") - prior <- attr(x, "prior") - nsim <- attr(x, "nsim") - nMC <- attr(x, "nMC") - method <- attr(x, "method") - GoRegions <- attr(x, "GoRegions") - NoGoRegions <- attr(x, "NoGoRegions") - gamma_go <- attr(x, "gamma_go") - gamma_nogo <- attr(x, "gamma_nogo") - theta_TV1 <- attr(x, "theta_TV1") - theta_MAV1 <- attr(x, "theta_MAV1") - theta_TV2 <- attr(x, "theta_TV2") - theta_MAV2 <- attr(x, "theta_MAV2") - theta_NULL1 <- attr(x, "theta_NULL1") - theta_NULL2 <- attr(x, "theta_NULL2") - n_t <- attr(x, "n_t") - n_c <- attr(x, "n_c") - m_t <- attr(x, "m_t") - m_c <- attr(x, "m_c") - Sigma_t <- attr(x, "Sigma_t") - Sigma_c <- attr(x, "Sigma_c") - kappa0_t <- attr(x, "kappa0_t") - nu0_t <- attr(x, "nu0_t") - mu0_t <- attr(x, "mu0_t") - Lambda0_t <- attr(x, "Lambda0_t") - kappa0_c <- attr(x, "kappa0_c") - nu0_c <- attr(x, "nu0_c") - mu0_c <- attr(x, "mu0_c") - Lambda0_c <- attr(x, "Lambda0_c") - r <- attr(x, "r") - ne_t <- attr(x, "ne_t") - ne_c <- attr(x, "ne_c") - alpha0e_t <- attr(x, "alpha0e_t") - alpha0e_c <- attr(x, "alpha0e_c") - bar_ye_t <- attr(x, "bar_ye_t") - bar_ye_c <- attr(x, "bar_ye_c") - se_t <- attr(x, "se_t") - se_c <- attr(x, "se_c") - error_if_Miss <- attr(x, "error_if_Miss") - Gray_inc_Miss <- attr(x, "Gray_inc_Miss") - seed <- attr(x, "seed") - - # Build info lines with fixed label width (lw) for consistent alignment - lw <- 17L # label field width - pad <- " " # left margin - - lines <- character(0) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Probability type", prob)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Design", design)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Prior", prior)) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Method", fmt(method))) - lines <- c(lines, sprintf("%s%-*s: nsim = %s", pad, lw, "Simulations", fmt(nsim))) - lines <- c(lines, sprintf("%s%-*s: nMC = %s", pad, lw, "MC draws", fmt(nMC))) - lines <- c(lines, sprintf("%s%-*s: %s", pad, lw, "Seed", fmt(seed))) - - # Threshold(s): split posterior across two lines to avoid overflow - if (prob == "posterior") { - lines <- c(lines, sprintf("%s%-*s: TV1 = %s, MAV1 = %s", - pad, lw, "Threshold(s)", - fmt(theta_TV1), fmt(theta_MAV1))) - lines <- c(lines, sprintf("%s%-*s TV2 = %s, MAV2 = %s", - pad, lw, "", - fmt(theta_TV2), fmt(theta_MAV2))) - } else { - lines <- c(lines, sprintf("%s%-*s: NULL1 = %s, NULL2 = %s", - pad, lw, "Threshold(s)", - fmt(theta_NULL1), fmt(theta_NULL2))) - } - - lines <- c(lines, sprintf("%s%-*s: gamma_go = %s", - pad, lw, "Go threshold", fmt(gamma_go))) - lines <- c(lines, sprintf("%s%-*s: gamma_nogo = %s", - pad, lw, "NoGo threshold", fmt(gamma_nogo))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "Go regions", - paste(GoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: {%s}", - pad, lw, "NoGo regions", - paste(NoGoRegions, collapse = ", "))) - lines <- c(lines, sprintf("%s%-*s: n_t = %s, n_c = %s", - pad, lw, "Sample size", fmt(n_t), fmt(n_c))) - lines <- c(lines, sprintf("%s%-*s: Sigma_t = %s", - pad, lw, "True cov (treat.)", fmt_mat(Sigma_t))) - if (design != "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: Sigma_c = %s", - pad, lw, "True cov (cont.) ", fmt_mat(Sigma_c))) - } - - # N-Inv-Wishart prior: treatment and control each split across two lines - if (prior == "N-Inv-Wishart") { - lines <- c(lines, sprintf( - "%s%-*s: kappa0_t = %s, nu0_t = %s, mu0_t = %s", - pad, lw, "Prior (treatment)", fmt(kappa0_t), fmt(nu0_t), fmt(mu0_t))) - lines <- c(lines, sprintf("%s%-*s Lambda0_t = %s", - pad, lw, "", fmt_mat(Lambda0_t))) - if (design %in% c("controlled", "external")) { - lines <- c(lines, sprintf( - "%s%-*s: kappa0_c = %s, nu0_c = %s, mu0_c = %s", - pad, lw, "Prior (control) ", fmt(kappa0_c), fmt(nu0_c), fmt(mu0_c))) - lines <- c(lines, sprintf("%s%-*s Lambda0_c = %s", - pad, lw, "", fmt_mat(Lambda0_c))) - } - } - - if (design == "uncontrolled") { - lines <- c(lines, sprintf("%s%-*s: mu0_c = %s, r = %s", - pad, lw, "Hyp. control", fmt(mu0_c), fmt(r))) - } - if (prob == "predictive") { - lines <- c(lines, sprintf("%s%-*s: m_t = %s, m_c = %s", - pad, lw, "Future trial", fmt(m_t), fmt(m_c))) - } - if (design == "external") { - # External data: treatment and control on separate lines - lines <- c(lines, sprintf( - "%s%-*s: ne_t = %s, alpha0e_t = %s", - pad, lw, "External (treat.)", fmt(ne_t), fmt(alpha0e_t))) - if (!is.null(bar_ye_t)) { - lines <- c(lines, sprintf("%s%-*s bar_ye_t = %s, se_t = %s", - pad, lw, "", fmt(bar_ye_t), fmt(se_t))) - } - lines <- c(lines, sprintf( - "%s%-*s: ne_c = %s, alpha0e_c = %s", - pad, lw, "External (cont.) ", fmt(ne_c), fmt(alpha0e_c))) - if (!is.null(bar_ye_c)) { - lines <- c(lines, sprintf("%s%-*s bar_ye_c = %s, se_c = %s", - pad, lw, "", fmt(bar_ye_c), fmt(se_c))) - } - } - lines <- c(lines, sprintf("%s%-*s: error_if_Miss = %s, Gray_inc_Miss = %s", - pad, lw, "Miss handling", - fmt(error_if_Miss), fmt(Gray_inc_Miss))) - - # Determine separator width dynamically from the longest line - title <- "Go/NoGo/Gray Decision Probabilities (Two Continuous Endpoints)" - sep_width <- max(nchar(title), max(nchar(lines))) - sep <- strrep("-", sep_width) - - # Print header block - cat(title, "\n") - cat(sep, "\n") - for (ln in lines) cat(ln, "\n") - cat(sep, "\n") - - # Format probability columns only (not scenario columns) - scenario_cols <- c("mu_t1", "mu_t2", "mu_c1", "mu_c2") - prob_cols <- names(x)[!names(x) %in% scenario_cols] - - x_print <- x - x_print[prob_cols] <- lapply(x[prob_cols], function(col) { - formatC(col, digits = digits, format = "f") - }) - - # Print table without row names (explicit call to avoid recursion) - print.data.frame(x_print, row.names = FALSE, quote = FALSE) - cat(sep, "\n") - - invisible(x) -} diff --git a/R/print.qdm_borrow.R b/R/print.qdm_borrow.R new file mode 100644 index 0000000..6a410b0 --- /dev/null +++ b/R/print.qdm_borrow.R @@ -0,0 +1,14 @@ +#' Print an external data specification +#' +#' @param x An object of class \code{"qdm_borrow"}. +#' @param ... Passed to \code{\link{format.qdm_borrow}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' print(borrow(data_binary(n = 20, y = 8), a0 = 0.5)) +#' @export +print.qdm_borrow <- function(x, ...) { + cat("External data:", format(x, ...), "\n") + invisible(x) +} diff --git a/R/print.qdm_boundary.R b/R/print.qdm_boundary.R new file mode 100644 index 0000000..c798fd5 --- /dev/null +++ b/R/print.qdm_boundary.R @@ -0,0 +1,34 @@ +#' Print a decision boundary +#' +#' Prints the number of grid points with each decision and the first rows of +#' the grid. +#' +#' @param x An object of class \code{"qdm_boundary"}. +#' @param ... Not used. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' qdm_boundary(des) +#' @export +print.qdm_boundary <- function(x, ...) { + counts <- table(x$decision) + cat(sprintf("Decision boundary on a grid of %d point%s (%s)\n", nrow(x), + if (nrow(x) == 1L) "" else "s", + paste(names(counts), counts, sep = ": ", collapse = ", "))) + df <- as.data.frame(x) + attr(df, "design") <- NULL + attr(df, "axes") <- NULL + print(df[seq_len(min(6L, nrow(df))), , drop = FALSE]) + k <- nrow(df) - 6L + if (k > 0L) { + cat(sprintf("... %d more row%s\n", k, if (k == 1L) "" else "s")) + } + invisible(x) +} diff --git a/R/print.qdm_calibration.R b/R/print.qdm_calibration.R new file mode 100644 index 0000000..051eb1c --- /dev/null +++ b/R/print.qdm_calibration.R @@ -0,0 +1,30 @@ +#' Print a calibration +#' +#' Prints the chosen thresholds and the decision probabilities of the design +#' with these thresholds under the two scenarios. +#' +#' @param x An object of class \code{"qdm_calibration"}. +#' @param digits Number of significant digits for numeric values. +#' @param ... Not used. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' print(qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), +#' data.frame(pi_t = 0.7, pi_c = 0.4), +#' target_go = 0.05, target_nogo = 0.2)) +#' @export +print.qdm_calibration <- function(x, digits = 4L, ...) { + cat(format(x, digits = digits), sep = "\n") + if (!is.null(x$oc)) { + cat("Decision probabilities with the chosen thresholds\n") + print(x$oc, digits = digits, row.names = FALSE) + } + invisible(x) +} diff --git a/R/print.qdm_conduct.R b/R/print.qdm_conduct.R new file mode 100644 index 0000000..2ab0c3b --- /dev/null +++ b/R/print.qdm_conduct.R @@ -0,0 +1,14 @@ +#' Print the conduct of a study +#' +#' @param x An object of class \code{"qdm_conduct"}. +#' @param ... Passed to \code{\link{format.qdm_conduct}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' conduct_tte(accrual_time = c(0, 12), cut_events = 20) +#' @export +print.qdm_conduct <- function(x, ...) { + cat(format(x, ...), sep = "\n") + invisible(x) +} diff --git a/R/print.qdm_criterion.R b/R/print.qdm_criterion.R new file mode 100644 index 0000000..af2a89f --- /dev/null +++ b/R/print.qdm_criterion.R @@ -0,0 +1,15 @@ +#' Print a decision criterion +#' +#' @param x An object of class \code{"qdm_criterion"}. +#' @param ... Passed to \code{\link{format.qdm_criterion}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' print(criterion_predictive(theta_null = 0, m_t = 50, gamma_go = 0.9, +#' gamma_nogo = 0.7)) +#' @export +print.qdm_criterion <- function(x, ...) { + cat(format(x, ...), sep = "\n") + invisible(x) +} diff --git a/R/print.qdm_data.R b/R/print.qdm_data.R new file mode 100644 index 0000000..dd4c5e5 --- /dev/null +++ b/R/print.qdm_data.R @@ -0,0 +1,14 @@ +#' Print a data specification +#' +#' @param x An object of class \code{"qdm_data"}. +#' @param ... Passed to \code{\link{format.qdm_data}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' print(data_continuous(n = 12, mean = 3.2, sd = 2)) +#' @export +print.qdm_data <- function(x, ...) { + cat("Data:", format(x, ...), "\n") + invisible(x) +} diff --git a/R/print.qdm_decision.R b/R/print.qdm_decision.R new file mode 100644 index 0000000..7a2aa31 --- /dev/null +++ b/R/print.qdm_decision.R @@ -0,0 +1,20 @@ +#' Print a decision +#' +#' @param x An object of class \code{"qdm_decision"}. +#' @param ... Passed to \code{\link{format.qdm_decision}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_predictive(theta_null = 0, m_t = 50, +#' gamma_go = 0.9, gamma_nogo = 0.7) +#' ) +#' print(qdm_decide(des, data_binary(12, 9), data_binary(12, 4))) +#' @export +print.qdm_decision <- function(x, ...) { + cat(format(x, ...), sep = "\n") + invisible(x) +} diff --git a/R/print.qdm_design.R b/R/print.qdm_design.R new file mode 100644 index 0000000..deb8e17 --- /dev/null +++ b/R/print.qdm_design.R @@ -0,0 +1,21 @@ +#' Print a design +#' +#' @param x An object of class \code{"qdm_design"}. +#' @param ... Passed to \code{\link{format.qdm_design}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 0, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8), +#' hypothetical_c = hypothetical(data = data_binary(n = 12, y = 4)) +#' ) +#' print(des) +#' @export +print.qdm_design <- function(x, ...) { + cat(format(x, ...), sep = "\n") + invisible(x) +} diff --git a/R/print.qdm_hypothetical.R b/R/print.qdm_hypothetical.R new file mode 100644 index 0000000..de096ca --- /dev/null +++ b/R/print.qdm_hypothetical.R @@ -0,0 +1,14 @@ +#' Print a hypothetical control specification +#' +#' @param x An object of class \code{"qdm_hypothetical"}. +#' @param ... Passed to \code{\link{format.qdm_hypothetical}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' print(hypothetical(data = data_binary(n = 15, y = 5))) +#' @export +print.qdm_hypothetical <- function(x, ...) { + cat("Hypothetical control:", format(x, ...), "\n") + invisible(x) +} diff --git a/R/print.qdm_oc.R b/R/print.qdm_oc.R new file mode 100644 index 0000000..04036b9 --- /dev/null +++ b/R/print.qdm_oc.R @@ -0,0 +1,29 @@ +#' Print operating characteristics +#' +#' @param x An object of class \code{"qdm_oc"}. +#' @param digits Number of significant digits for the probabilities. +#' @param ... Not used. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' print(qdm_oc(des, data.frame(pi_t = c(0.4, 0.6), pi_c = 0.4))) +#' @export +print.qdm_oc <- function(x, digits = 4L, ...) { + method <- attr(x, "method") + if (!is.null(method)) { + cat(sprintf("Operating characteristics (%s)\n", method)) + } + y <- x + class(y) <- "data.frame" + attr(y, "design") <- NULL + attr(y, "method") <- NULL + print(y, digits = digits, row.names = FALSE) + invisible(x) +} diff --git a/R/print.qdm_prior.R b/R/print.qdm_prior.R new file mode 100644 index 0000000..9afe8cf --- /dev/null +++ b/R/print.qdm_prior.R @@ -0,0 +1,14 @@ +#' Print a prior specification +#' +#' @param x An object of class \code{"qdm_prior"}. +#' @param ... Passed to \code{\link{format.qdm_prior}}. +#' +#' @return \code{x}, invisibly. +#' +#' @examples +#' print(prior_nix(mu0 = 0, kappa0 = 1, nu0 = 3, sigma0 = 2)) +#' @export +print.qdm_prior <- function(x, ...) { + cat("Prior:", format(x, ...), "\n") + invisible(x) +} diff --git a/R/prior_beta.R b/R/prior_beta.R new file mode 100644 index 0000000..96e1dcc --- /dev/null +++ b/R/prior_beta.R @@ -0,0 +1,20 @@ +#' Beta prior for a response rate +#' +#' Creates a Beta prior distribution for the response rate of one group in an +#' analysis of a single binary endpoint. +#' +#' @param a,b Positive shape parameters. \code{prior_beta(0.5, 0.5)} is the +#' Jeffreys prior and \code{prior_beta(1, 1)} is the uniform prior. +#' +#' @return An object of class \code{c("qdm_prior_beta", "qdm_prior")} with +#' elements \code{a} and \code{b}. +#' +#' @family priors +#' @examples +#' prior_beta(0.5, 0.5) +#' @export +prior_beta <- function(a, b) { + check_numeric(a, "a", lower = 0, lower_open = TRUE) + check_numeric(b, "b", lower = 0, lower_open = TRUE) + structure(list(a = a, b = b), class = c("qdm_prior_beta", "qdm_prior")) +} diff --git a/R/prior_dirichlet.R b/R/prior_dirichlet.R new file mode 100644 index 0000000..7f1f4a8 --- /dev/null +++ b/R/prior_dirichlet.R @@ -0,0 +1,29 @@ +#' Dirichlet prior for two binary endpoints +#' +#' Creates a Dirichlet prior distribution for the four joint response +#' probabilities of two binary endpoints in one group. +#' +#' The four cells are ordered as \code{"00"}, \code{"01"}, \code{"10"} and +#' \code{"11"}, where the first digit is the response on endpoint 1 and the +#' second digit is the response on endpoint 2 (1 = response, 0 = no +#' response). The marginal response rates are therefore +#' \eqn{\pi_1 = p_{10} + p_{11}} and \eqn{\pi_2 = p_{01} + p_{11}}. +#' With \code{alpha = rep(0.25, 4)}, each marginal response rate has a +#' Beta(0.5, 0.5) prior distribution. +#' +#' @param alpha A numeric vector of four positive concentration parameters in +#' the cell order \code{"00"}, \code{"01"}, \code{"10"}, \code{"11"}. +#' +#' @return An object of class \code{c("qdm_prior_dirichlet", "qdm_prior")} +#' with element \code{alpha}, a named numeric vector of length 4. +#' +#' @family priors +#' @examples +#' prior_dirichlet(rep(0.25, 4)) +#' @export +prior_dirichlet <- function(alpha) { + check_numeric(alpha, "alpha", len = 4L, lower = 0, lower_open = TRUE) + alpha <- stats::setNames(as.numeric(alpha), c("00", "01", "10", "11")) + structure(list(alpha = alpha), + class = c("qdm_prior_dirichlet", "qdm_prior")) +} diff --git a/R/prior_gamma.R b/R/prior_gamma.R new file mode 100644 index 0000000..363f254 --- /dev/null +++ b/R/prior_gamma.R @@ -0,0 +1,28 @@ +#' Gamma prior for a hazard rate +#' +#' Creates a Gamma prior distribution for the hazard rate \eqn{\lambda} of +#' one group in an analysis of a time-to-event endpoint with exponential +#' event times. The milestone survival probability at time \eqn{t_0} is +#' \eqn{S(t_0) = \exp(-\lambda t_0)}. +#' +#' The prior is equivalent to \code{shape} events observed during a total +#' observed time of \code{rate}, so small values give a weakly informative +#' prior: \code{prior_gamma(0.1, 1)} carries the information of a tenth of an +#' event. +#' +#' @param shape,rate Positive shape and rate parameters (the prior mean of +#' the hazard is \code{shape / rate}). +#' +#' @return An object of class \code{c("qdm_prior_gamma", "qdm_prior")} with +#' elements \code{shape} and \code{rate}. +#' +#' @family priors +#' @examples +#' prior_gamma(0.1, 1) +#' @export +prior_gamma <- function(shape, rate) { + check_numeric(shape, "shape", lower = 0, lower_open = TRUE) + check_numeric(rate, "rate", lower = 0, lower_open = TRUE) + structure(list(shape = shape, rate = rate), + class = c("qdm_prior_gamma", "qdm_prior")) +} diff --git a/R/prior_niw.R b/R/prior_niw.R new file mode 100644 index 0000000..bcaa406 --- /dev/null +++ b/R/prior_niw.R @@ -0,0 +1,30 @@ +#' Normal-Inverse-Wishart prior for two continuous endpoints +#' +#' Creates the conjugate Normal-Inverse-Wishart prior for the mean vector +#' \eqn{\mu} and covariance matrix \eqn{\Sigma} of a bivariate normal endpoint +#' in one group: +#' \deqn{\mu \mid \Sigma \sim N_2(\mu_0, \Sigma / \kappa_0), \quad +#' \Sigma \sim \textrm{Inv-Wishart}(\nu_0, \Lambda_0).} +#' +#' @param mu0 Numeric vector of length 2, the prior mean of \eqn{\mu}. +#' @param kappa0 Positive prior sample size for \eqn{\mu}. +#' @param nu0 Prior degrees of freedom of the inverse Wishart distribution; +#' must be greater than 1. +#' @param Lambda0 A 2 x 2 symmetric positive definite scale matrix. +#' +#' @return An object of class \code{c("qdm_prior_niw", "qdm_prior")} with +#' elements \code{mu0}, \code{kappa0}, \code{nu0} and \code{Lambda0}. +#' +#' @family priors +#' @examples +#' prior_niw(mu0 = c(0, 0), kappa0 = 1, nu0 = 4, Lambda0 = diag(2)) +#' @export +prior_niw <- function(mu0, kappa0, nu0, Lambda0) { + check_numeric(mu0, "mu0", len = 2L) + check_numeric(kappa0, "kappa0", lower = 0, lower_open = TRUE) + check_numeric(nu0, "nu0", lower = 1, lower_open = TRUE) + check_pd_matrix(Lambda0, "Lambda0") + structure(list(mu0 = as.numeric(mu0), kappa0 = kappa0, nu0 = nu0, + Lambda0 = unname(Lambda0)), + class = c("qdm_prior_niw", "qdm_prior")) +} diff --git a/R/prior_nix.R b/R/prior_nix.R new file mode 100644 index 0000000..1cb807c --- /dev/null +++ b/R/prior_nix.R @@ -0,0 +1,30 @@ +#' Normal-Inverse-chi-squared prior for a continuous endpoint +#' +#' Creates the conjugate Normal-Inverse-chi-squared prior for the mean +#' \eqn{\mu} and variance \eqn{\sigma^2} of a normally distributed endpoint in +#' one group: +#' \deqn{\mu \mid \sigma^2 \sim N(\mu_0, \sigma^2 / \kappa_0), \quad +#' \sigma^2 \sim \textrm{Inv-}\chi^2(\nu_0, \sigma_0^2).} +#' +#' @param mu0 Prior mean of \eqn{\mu}. +#' @param kappa0 Positive prior sample size for \eqn{\mu}. +#' @param nu0 Positive prior degrees of freedom for \eqn{\sigma^2}. +#' @param sigma0 Positive prior scale of \eqn{\sigma}, on the standard +#' deviation scale (the scaled inverse chi-squared distribution has scale +#' parameter \code{sigma0^2}). +#' +#' @return An object of class \code{c("qdm_prior_nix", "qdm_prior")} with +#' elements \code{mu0}, \code{kappa0}, \code{nu0} and \code{sigma0}. +#' +#' @family priors +#' @examples +#' prior_nix(mu0 = 0, kappa0 = 1, nu0 = 3, sigma0 = 2) +#' @export +prior_nix <- function(mu0, kappa0, nu0, sigma0) { + check_numeric(mu0, "mu0") + check_numeric(kappa0, "kappa0", lower = 0, lower_open = TRUE) + check_numeric(nu0, "nu0", lower = 0, lower_open = TRUE) + check_numeric(sigma0, "sigma0", lower = 0, lower_open = TRUE) + structure(list(mu0 = mu0, kappa0 = kappa0, nu0 = nu0, sigma0 = sigma0), + class = c("qdm_prior_nix", "qdm_prior")) +} diff --git a/R/prior_vague.R b/R/prior_vague.R new file mode 100644 index 0000000..120c00a --- /dev/null +++ b/R/prior_vague.R @@ -0,0 +1,19 @@ +#' Vague prior for continuous endpoints +#' +#' Creates the vague (reference) prior for the parameters of a normally +#' distributed endpoint. For one endpoint the prior density is +#' \eqn{p(\mu, \sigma^2) \propto \sigma^{-2}}; for two endpoints it is +#' \eqn{p(\mu, \Sigma) \propto |\Sigma|^{-3/2}}. With \eqn{n} observations the +#' posterior distribution of the mean is a t distribution with \eqn{n - 1} +#' degrees of freedom for one endpoint and a bivariate t distribution with +#' \eqn{n - 2} degrees of freedom for two endpoints. +#' +#' @return An object of class \code{c("qdm_prior_vague", "qdm_prior")}. +#' +#' @family priors +#' @examples +#' prior_vague() +#' @export +prior_vague <- function() { + structure(list(), class = c("qdm_prior_vague", "qdm_prior")) +} diff --git a/R/psurv_fixed.R b/R/psurv_fixed.R new file mode 100644 index 0000000..80c65fa --- /dev/null +++ b/R/psurv_fixed.R @@ -0,0 +1,33 @@ +#' Distribution function of a milestone survival probability +#' +#' \eqn{\Pr(S \le x)} (or \eqn{\Pr(S > x)}) for \eqn{S = \exp(-\lambda t_0)} +#' with \eqn{\lambda \sim \textrm{Gamma}(a, b)} (shape and rate). For +#' \eqn{0 < x < 1}, \eqn{S > x} if and only if \eqn{\lambda < -\log(x) / t_0}; +#' \eqn{\Pr(S > x)} is 1 for \eqn{x \le 0} and 0 for \eqn{x \ge 1}. Used for +#' a fixed control with \eqn{x} the threshold plus the fixed value. +#' +#' @param x Numeric vector of values. +#' @param milestone Milestone time \eqn{t_0}. +#' @param shape,rate Numeric vectors of Gamma parameters. +#' @param lower.tail Logical; if \code{TRUE}, \eqn{\Pr(S \le x)}. +#' +#' @return A numeric vector of probabilities. +#' @noRd +psurv_fixed <- function(x, milestone, shape, rate, lower.tail = TRUE) { + args <- recycle_common(list(x = x, shape = shape, rate = rate)) + inside <- args$x > 0 & args$x < 1 + # P(S > x) outside (0, 1) + upper <- ifelse(args$x <= 0, 1, 0) + # P(lambda < -log(x) / t0) = P(S > x); the lower tail is the upper tail of + # the hazard + lam <- -log(args$x[inside]) / milestone + if (lower.tail) { + out <- 1 - upper + out[inside] <- stats::pgamma(lam, args$shape[inside], args$rate[inside], + lower.tail = FALSE) + } else { + out <- upper + out[inside] <- stats::pgamma(lam, args$shape[inside], args$rate[inside]) + } + out +} diff --git a/R/psurvdiff.R b/R/psurvdiff.R new file mode 100644 index 0000000..0e34b07 --- /dev/null +++ b/R/psurvdiff.R @@ -0,0 +1,70 @@ +#' Distribution function of the difference of two milestone survival +#' probabilities +#' +#' Computes \eqn{\Pr(S_t - S_c \le q)} (or the upper tail +#' \eqn{\Pr(S_t - S_c > q)}) for the milestone survival probabilities +#' \eqn{S_k = \exp(-\lambda_k t_0)}, where the hazards have independent +#' Gamma distributions, \eqn{\lambda_t \sim \textrm{Gamma}(a_t, b_t)} and +#' \eqn{\lambda_c \sim \textrm{Gamma}(a_c, b_c)} (shape and rate). This is +#' the posterior probability used for a time-to-event endpoint with a +#' concurrent, external or hypothetical control. +#' +#' The upper tail is computed as +#' \deqn{\Pr(S_t - S_c > q) = \Pr(S_c \le -q) + +#' \int g_c(\lambda) G_t\left(-\log(q + e^{-\lambda t_0}) / t_0\right) +#' \, d\lambda,} +#' where \eqn{g_c} is the density of \eqn{\lambda_c}, \eqn{G_t} is the +#' distribution function of \eqn{\lambda_t}, the integral runs over the +#' values of \eqn{\lambda} with \eqn{0 < q + e^{-\lambda t_0} < 1}, and the +#' first term is zero for \eqn{q \ge 0}. The integral is evaluated by +#' adaptive Gauss-Kronrod quadrature (the QUADPACK routine used by +#' \code{\link[stats]{integrate}}), with the range split at quantiles of the +#' control hazard and at the values that correspond to quantiles of the +#' treatment hazard. When the density of \eqn{\lambda_c} is unbounded at 0 +#' (\eqn{a_c < 1}), the integral below its median is evaluated in the +#' variable \eqn{u = \lambda^{a_c}}, in which the integrand is bounded. The +#' lower tail is computed from the same formula with the roles of the two +#' groups exchanged, so both tails are accurate near 0. +#' +#' @param q Numeric vector of quantiles. +#' @param milestone Positive milestone time \eqn{t_0}. +#' @param shape_t,rate_t Positive shape and rate of the treatment hazard. +#' @param shape_c,rate_c Positive shape and rate of the control hazard. +#' @param lower.tail Logical; if \code{TRUE} (default), probabilities are +#' \eqn{\Pr(S_t - S_c \le q)}, otherwise \eqn{\Pr(S_t - S_c > q)}. +#' +#' @return A numeric vector of probabilities. All arguments except +#' \code{lower.tail} are recycled to a common length; each must have length +#' 1 or the common length. +#' +#' @family distributions +#' @examples +#' # Posterior probability that the 3-month survival is higher by more than +#' # 0.1 with 5 events in 40 months of follow-up versus 9 events in 35 months +#' # (Gamma(0.1, 1) priors) +#' psurvdiff(0.1, milestone = 3, shape_t = 5.1, rate_t = 41, +#' shape_c = 9.1, rate_c = 36, lower.tail = FALSE) +#' @export +psurvdiff <- function(q, milestone, shape_t, rate_t, shape_c, rate_c, + lower.tail = TRUE) { + check_numeric(q, "q", len = NULL) + check_numeric(milestone, "milestone", len = NULL, lower = 0, + lower_open = TRUE) + check_numeric(shape_t, "shape_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(rate_t, "rate_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(shape_c, "shape_c", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(rate_c, "rate_c", len = NULL, lower = 0, lower_open = TRUE) + check_flag(lower.tail, "lower.tail") + args <- recycle_common(list(q = q, milestone = milestone, + shape_t = shape_t, rate_t = rate_t, + shape_c = shape_c, rate_c = rate_c)) + if (lower.tail) { + # P(S_t - S_c <= q) = P(S_c - S_t >= -q), the upper tail with the groups + # exchanged (the distribution is continuous). + cpp_psurvdiff_upper(-args$q, args$milestone, args$shape_c, args$rate_c, + args$shape_t, args$rate_t) + } else { + cpp_psurvdiff_upper(args$q, args$milestone, args$shape_t, args$rate_t, + args$shape_c, args$rate_c) + } +} diff --git a/R/ptdiff.R b/R/ptdiff.R new file mode 100644 index 0000000..00907d8 --- /dev/null +++ b/R/ptdiff.R @@ -0,0 +1,104 @@ +#' Distribution function of the difference of two t variables +#' +#' Computes \eqn{\Pr(T_t - T_c \le q)} (or the upper tail +#' \eqn{\Pr(T_t - T_c > q)}) for independent location-scale t variables +#' \eqn{T_k = \mu_k + s_k X_k}, where \eqn{X_k} follows a t distribution with +#' \eqn{\nu_k} degrees of freedom. This is the posterior (or posterior +#' predictive) probability used for a single continuous endpoint. +#' +#' Three methods are available. +#' \describe{ +#' \item{\code{"NI"}}{Numerical integration over the whole real line by +#' adaptive Gauss-Kronrod quadrature (the QUADPACK routine used by +#' \code{\link[stats]{integrate}}). The integral is taken over the +#' variable of the group with the smaller scale, for example +#' \eqn{\int f_c(u) \Pr(T_t > u + q) \, du} when +#' \eqn{s_c \le s_t}. The range is split around the peak of the density +#' and around the change of the other factor, and the parts far from the +#' origin are integrated on a logarithmic scale, so that heavy tails and +#' very different scales are handled. The absolute error is below +#' \eqn{10^{-9}} in the tests, which include scale ratios from +#' \eqn{10^{-9}} to \eqn{10^3} and degrees of freedom from 0.5 to +#' \code{Inf}.} +#' \item{\code{"MM"}}{The moment-matching approximation of Yamaguchi, +#' Homma, Takeda and Maruo (submitted, Theorem 1), which replaces the +#' difference by a single t +#' distribution with matched second and fourth moments. It requires +#' \eqn{\nu_t > 4} and \eqn{\nu_c > 4}, is evaluated in closed form, and is +#' the fastest method.} +#' \item{\code{"MC"}}{Monte Carlo simulation with \code{nMC} draws for each +#' element, using the random number generator of R.} +#' } +#' Degrees of freedom may be \code{Inf} (normal distributions). For the lower +#' tail, the upper tail of \eqn{T_c - T_t} at \eqn{-q} is computed, so both +#' tails are accurate near 0. +#' +#' @param q Numeric vector of quantiles. +#' @param mu_t,scale_t,df_t Location, positive scale and positive degrees of +#' freedom of the treatment group. +#' @param mu_c,scale_c,df_c Location, positive scale and positive degrees of +#' freedom of the control group. +#' @param method One of \code{"NI"} (default), \code{"MM"} or \code{"MC"}. +#' @param nMC Number of Monte Carlo draws per element for \code{method = "MC"}. +#' @param lower.tail Logical; if \code{TRUE} (default), probabilities are +#' \eqn{\Pr(T_t - T_c \le q)}, otherwise \eqn{\Pr(T_t - T_c > q)}. +#' +#' @return A numeric vector of probabilities. All arguments from \code{q} to +#' \code{df_c} are recycled to a common length; each must have length 1 or +#' the common length. +#' +#' @references +#' Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +#' Moment-matching approximation for t-differences in clinical trials with +#' continuous endpoints. +#' +#' @family distributions +#' @examples +#' ptdiff(1, mu_t = 3, scale_t = 1, df_t = 15, mu_c = 1, scale_c = 1, +#' df_c = 15, lower.tail = FALSE) +#' ptdiff(1, mu_t = 3, scale_t = 1, df_t = 15, mu_c = 1, scale_c = 1, +#' df_c = 15, method = "MM", lower.tail = FALSE) +#' @export +ptdiff <- function(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c, + method = c("NI", "MM", "MC"), nMC = 10000L, + lower.tail = TRUE) { + method <- match.arg(method) + check_numeric(q, "q", len = NULL) + check_numeric(mu_t, "mu_t", len = NULL) + check_numeric(scale_t, "scale_t", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(df_t, "df_t", len = NULL, lower = 0, lower_open = TRUE, + allow_inf = TRUE) + check_numeric(mu_c, "mu_c", len = NULL) + check_numeric(scale_c, "scale_c", len = NULL, lower = 0, lower_open = TRUE) + check_numeric(df_c, "df_c", len = NULL, lower = 0, lower_open = TRUE, + allow_inf = TRUE) + check_flag(lower.tail, "lower.tail") + args <- recycle_common(list(q = q, mu_t = mu_t, scale_t = scale_t, + df_t = df_t, mu_c = mu_c, scale_c = scale_c, + df_c = df_c)) + if (method == "MM" && any(args$df_t <= 4 | args$df_c <= 4)) { + stop("method = \"MM\" requires 'df_t' and 'df_c' greater than 4.", + call. = FALSE) + } + if (method == "MC") { + check_numeric(nMC, "nMC", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + } + if (lower.tail) { + # P(T_t - T_c <= q) = P(T_c - T_t >= -q), the upper tail with the groups + # exchanged (the distribution is continuous). + args <- list(q = -args$q, mu_t = args$mu_c, scale_t = args$scale_c, + df_t = args$df_c, mu_c = args$mu_t, scale_c = args$scale_t, + df_c = args$df_t) + } + switch( + method, + NI = cpp_ptdiff_ni_upper(args$q, args$mu_t, args$scale_t, args$df_t, + args$mu_c, args$scale_c, args$df_c), + MM = ptdiff_mm_upper(args$q, args$mu_t, args$scale_t, args$df_t, + args$mu_c, args$scale_c, args$df_c), + MC = cpp_ptdiff_mc_upper(args$q, args$mu_t, args$scale_t, args$df_t, + args$mu_c, args$scale_c, args$df_c, + as.integer(round(nMC))) + ) +} diff --git a/R/ptdiff_MC.R b/R/ptdiff_MC.R deleted file mode 100644 index 9f48d7d..0000000 --- a/R/ptdiff_MC.R +++ /dev/null @@ -1,148 +0,0 @@ -#' Cumulative Distribution Function of the Difference of Two -#' Independent t-Distributed Variables via Monte Carlo Simulation -#' -#' Calculates the cumulative distribution function (CDF) of the difference -#' between two independent non-standardised t-distributed random variables -#' using Monte Carlo simulation. Specifically, computes -#' \eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -#' \eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -#' -#' @param nMC A positive integer giving the number of Monte Carlo draws. -#' Typical values range from 10,000 (quick estimates) to 100,000 -#' or more (high precision). Larger values reduce Monte Carlo error -#' at the cost of computation time. -#' @param q A numeric scalar representing the quantile threshold. -#' @param mu_t A numeric scalar or vector giving the location parameter of -#' the t-distribution for the treatment group. -#' @param mu_c A numeric scalar or vector giving the location parameter of -#' the t-distribution for the control group. -#' @param sd_t A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the treatment group. -#' @param sd_c A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the control group. -#' @param nu_t A numeric scalar giving the degrees of freedom of the -#' t-distribution for the treatment group. -#' Must be greater than 2 for finite variance. -#' @param nu_c A numeric scalar giving the degrees of freedom of the -#' t-distribution for the control group. -#' Must be greater than 2 for finite variance. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(T_t - T_c \le q)}, otherwise -#' \eqn{P(T_t - T_c > q)}. -#' -#' @return A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -#' \code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -#' \eqn{n}, a vector of length \eqn{n} is returned. -#' -#' @details -#' The algorithm proceeds as follows: -#' \enumerate{ -#' \item Generate an \code{nMC x n} matrix of standard t draws for -#' \eqn{T_t} (\eqn{\nu_t} degrees of freedom), then scale and shift -#' each column by \code{sd_t[i]} and \code{mu_t[i]}. -#' \item Repeat for \eqn{T_c} with \eqn{\nu_c} degrees of freedom. -#' \item Compute the \code{nMC x n} difference matrix -#' \eqn{D = T_t - T_c}. -#' \item Return \code{colMeans(D > q)} as the estimated -#' \eqn{P(T_t - T_c > q)} for each parameter set. -#' } -#' -#' All operations are matrix-based (no R-level loop over parameter sets), so -#' performance scales well with \eqn{n}. However, note that the matrix size -#' is \code{nMC x n}, so memory usage grows linearly with both \code{nMC} -#' and \eqn{n}. When \eqn{n} is large (e.g., \code{nsim x n_scenarios} in -#' \code{\link{pbayesdecisionprob1cont}}), memory requirements can become -#' prohibitive; in such cases prefer \code{CalcMethod = 'MM'}. -#' -#' Monte Carlo error is approximately -#' \eqn{\sqrt{p(1 - p) / \mathrm{nMC}}}; near \eqn{p = 0.5} this is -#' roughly \eqn{0.5 / \sqrt{\mathrm{nMC}}}. -#' -#' @examples -#' # P(T_t - T_c > 3) with equal parameters -#' ptdiff_MC(nMC = 1e5, q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, -#' nu_t = 17, nu_c = 17, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 1) with unequal scales -#' ptdiff_MC(nMC = 1e5, q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, -#' nu_t = 10, nu_c = 15, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 0) with different degrees of freedom -#' ptdiff_MC(nMC = 1e5, q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, -#' nu_t = 5, nu_c = 20, lower.tail = FALSE) -#' -#' # Lower tail: P(T_t - T_c <= 2) -#' ptdiff_MC(nMC = 1e5, q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, -#' nu_t = 12, nu_c = 15, lower.tail = TRUE) -#' -#' # Vectorised usage -#' ptdiff_MC(nMC = 1e5, q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), -#' sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), -#' nu_t = 10, nu_c = 10, lower.tail = FALSE) -#' -#' @importFrom stats rt -#' @export -ptdiff_MC <- function(nMC, q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, - lower.tail = TRUE) { - - # --- Input validation --- - if (!is.numeric(nMC) || length(nMC) != 1L || is.na(nMC) || - nMC != floor(nMC) || nMC < 1L) { - stop("'nMC' must be a single positive integer") - } - - if (!is.numeric(q) || length(q) != 1L || is.na(q)) { - stop("'q' must be a single numeric value") - } - - for (nm in c("mu_t", "mu_c", "sd_t", "sd_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) < 1L || any(is.na(val))) { - stop(paste0("'", nm, "' must be a numeric scalar or vector with no missing values")) - } - } - - if (any(sd_t <= 0)) stop("'sd_t' must contain only positive values") - if (any(sd_c <= 0)) stop("'sd_c' must contain only positive values") - - if (!is.numeric(nu_t) || length(nu_t) != 1L || is.na(nu_t) || nu_t <= 2) { - stop("'nu_t' must be a single numeric value greater than 2") - } - - if (!is.numeric(nu_c) || length(nu_c) != 1L || is.na(nu_c) || nu_c <= 2) { - stop("'nu_c' must be a single numeric value greater than 2") - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # --- Monte Carlo estimation --- - # Number of parameter sets - n <- max(length(mu_t), length(mu_c), length(sd_t), length(sd_c)) - - # Recycle location/scale parameters to length n - mu_t <- rep(mu_t, length.out = n) - mu_c <- rep(mu_c, length.out = n) - sd_t <- rep(sd_t, length.out = n) - sd_c <- rep(sd_c, length.out = n) - - # Generate nMC x n matrices of scaled and shifted t draws. - # rep(..., each = nMC) broadcasts column-wise so that column j uses - # scale sd_t[j] and location mu_t[j]. - rand.t <- matrix(rt(nMC * n, df = nu_t), nrow = nMC, ncol = n) * - rep(sd_t, each = nMC) + rep(mu_t, each = nMC) - - rand.c <- matrix(rt(nMC * n, df = nu_c), nrow = nMC, ncol = n) * - rep(sd_c, each = nMC) + rep(mu_c, each = nMC) - - # Column-wise proportion of differences exceeding q: P(T_t - T_c > q) - results <- colMeans(rand.t - rand.c > q) - - # Convert to lower tail if requested: - # lower.tail = TRUE -> P(T_t - T_c <= q) = 1 - P(T_t - T_c > q) - # lower.tail = FALSE -> P(T_t - T_c > q) - results <- lower.tail + c(1, -1)[lower.tail + 1] * results - - return(results) -} diff --git a/R/ptdiff_MM.R b/R/ptdiff_MM.R deleted file mode 100644 index 7205c00..0000000 --- a/R/ptdiff_MM.R +++ /dev/null @@ -1,132 +0,0 @@ -#' Cumulative Distribution Function of the Difference of Two -#' Independent t-Distributed Variables via Moment-Matching Approximation -#' -#' Calculates the cumulative distribution function (CDF) of the difference -#' between two independent non-standardised t-distributed random variables -#' using a Moment-Matching approximation. Specifically, computes -#' \eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -#' \eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -#' -#' @param q A numeric scalar representing the quantile threshold. -#' @param mu_t A numeric scalar or vector giving the location parameter of -#' the t-distribution for the treatment group. -#' @param mu_c A numeric scalar or vector giving the location parameter of -#' the t-distribution for the control group. -#' @param sd_t A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the treatment group. -#' @param sd_c A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the control group. -#' @param nu_t A numeric scalar giving the degrees of freedom of the -#' t-distribution for the treatment group. -#' Must be greater than 4 for finite fourth moment. -#' @param nu_c A numeric scalar giving the degrees of freedom of the -#' t-distribution for the control group. -#' Must be greater than 4 for finite fourth moment. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(T_t - T_c \le q)}, otherwise -#' \eqn{P(T_t - T_c > q)}. -#' -#' @return A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -#' \code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -#' \eqn{n}, a vector of length \eqn{n} is returned. -#' -#' @details -#' The difference \eqn{D = T_t - T_c} is approximated by a single -#' non-standardised t-distribution -#' \eqn{t(\mu^*, {\sigma^*}^2, \nu^*)} whose parameters are determined by -#' matching the first two even moments of \eqn{D}: -#' \itemize{ -#' \item \eqn{\mu^* = \mu_t - \mu_c}. -#' \item \eqn{{\sigma^*}^2} is obtained from the second-moment equation. -#' \item \eqn{\nu^*} is obtained from the fourth-moment equation. -#' } -#' -#' The approximation requires \eqn{\nu_t > 4} and \eqn{\nu_c > 4} for -#' finite fourth moments. It is exact in the normal limit -#' (\eqn{\nu \to \infty}) and works well in practice when \eqn{\nu > 10}. -#' Because it reduces to a single call to \code{pt()}, it is orders of -#' magnitude faster than the numerical integration method -#' (\code{\link{ptdiff_NI}}) and is fully vectorised. -#' -#' @examples -#' # P(T_t - T_c > 3) with equal parameters -#' ptdiff_MM(q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, -#' nu_t = 17, nu_c = 17, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 1) with unequal scales -#' ptdiff_MM(q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, -#' nu_t = 10, nu_c = 15, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 0) with different degrees of freedom -#' ptdiff_MM(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, -#' nu_t = 5, nu_c = 20, lower.tail = FALSE) -#' -#' # Lower tail: P(T_t - T_c <= 2) -#' ptdiff_MM(q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, -#' nu_t = 12, nu_c = 15, lower.tail = TRUE) -#' -#' # Vectorised usage -#' ptdiff_MM(q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), -#' sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), -#' nu_t = 10, nu_c = 10, lower.tail = FALSE) -#' -#' @importFrom stats pt -#' @export -ptdiff_MM <- function(q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, - lower.tail = TRUE) { - - # --- Input validation --- - if (!is.numeric(q) || length(q) != 1L || is.na(q)) { - stop("'q' must be a single numeric value") - } - - for (nm in c("mu_t", "mu_c", "sd_t", "sd_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) < 1L || any(is.na(val))) { - stop(paste0("'", nm, "' must be a numeric scalar or vector with no missing values")) - } - } - - if (any(sd_t <= 0)) stop("'sd_t' must contain only positive values") - if (any(sd_c <= 0)) stop("'sd_c' must contain only positive values") - - if (!is.numeric(nu_t) || length(nu_t) != 1L || is.na(nu_t) || nu_t <= 4) { - stop("'nu_t' must be a single numeric value greater than 4") - } - - if (!is.numeric(nu_c) || length(nu_c) != 1L || is.na(nu_c) || nu_c <= 4) { - stop("'nu_c' must be a single numeric value greater than 4") - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # --- Moment-Matching approximation --- - # Step 1: Mean of the difference - mu.diff <- mu_t - mu_c - - # Step 2: Effective degrees of freedom (nu.star) from fourth-moment matching - var_t <- sd_t ^ 2 * nu_t / (nu_t - 2) - var_c <- sd_c ^ 2 * nu_c / (nu_c - 2) - Qu_star <- (var_t + var_c) ^ 2 - term1 <- (sd_t ^ 2) ^ 2 * nu_t ^ 2 / ((nu_t - 2) * (nu_t - 4)) - term2 <- (sd_c ^ 2) ^ 2 * nu_c ^ 2 / ((nu_c - 2) * (nu_c - 4)) - term3 <- 2 * var_t * var_c - Qu <- term1 + term2 + term3 - nu.star <- (2 * Qu_star - 4 * Qu) / (Qu_star - Qu) - - # Step 3: Scale parameter (sigma.star) from second-moment matching - sigma.star <- sqrt((var_t + var_c) * (nu.star - 2) / nu.star) - - # Step 4: Standardised statistic and CDF evaluation - standardized <- (q - mu.diff) / sigma.star - results <- pt(standardized, df = nu.star, lower.tail = FALSE) - - # Convert to lower tail if requested: - # lower.tail = TRUE -> P(T_t - T_c <= q) = 1 - P(T_t - T_c > q) - # lower.tail = FALSE -> P(T_t - T_c > q) - results <- lower.tail + c(1, -1)[lower.tail + 1] * results - - return(results) -} diff --git a/R/ptdiff_NI.R b/R/ptdiff_NI.R deleted file mode 100644 index 13b5349..0000000 --- a/R/ptdiff_NI.R +++ /dev/null @@ -1,157 +0,0 @@ -#' Cumulative Distribution Function of the Difference of Two -#' Independent t-Distributed Variables via Numerical Integration -#' -#' Calculates the cumulative distribution function (CDF) of the difference -#' between two independent non-standardised t-distributed random variables -#' using numerical integration. Specifically, computes -#' \eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -#' \eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -#' -#' @param q A numeric scalar representing the quantile threshold. -#' @param mu_t A numeric scalar or vector giving the location parameter of -#' the t-distribution for the treatment group. -#' @param mu_c A numeric scalar or vector giving the location parameter of -#' the t-distribution for the control group. -#' @param sd_t A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the treatment group. -#' @param sd_c A positive numeric scalar or vector giving the scale parameter -#' of the t-distribution for the control group. -#' @param nu_t A numeric scalar giving the degrees of freedom of the -#' t-distribution for the treatment group. -#' Must be greater than 2 for finite variance. -#' @param nu_c A numeric scalar giving the degrees of freedom of the -#' t-distribution for the control group. -#' Must be greater than 2 for finite variance. -#' @param lower.tail A logical scalar; if \code{TRUE} (default), the function -#' returns \eqn{P(T_t - T_c \le q)}, otherwise -#' \eqn{P(T_t - T_c > q)}. -#' -#' @return A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -#' \code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -#' \eqn{n}, a vector of length \eqn{n} is returned. -#' -#' @details -#' The upper-tail probability is obtained via the convolution formula: -#' \deqn{P(T_t - T_c > q) -#' = \int_{-\infty}^{\infty} -#' F_{t(\mu_c, \sigma_c^2, \nu_c)}(x - q)\, -#' f_{t(\mu_t, \sigma_t^2, \nu_t)}(x)\, dx} -#' where \eqn{f_{t(\mu_t, \sigma_t^2, \nu_t)}} is the density of \eqn{T_t} -#' and \eqn{F_{t(\mu_c, \sigma_c^2, \nu_c)}} is the CDF of \eqn{T_c}. -#' The integral is evaluated by adaptive Gauss-Kronrod quadrature via -#' \code{stats::integrate}. -#' -#' When the input parameters are vectors, \code{mapply} applies the scalar -#' integration function across all parameter sets. -#' -#' Advantages: -#' \itemize{ -#' \item Exact within numerical precision. -#' \item Handles arbitrary parameter combinations. -#' } -#' Computational note: this method is substantially slower than the -#' Moment-Matching approximation (\code{\link{ptdiff_MM}}) because it calls -#' \code{integrate()} once per parameter set. For large-scale simulation -#' (many parameter sets), prefer \code{CalcMethod = 'MM'} in -#' \code{\link{pbayesdecisionprob1cont}}. -#' -#' @examples -#' # P(T_t - T_c > 3) with equal parameters -#' ptdiff_NI(q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, -#' nu_t = 17, nu_c = 17, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 1) with unequal scales -#' ptdiff_NI(q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, -#' nu_t = 10, nu_c = 15, lower.tail = FALSE) -#' -#' # P(T_t - T_c > 0) with different degrees of freedom -#' ptdiff_NI(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, -#' nu_t = 5, nu_c = 20, lower.tail = FALSE) -#' -#' # Lower tail: P(T_t - T_c <= 2) -#' ptdiff_NI(q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, -#' nu_t = 12, nu_c = 15, lower.tail = TRUE) -#' -#' # Vectorised usage -#' ptdiff_NI(q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), -#' sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), -#' nu_t = 10, nu_c = 10, lower.tail = FALSE) -#' -#' @importFrom stats dt integrate pt -#' @export -ptdiff_NI <- function(q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, - lower.tail = TRUE) { - - # --- Input validation --- - if (!is.numeric(q) || length(q) != 1L || is.na(q)) { - stop("'q' must be a single numeric value") - } - - for (nm in c("mu_t", "mu_c", "sd_t", "sd_c")) { - val <- get(nm) - if (!is.numeric(val) || length(val) < 1L || any(is.na(val))) { - stop(paste0("'", nm, "' must be a numeric scalar or vector with no missing values")) - } - } - - if (any(sd_t <= 0)) stop("'sd_t' must contain only positive values") - if (any(sd_c <= 0)) stop("'sd_c' must contain only positive values") - - if (!is.numeric(nu_t) || length(nu_t) != 1L || is.na(nu_t) || nu_t <= 2) { - stop("'nu_t' must be a single numeric value greater than 2") - } - - if (!is.numeric(nu_c) || length(nu_c) != 1L || is.na(nu_c) || nu_c <= 2) { - stop("'nu_c' must be a single numeric value greater than 2") - } - - if (!is.logical(lower.tail) || length(lower.tail) != 1L || is.na(lower.tail)) { - stop("'lower.tail' must be a single logical value (TRUE or FALSE)") - } - - # --- Core scalar integration function --- - # Computes P(T_t - T_c > q) for a single parameter set via convolution. - integrand_upper <- function(x, q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c) { - # f_t(x) * F_c(x - q): density of T_t times CDF of T_c evaluated at (x - q) - dt((x - mu_t) / sd_t, df = nu_t) / sd_t * - pt((x - q - mu_c) / sd_c, df = nu_c) - } - - # Integration bounds: mu_t +/- 8 * sd*(T_t), where sd*(T_t) = sd_t * sqrt((nu_t+1)/(nu_t-2)) - scalar_upper <- function(q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c) { - spread <- sd_t * sqrt((nu_t + 1) / (nu_t - 2)) - lo <- mu_t - 8 * spread - hi <- mu_t + 8 * spread - integrate( - integrand_upper, - lower = lo, - upper = hi, - q = q, - mu_t = mu_t, - mu_c = mu_c, - sd_t = sd_t, - sd_c = sd_c, - nu_t = nu_t, - nu_c = nu_c, - rel.tol = 1e-6, - abs.tol = 1e-8 - )$value - } - - # --- Vectorised computation --- - # Use mapply to apply the scalar function across all parameter combinations - p_upper <- mapply( - scalar_upper, - q = q, - mu_t = mu_t, - mu_c = mu_c, - sd_t = sd_t, - sd_c = sd_c, - MoreArgs = list(nu_t = nu_t, nu_c = nu_c) - ) - - # Clamp to [0, 1] to guard against minor numerical overshoot - p_upper <- pmin(pmax(p_upper, 0), 1) - - if (lower.tail) 1 - p_upper else p_upper -} diff --git a/R/ptdiff_mm_upper.R b/R/ptdiff_mm_upper.R new file mode 100644 index 0000000..a013140 --- /dev/null +++ b/R/ptdiff_mm_upper.R @@ -0,0 +1,31 @@ +#' Upper tail of the difference of two t variables by moment matching +#' +#' Approximates \eqn{\Pr(T_t - T_c > q)} by a single scaled t distribution +#' whose second and fourth moments match those of the difference (Yamaguchi et +#' al., submitted, Theorem 1). The matched degrees of freedom are +#' \deqn{\nu^* = 4 + \frac{(v_t + v_c)^2}{v_t^2 / (\nu_t - 4) + +#' v_c^2 / (\nu_c - 4)},} +#' where \eqn{v_k = s_k^2 \nu_k / (\nu_k - 2)} is the variance of group +#' \eqn{k}, and the matched squared scale is +#' \eqn{(v_t + v_c)(\nu^* - 2) / \nu^*}. Infinite degrees of freedom (normal +#' distributions) are allowed. +#' +#' @param q,mu_t,scale_t,df_t,mu_c,scale_c,df_c Numeric vectors of a common +#' length; all degrees of freedom must be greater than 4. +#' +#' @return A numeric vector of upper tail probabilities. +#' @noRd +ptdiff_mm_upper <- function(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c) { + var_t <- ifelse(is.finite(df_t), scale_t ^ 2 * df_t / (df_t - 2), + scale_t ^ 2) + var_c <- ifelse(is.finite(df_c), scale_c ^ 2 * df_c / (df_c - 2), + scale_c ^ 2) + kurt_t <- ifelse(is.finite(df_t), var_t ^ 2 / (df_t - 4), 0) + kurt_c <- ifelse(is.finite(df_c), var_c ^ 2 / (df_c - 4), 0) + kurt <- kurt_t + kurt_c + nu_star <- ifelse(kurt > 0, 4 + (var_t + var_c) ^ 2 / kurt, Inf) + scale_star <- sqrt((var_t + var_c) * + ifelse(is.finite(nu_star), (nu_star - 2) / nu_star, 1)) + stats::pt((q - (mu_t - mu_c)) / scale_star, df = nu_star, + lower.tail = FALSE) +} diff --git a/R/qdm_boundary.R b/R/qdm_boundary.R new file mode 100644 index 0000000..525fd82 --- /dev/null +++ b/R/qdm_boundary.R @@ -0,0 +1,164 @@ +#' Decision boundary of a design +#' +#' Computes the decision of a design (Go, NoGo, Gray or Miss) for every point +#' of a grid of possible observed data of the treatment group, so that the +#' regions of the data that lead to each decision can be plotted +#' (\code{\link{plot.qdm_boundary}}). Unlike the operating characteristics, +#' the result does not depend on the true parameters: it shows which data +#' lead to which decision. +#' +#' The grid depends on the endpoint of the design: +#' \describe{ +#' \item{One binary endpoint}{With a concurrent control group, all numbers +#' of responders \eqn{y_t = 0, \ldots, n_t} and \eqn{y_c = 0, \ldots, n_c} +#' (\code{n_t} must be a single number; \eqn{n_c} is that of the design). +#' Without one, all \eqn{(n, y_t)} with \eqn{n} in \code{n_t} and +#' \eqn{y_t = 0, \ldots, n}, which shows how the boundary changes with the +#' sample size.} +#' \item{One continuous endpoint}{All combinations of \code{mean_t}, +#' \code{sd_t} and \code{n_t}, of which at most one of \code{sd_t} and +#' \code{n_t} may have more than one value (the horizontal axis). With a +#' concurrent control group, \code{data_c} gives the observed control +#' data and the vertical axis is the observed difference of the means.} +#' \item{Two continuous endpoints}{All combinations of the observed +#' treatment means of the two endpoints, \code{mean_t[[1]]} and +#' \code{mean_t[[2]]}, with the sample covariance matrix \code{cov_t} and +#' \code{n_t} subjects (a single number). With a concurrent control +#' group, \code{data_c} gives the observed control data and the axes are +#' the observed differences of the means.} +#' \item{One time-to-event endpoint}{All combinations of the numbers of +#' events \code{events_t} and the total observed times +#' \code{exposure_t} of the treatment group. With a concurrent control +#' group, \code{data_c} gives the observed control data.} +#' } +#' Two binary endpoints are not supported, because their decision depends on +#' the four cell counts and cannot be shown on two axes. +#' +#' The decision at each point is made as in \code{\link{qdm_decide}}. +#' Probabilities computed by Monte Carlo simulation (\code{method = "MC"}, +#' or posterior predictive probabilities of a time-to-event endpoint) make +#' the boundary irregular; deterministic methods give smooth boundaries. +#' +#' @param design A design created by \code{\link{design_binary}}, +#' \code{\link{design_continuous}}, \code{\link{design_continuous2}} or +#' \code{\link{design_tte}}. +#' @param n_t Numbers of subjects in the treatment group (whole numbers); by +#' default that of the design. Several values are allowed for one binary +#' endpoint without a concurrent control group and for one continuous +#' endpoint. For a time-to-event endpoint, \code{n_t} only sets the default +#' numbers of events. +#' @param mean_t Observed treatment means: a numeric vector for one +#' continuous endpoint, or a list of two numeric vectors (endpoints 1 and +#' 2) for two continuous endpoints. +#' @param sd_t Observed treatment standard deviations (one continuous +#' endpoint; positive). +#' @param cov_t Observed treatment covariance matrix (two continuous +#' endpoints; a 2 x 2 positive definite matrix). +#' @param events_t Numbers of events of the treatment group (time-to-event +#' endpoint; whole numbers); by default \code{0:n_t}. +#' @param exposure_t Total observed times of the treatment group +#' (time-to-event endpoint; positive). +#' @param data_c Observed data of the concurrent control group, created by +#' \code{\link{data_continuous}}, \code{\link{data_continuous2}} or +#' \code{\link{data_tte}}; required for those endpoints with a concurrent +#' control group and \code{NULL} otherwise. +#' @param seed Random seed for probabilities computed by Monte Carlo +#' simulation, or \code{NULL} to use the current random number stream. If +#' given, the previous state of the random number generator is restored on +#' exit. +#' +#' @return An object of class \code{c("qdm_boundary", "data.frame")}: the +#' grid (columns named as the arguments, and \code{y_t} and \code{y_c} for +#' binary data or \code{diff}, \code{diff1} and \code{diff2} for +#' differences of means), the columns \code{prob_go} and \code{prob_nogo} +#' (for two endpoints with a marginal rule, \code{prob_go1}, +#' \code{prob_go2}, \code{prob_nogo1} and \code{prob_nogo2}) and the +#' factor \code{decision}. The attributes \code{design} and \code{axes} +#' record the design and the columns and labels of the axes of the plot. +#' +#' @family operations +#' @examples +#' # Single-arm study with a fixed control response rate of 0.2 +#' des <- design_binary( +#' n_t = 20, n_c = 0, prior_t = prior_beta(1, 1), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.05, +#' gamma_go = 0.8, gamma_nogo = 0.8), +#' fixed_c = 0.2 +#' ) +#' b <- qdm_boundary(des, n_t = 10:30) +#' plot(b) +#' +#' # Continuous endpoint with a concurrent control group +#' des2 <- design_continuous( +#' n_t = 12, n_c = 12, +#' prior_t = prior_vague(), prior_c = prior_vague(), +#' criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, +#' gamma_go = 0.6, gamma_nogo = 0.7), +#' method = "MM" +#' ) +#' b2 <- qdm_boundary(des2, mean_t = seq(-20, 60, by = 2), +#' sd_t = seq(10, 40, by = 2), +#' data_c = data_continuous(12, 0, 25)) +#' plot(b2) +#' @export +qdm_boundary <- function(design, n_t = NULL, mean_t = NULL, sd_t = NULL, + cov_t = NULL, events_t = NULL, exposure_t = NULL, + data_c = NULL, seed = NULL) { + check_design(design) + if (design$endpoint == "binary2") { + stop(paste("qdm_boundary() does not support two binary endpoints,", + "whose decision depends on the four cell counts."), + call. = FALSE) + } + if (is.null(n_t)) { + n_t <- design$n_t + } + used <- switch(design$endpoint, + binary = "n_t", + continuous = c("n_t", "mean_t", "sd_t", "data_c"), + continuous2 = c("n_t", "mean_t", "cov_t", "data_c"), + tte = c("n_t", "events_t", "exposure_t", "data_c")) + given <- c(mean_t = !is.null(mean_t), sd_t = !is.null(sd_t), + cov_t = !is.null(cov_t), events_t = !is.null(events_t), + exposure_t = !is.null(exposure_t), data_c = !is.null(data_c)) + unused <- setdiff(names(given)[given], used) + if (length(unused) > 0L) { + stop(sprintf("%s %s not used for this endpoint.", + paste0("'", unused, "'", collapse = ", "), + if (length(unused) > 1L) "are" else "is"), call. = FALSE) + } + concurrent <- design$control == "concurrent" + if ("data_c" %in% used && concurrent && is.null(data_c)) { + stop("'data_c' must be given for a design with a concurrent control group.", + call. = FALSE) + } + if (!concurrent && !is.null(data_c)) { + stop(paste("'data_c' must be NULL for a design without a concurrent", + "control group."), call. = FALSE) + } + res <- with_seed(seed, switch( + design$endpoint, + binary = boundary_binary(design, n_t), + continuous = boundary_continuous(design, n_t, mean_t, sd_t, data_c), + continuous2 = boundary_continuous2(design, n_t, mean_t, cov_t, data_c), + tte = boundary_tte(design, n_t, events_t, exposure_t, data_c) + )) + crit <- design$criterion + met_go <- meets_criterion(res$p_go, crit$gamma_go, crit$rule) + met_nogo <- meets_criterion(res$p_nogo, crit$gamma_nogo, crit$rule) + out <- res$grid + if (is.list(res$p_go)) { + out$prob_go1 <- res$p_go[[1L]] + out$prob_go2 <- res$p_go[[2L]] + out$prob_nogo1 <- res$p_nogo[[1L]] + out$prob_nogo2 <- res$p_nogo[[2L]] + } else { + out$prob_go <- res$p_go + out$prob_nogo <- res$p_nogo + } + out$decision <- factor(decision_label(met_go, met_nogo), + levels = c("Go", "NoGo", "Gray", "Miss")) + rownames(out) <- NULL + structure(out, class = c("qdm_boundary", "data.frame"), design = design, + axes = res$axes) +} diff --git a/R/qdm_calibrate.R b/R/qdm_calibrate.R new file mode 100644 index 0000000..46aad04 --- /dev/null +++ b/R/qdm_calibrate.R @@ -0,0 +1,147 @@ +#' Calibration of the decision thresholds +#' +#' Chooses the thresholds \eqn{\gamma_{go}} and \eqn{\gamma_{nogo}} of the +#' criterion of a design so that the probabilities of a false Go decision and +#' a false NoGo decision are controlled. +#' +#' The threshold \eqn{\gamma_{go}} is the smallest value in \code{grid} for +#' which the probability that the Go criterion is met under +#' \code{scenario_go} (typically a scenario with no or a small treatment +#' effect) is at most \code{target_go}. The threshold \eqn{\gamma_{nogo}} is +#' the smallest value in \code{grid} for which the probability that the NoGo +#' criterion is met under \code{scenario_nogo} (typically a scenario with the +#' expected treatment effect) is at most \code{target_nogo}. Both +#' probabilities decrease as the threshold increases, so the chosen thresholds +#' are the least strict ones that meet the targets. +#' +#' The decision probabilities of the design with the chosen thresholds are +#' computed under both scenarios. If \eqn{\gamma_{go} + \gamma_{nogo} \le 1} +#' (and, for two endpoints with the marginal rule \code{"or"}, for any +#' thresholds), Miss decisions (both criteria met) can occur, and a warning is +#' given when they have positive probability. +#' +#' @param design A design created by \code{\link{design_binary}}, +#' \code{\link{design_continuous}}, \code{\link{design_binary2}}, +#' \code{\link{design_continuous2}} or \code{\link{design_tte}}. Its +#' thresholds are replaced by the calibrated ones. For two endpoints with a +#' marginal rule (\code{rule = "and"} or \code{"or"}), the same threshold is +#' used for both endpoints. +#' @param scenario_go,scenario_nogo Data frames with one row each, giving the +#' scenarios used to calibrate \eqn{\gamma_{go}} and \eqn{\gamma_{nogo}} +#' (see \code{\link{qdm_oc}} for the columns). For two binary endpoints, the +#' correlations must be feasible. +#' @param target_go,target_nogo Upper bounds for the probabilities that the +#' Go criterion is met under \code{scenario_go} and that the NoGo criterion +#' is met under \code{scenario_nogo}, strictly between 0 and 1. +#' @param grid Candidate thresholds, strictly between 0 and 1. +#' @param nsim,seed As in \code{\link{qdm_oc}}. The probabilities for all +#' values of \code{grid} are computed from the same outcomes (simulated +#' studies or enumerated outcomes) and the same Monte Carlo draws. +#' +#' @return An object of class \code{"qdm_calibration"}: a list with elements +#' \describe{ +#' \item{gamma_go, gamma_nogo}{The chosen thresholds (\code{NA} if no +#' value in \code{grid} meets the target).} +#' \item{prob_go, prob_nogo}{The probabilities that the Go criterion is +#' met under \code{scenario_go} and that the NoGo criterion is met under +#' \code{scenario_nogo}, at the chosen thresholds.} +#' \item{target_go, target_nogo}{The targets.} +#' \item{curve}{A data frame with the columns \code{gamma} (the grid), +#' \code{prob_go} and \code{prob_nogo} (the two probabilities at each +#' threshold).} +#' \item{oc}{A data frame of the decision probabilities with the chosen +#' thresholds under the two scenarios (\code{NULL} if a threshold was +#' not found).} +#' \item{design}{The design with the chosen thresholds (\code{NULL} if a +#' threshold was not found).} +#' \item{scenario_go, scenario_nogo, method}{The scenarios and the method +#' of computation.} +#' } +#' +#' @family operations +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' cal <- qdm_calibrate(des, +#' scenario_go = data.frame(pi_t = 0.4, pi_c = 0.4), +#' scenario_nogo = data.frame(pi_t = 0.7, pi_c = 0.4), +#' target_go = 0.05, target_nogo = 0.2) +#' cal +#' plot(cal) +#' cal$design +#' @export +qdm_calibrate <- function(design, scenario_go, scenario_nogo, target_go, + target_nogo, grid = seq(0.01, 0.99, by = 0.01), + nsim = 10000L, seed = NULL) { + check_design(design) + scenario_go <- check_scenarios(design, scenario_go, "scenario_go", + one_row = TRUE, feasible = TRUE) + scenario_nogo <- check_scenarios(design, scenario_nogo, "scenario_nogo", + one_row = TRUE, feasible = TRUE) + check_numeric(target_go, "target_go", lower = 0, upper = 1, + lower_open = TRUE, upper_open = TRUE) + check_numeric(target_nogo, "target_nogo", lower = 0, upper = 1, + lower_open = TRUE, upper_open = TRUE) + check_numeric(grid, "grid", len = NULL, lower = 0, upper = 1, + lower_open = TRUE, upper_open = TRUE) + grid <- sort(unique(grid)) + check_numeric(nsim, "nsim", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + if (!is.null(seed)) { + check_numeric(seed, "seed", lower = -.Machine$integer.max, + upper = .Machine$integer.max, integer = TRUE) + } + cols <- scenario_columns(design)$names + scenarios <- rbind(scenario_go[, cols, drop = FALSE], + scenario_nogo[, cols, drop = FALSE]) + sample <- with_seed(seed, oc_sample(design, scenarios, nsim)) + rule <- design$criterion$rule + curve <- data.frame( + gamma = grid, + prob_go = met_curve(sample_column(sample$p_go, 1L, sample$per_scenario), + sample_weights(sample, 1L), grid, rule), + prob_nogo = met_curve(sample_column(sample$p_nogo, 2L, + sample$per_scenario), + sample_weights(sample, 2L), grid, rule) + ) + gamma_go <- select_gamma(grid, curve$prob_go, target_go) + gamma_nogo <- select_gamma(grid, curve$prob_nogo, target_nogo) + if (is.na(gamma_go)) { + warning(sprintf(paste("No value in 'grid' gives a probability of meeting", + "the Go criterion of at most %s under", + "'scenario_go'."), format(target_go)), + call. = FALSE) + } + if (is.na(gamma_nogo)) { + warning(sprintf(paste("No value in 'grid' gives a probability of meeting", + "the NoGo criterion of at most %s under", + "'scenario_nogo'."), format(target_nogo)), + call. = FALSE) + } + oc <- NULL + new_design <- NULL + if (!is.na(gamma_go) && !is.na(gamma_nogo)) { + new_design <- design + k <- length(design$criterion$gamma_go) + new_design$criterion$gamma_go <- rep(gamma_go, k) + new_design$criterion$gamma_nogo <- rep(gamma_nogo, k) + probs <- oc_from_sample(sample, new_design$criterion$gamma_go, + new_design$criterion$gamma_nogo, rule) + oc <- cbind(data.frame(scenario = c("scenario_go", "scenario_nogo")), + scenarios, as.data.frame(probs)) + rownames(oc) <- NULL + warn_miss(oc$Miss, rule) + } + structure(list(gamma_go = gamma_go, gamma_nogo = gamma_nogo, + prob_go = curve$prob_go[match(gamma_go, grid)], + prob_nogo = curve$prob_nogo[match(gamma_nogo, grid)], + target_go = target_go, target_nogo = target_nogo, + curve = curve, oc = oc, design = new_design, + scenario_go = scenario_go, scenario_nogo = scenario_nogo, + method = sample$method), + class = "qdm_calibration") +} diff --git a/R/qdm_decide.R b/R/qdm_decide.R new file mode 100644 index 0000000..d4b3a77 --- /dev/null +++ b/R/qdm_decide.R @@ -0,0 +1,110 @@ +#' Go/NoGo decision for observed data +#' +#' Computes the probabilities of the Go and NoGo regions given the observed +#' proof-of-concept data, and makes the decision of a design. +#' +#' The decision is Go if only the Go criterion is met, NoGo if only the NoGo +#' criterion is met, Gray if neither is met, and Miss if both are met (see +#' \code{\link{criterion_posterior}} and \code{\link{criterion_predictive}}). +#' A probability that is below a threshold by less than \eqn{10^{-10}} is +#' treated as equal to the threshold, so that ties that arise in symmetric +#' settings are not decided by rounding errors. +#' +#' The sample sizes of the observed data may differ from those of the design, +#' which are used only by \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +#' +#' @param design A design created by \code{\link{design_binary}}, +#' \code{\link{design_continuous}}, \code{\link{design_binary2}}, +#' \code{\link{design_continuous2}} or \code{\link{design_tte}}. +#' @param data_t Observed data of the treatment group, created by +#' \code{\link{data_binary}}, \code{\link{data_continuous}}, +#' \code{\link{data_binary2}}, \code{\link{data_continuous2}} or +#' \code{\link{data_tte}} (matching the endpoint of the design). +#' @param data_c Observed data of the concurrent control group, created by +#' the same function as \code{data_t}; \code{NULL} (the default) for a +#' design without a concurrent control group. +#' @param seed Random seed for probabilities computed by Monte Carlo +#' simulation (a continuous design with \code{method = "MC"}, posterior +#' probabilities for two binary endpoints, or posterior predictive +#' probabilities for a time-to-event endpoint), or \code{NULL} to use the +#' current random number stream. If given, the previous state of the random +#' number generator is restored on exit. Not used otherwise. +#' +#' @return An object of class \code{"qdm_decision"}: a list with elements +#' \describe{ +#' \item{decision}{\code{"Go"}, \code{"NoGo"}, \code{"Gray"} or +#' \code{"Miss"}.} +#' \item{prob_go, prob_nogo}{Probabilities of the Go and NoGo regions +#' (for two endpoints with a marginal rule, one probability per +#' endpoint).} +#' \item{prob_regions}{For two endpoints, the probabilities of all +#' regions (see \code{\link{qdm_regions}}); \code{NULL} otherwise.} +#' \item{met_go, met_nogo}{Whether the Go and NoGo criteria are met.} +#' \item{posterior_t, posterior_c}{Parameters of the posterior +#' distributions of the treatment and control groups: for a binary +#' endpoint, the Beta parameters \code{a} and \code{b}; for a +#' continuous endpoint, the Normal-Inverse-chi-squared parameters +#' \code{mu}, \code{kappa}, \code{nu} and \code{sigma} (on the standard +#' deviation scale), so that the mean has the distribution +#' \eqn{t_{\nu}(\mu, \sigma^2 / \kappa)}. For a hypothetical control, +#' \code{posterior_c} gives the distribution of the control mean in the +#' same form (see \code{\link{design_continuous}}). For two binary +#' endpoints, the Dirichlet parameters of the cells \code{"00"}, +#' \code{"01"}, \code{"10"} and \code{"11"}. For two continuous +#' endpoints, the Normal-Inverse-Wishart parameters \code{mu1}, +#' \code{mu2}, \code{kappa}, \code{nu} and the elements \code{L11}, +#' \code{L12} and \code{L22} of \eqn{\Lambda}, so that the mean has the +#' distribution \eqn{t_{\nu - 1}(\mu, \Lambda / (\kappa (\nu - 1)))}. +#' For a time-to-event endpoint, the shape and rate of the Gamma +#' distribution of the hazard. For a fixed control, \code{posterior_c} +#' is the fixed value (named \code{value}, or \code{value1} and +#' \code{value2} for two endpoints).} +#' \item{design, data_t, data_c}{The arguments.} +#' } +#' +#' @family operations +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' qdm_decide(des, data_t = data_binary(12, 9), data_c = data_binary(12, 4)) +#' +#' # Continuous endpoint +#' des2 <- design_continuous( +#' n_t = 12, n_c = 12, +#' prior_t = prior_vague(), prior_c = prior_vague(), +#' criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, +#' gamma_go = 0.6, gamma_nogo = 0.7) +#' ) +#' qdm_decide(des2, data_t = data_continuous(12, 18, 25), +#' data_c = data_continuous(12, -12, 25)) +#' @export +qdm_decide <- function(design, data_t, data_c = NULL, seed = NULL) { + check_design(design) + if (!is.null(seed)) { + check_numeric(seed, "seed", lower = -.Machine$integer.max, + upper = .Machine$integer.max, integer = TRUE) + } + res <- with_seed(seed, switch( + design$endpoint, + binary = decide_binary(design, data_t, data_c), + continuous = decide_continuous(design, data_t, data_c), + binary2 = decide_binary2(design, data_t, data_c), + continuous2 = decide_continuous2(design, data_t, data_c), + tte = decide_tte(design, data_t, data_c) + )) + crit <- design$criterion + met_go <- meets_criterion(res$prob_go, crit$gamma_go, crit$rule) + met_nogo <- meets_criterion(res$prob_nogo, crit$gamma_nogo, crit$rule) + structure(list(decision = decision_label(met_go, met_nogo), + prob_go = res$prob_go, prob_nogo = res$prob_nogo, + met_go = met_go, met_nogo = met_nogo, + prob_regions = res$prob_regions, + posterior_t = res$posterior_t, + posterior_c = res$posterior_c, design = design, + data_t = data_t, data_c = data_c), + class = "qdm_decision") +} diff --git a/R/qdm_oc.R b/R/qdm_oc.R new file mode 100644 index 0000000..69d5c46 --- /dev/null +++ b/R/qdm_oc.R @@ -0,0 +1,159 @@ +#' Operating characteristics of a design +#' +#' Computes the probabilities of Go, NoGo, Gray and Miss decisions of a design +#' under scenarios for the true parameters. +#' +#' For a binary endpoint, all possible outcomes of the proof-of-concept study +#' are enumerated and the probabilities are exact (Kang et al., 2026, Section +#' 4.3); \code{nsim} and \code{seed} are not used. +#' +#' For a continuous endpoint, \code{nsim} studies are simulated under each +#' scenario. Only the sufficient statistics are simulated: the sample mean +#' \eqn{\bar y = \mu + \sigma Z / \sqrt{n}} and the sample standard deviation +#' \eqn{s = \sigma \sqrt{X / (n - 1)}}, with \eqn{Z \sim N(0, 1)} and +#' \eqn{X \sim \chi^2_{n - 1}}. The same random numbers are used for all +#' scenarios, so the results change smoothly across scenarios. The +#' probabilities have a simulation standard error of at most +#' \eqn{0.5 / \sqrt{nsim}} (0.005 for the default \code{nsim}). For each +#' simulated study, the probabilities of the Go and NoGo regions are computed +#' by the method of the design (see \code{\link{design_continuous}}), of which +#' \code{method = "MM"} is the fastest. To explore many scenarios or designs, +#' \code{method = "MM"} or a smaller \code{nsim} gives results quickly; the +#' chosen design can then be checked with \code{method = "NI"} and the +#' default \code{nsim}. +#' +#' For two binary endpoints, all outcomes are enumerated (Yamaguchi et al., +#' submitted, equation A.5) or \code{nsim} studies are simulated, as specified +#' by \code{enumerate} in \code{\link{design_binary2}}. The response rates +#' and correlation of each group are converted to cell probabilities by +#' \code{\link{cellprob_binary2}}; a scenario whose correlation is outside the +#' feasible range for its response rates is not evaluable, and its +#' probabilities are \code{NA} (with a warning). +#' +#' For two continuous endpoints, \code{nsim} studies are simulated under each +#' scenario. Only the sufficient statistics are simulated: the sample means +#' \eqn{\bar y = \mu + L z / \sqrt{n}} and the matrix of sums of squares and +#' cross-products \eqn{S = L A A^T L^T}, where \eqn{L} is the Cholesky +#' factor of the covariance matrix of the scenario, \eqn{z} has two +#' independent standard normal elements and \eqn{A} is the Bartlett factor +#' of a Wishart distribution with \eqn{n - 1} degrees of freedom. The same +#' random numbers are used for all scenarios. +#' +#' For a time-to-event endpoint, \code{nsim} studies are simulated under each +#' scenario as specified by the conduct of the design (enrollment, dropout +#' and analysis time; see \code{\link{conduct_tte}}), with exponential event +#' times whose hazard is \eqn{\log(2) / M} for the median survival time +#' \eqn{M} of the scenario. The same random numbers are used for all +#' scenarios. With a predictive criterion, every simulated study needs +#' \code{nMC} simulated future studies (see \code{\link{design_tte}}), so +#' the computing time grows with \code{nsim} times \code{nMC}. +#' +#' The decision for each outcome is made as in \code{\link{qdm_decide}}. A +#' warning is given when Miss decisions (both criteria met) have positive +#' probability in some scenario. +#' +#' @param design A design created by \code{\link{design_binary}}, +#' \code{\link{design_continuous}}, \code{\link{design_binary2}}, +#' \code{\link{design_continuous2}} or \code{\link{design_tte}}. +#' @param scenarios A data frame with one row per scenario. For a binary +#' endpoint the columns \code{pi_t} and \code{pi_c} give the true response +#' rates of the treatment and control groups. For a continuous endpoint the +#' columns \code{mu_t}, \code{sd_t}, \code{mu_c} and \code{sd_c} give the +#' true means and standard deviations. For two binary endpoints the columns +#' \code{pi_t1}, \code{pi_t2}, \code{rho_t}, \code{pi_c1}, \code{pi_c2} and +#' \code{rho_c} give the true response rates of endpoints 1 and 2 (strictly +#' between 0 and 1) and the correlation of the two endpoints in each group. +#' For two continuous endpoints the columns \code{mu_t1}, \code{mu_t2}, +#' \code{sd_t1}, \code{sd_t2}, \code{rho_t}, \code{mu_c1}, \code{mu_c2}, +#' \code{sd_c1}, \code{sd_c2} and \code{rho_c} give the true means, +#' standard deviations and correlation of the two endpoints in each group +#' (the correlation strictly between -1 and 1). +#' For a time-to-event endpoint the columns \code{median_t} and +#' \code{median_c} give the true median survival times (positive). +#' The columns of the control group are not needed for a design without a +#' concurrent control group. Other columns, such as labels, are kept in the +#' result. +#' @param nsim Number of simulated studies per scenario for designs whose +#' operating characteristics are computed by simulation. +#' @param seed Random seed for the simulation and for Monte Carlo estimates +#' of probabilities, or \code{NULL} to use the current random number +#' stream. If given, the previous state of the random number generator is +#' restored on exit. +#' +#' @return An object of class \code{c("qdm_oc", "data.frame")}: the scenarios +#' with the columns \code{Go}, \code{NoGo}, \code{Gray} and \code{Miss} +#' added. The attributes \code{design} and \code{method} record the design +#' and the method of computation. +#' +#' @references +#' Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +#' decision-making framework in cell and gene therapy development for rare +#' diseases. \emph{Journal of Biopharmaceutical Statistics}. +#' \doi{10.1080/10543406.2026.2655410} +#' +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' @family operations +#' @examples +#' des <- design_binary( +#' n_t = 12, n_c = 12, +#' prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), +#' criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, +#' gamma_go = 0.5, gamma_nogo = 0.8) +#' ) +#' oc <- qdm_oc(des, data.frame(pi_t = seq(0.2, 0.8, by = 0.1), pi_c = 0.4)) +#' oc +#' plot(oc) +#' +#' # Continuous endpoint (moment-matching approximation for speed) +#' des2 <- design_continuous( +#' n_t = 12, n_c = 12, +#' prior_t = prior_vague(), prior_c = prior_vague(), +#' criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, +#' gamma_go = 0.6, gamma_nogo = 0.7), +#' method = "MM" +#' ) +#' oc2 <- qdm_oc(des2, data.frame(mu_t = seq(0, 50, by = 10), sd_t = 25, +#' mu_c = 0, sd_c = 25), +#' nsim = 2000, seed = 1) +#' oc2 +#' +#' # Two binary endpoints (small nMC for speed) +#' des3 <- design_binary2( +#' n_t = 6, n_c = 6, +#' prior_t = prior_dirichlet(rep(0.25, 4)), +#' prior_c = prior_dirichlet(rep(0.25, 4)), +#' criterion = criterion_posterior(theta_tv = c(0.15, 0.15), +#' theta_mav = c(0.10, 0.10), +#' gamma_go = 0.3, gamma_nogo = 0.4), +#' nMC = 2000 +#' ) +#' effects <- expand.grid(theta1 = c(0, 0.15, 0.3), theta2 = c(0, 0.15, 0.3)) +#' oc3 <- qdm_oc(des3, data.frame(pi_t1 = 0.2 + effects$theta1, +#' pi_t2 = 0.2 + effects$theta2, rho_t = 0.3, +#' pi_c1 = 0.2, pi_c2 = 0.2, rho_c = 0.3), +#' seed = 1) +#' oc3 +#' plot(oc3) +#' @export +qdm_oc <- function(design, scenarios, nsim = 10000L, seed = NULL) { + check_design(design) + scenarios <- check_scenarios(design, scenarios) + check_numeric(nsim, "nsim", lower = 1, upper = .Machine$integer.max, + integer = TRUE) + if (!is.null(seed)) { + check_numeric(seed, "seed", lower = -.Machine$integer.max, + upper = .Machine$integer.max, integer = TRUE) + } + sample <- with_seed(seed, oc_sample(design, scenarios, nsim)) + probs <- oc_from_sample(sample, design$criterion$gamma_go, + design$criterion$gamma_nogo, + design$criterion$rule) + out <- cbind(scenarios, as.data.frame(probs)) + rownames(out) <- NULL + warn_miss(out$Miss, design$criterion$rule) + structure(out, class = c("qdm_oc", "data.frame"), design = design, + method = sample$method) +} diff --git a/R/qdm_regions.R b/R/qdm_regions.R new file mode 100644 index 0000000..bb2b5b4 --- /dev/null +++ b/R/qdm_regions.R @@ -0,0 +1,42 @@ +#' Region numbers for two endpoints +#' +#' Shows how the regions used by the decision criteria for two endpoints are +#' numbered (Yamaguchi et al., submitted, Tables 1 and 2). +#' +#' For posterior probability, the target value (TV) and the minimum acceptable +#' value (MAV) of each endpoint divide the plane of \eqn{(\theta_1, \theta_2)} +#' into nine regions. Columns correspond to endpoint 1 and rows to endpoint 2. +#' For posterior predictive probability, the null values divide the plane into +#' four regions. +#' +#' @param prob Either \code{"posterior"} (nine regions) or \code{"predictive"} +#' (four regions). +#' +#' @return A character matrix of region labels (printed without quotes), with +#' the conditions on endpoint 1 as column names and those on endpoint 2 as +#' row names. +#' +#' @references +#' Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +#' (submitted). Bivariate Bayesian quantitative decision-making for two +#' endpoints in rare disease drug development. +#' +#' @examples +#' qdm_regions("posterior") +#' qdm_regions("predictive") +#' @export +qdm_regions <- function(prob = c("posterior", "predictive")) { + prob <- match.arg(prob) + if (prob == "posterior") { + out <- matrix(paste0("R", 1:9), nrow = 3L, + dimnames = list(c("theta2 > TV2", "MAV2 < theta2 <= TV2", + "theta2 <= MAV2"), + c("theta1 > TV1", "MAV1 < theta1 <= TV1", + "theta1 <= MAV1"))) + } else { + out <- matrix(paste0("R", 1:4), nrow = 2L, + dimnames = list(c("theta2 > NULL2", "theta2 <= NULL2"), + c("theta1 > NULL1", "theta1 <= NULL1"))) + } + noquote(out) +} diff --git a/R/rdirichlet.R b/R/rdirichlet.R index 1dd9ed4..7f7949f 100644 --- a/R/rdirichlet.R +++ b/R/rdirichlet.R @@ -1,108 +1,33 @@ -#' Generate Random Samples from a Dirichlet Distribution +#' Random generation from the Dirichlet distribution #' -#' Generates random samples from a Dirichlet distribution using the Gamma -#' representation: if \eqn{Y_i \sim \mathrm{Gamma}(\alpha_i, 1)} independently -#' for \eqn{i = 1, \ldots, K}, then -#' \eqn{(Y_1 / S, \ldots, Y_K / S) \sim \mathrm{Dirichlet}(\alpha_1, \ldots, \alpha_K)}, -#' where \eqn{S = \sum_{i=1}^{K} Y_i}. +#' Draws random vectors from the Dirichlet distribution by normalizing +#' independent Gamma variables, using the random number generator of R. #' -#' @param n A positive integer specifying the number of random vectors to -#' generate. -#' @param alpha A numeric vector of length \eqn{K \ge 2} containing positive -#' concentration parameters of the Dirichlet distribution. -#' All elements must be strictly positive. +#' @param n Number of draws (a whole number of at least 1). +#' @param alpha Numeric vector of at least two positive concentration +#' parameters. #' -#' @return A numeric matrix of dimensions \code{n x K} where each row is one -#' random draw from the Dirichlet distribution, with all elements in -#' \code{[0, 1]} and each row summing to 1. -#' When \code{n = 1}, a numeric vector of length \code{K} is returned. -#' -#' @details -#' The Dirichlet distribution is a multivariate generalisation of the Beta -#' distribution and is commonly used as a conjugate prior for multinomial -#' proportions in Bayesian statistics. -#' -#' The probability density function is: -#' \deqn{f(x_1, \ldots, x_K) = -#' \frac{\Gamma\!\left(\sum_{i=1}^{K} \alpha_i\right)} -#' {\prod_{i=1}^{K} \Gamma(\alpha_i)} -#' \prod_{i=1}^{K} x_i^{\alpha_i - 1}} -#' where \eqn{x_i > 0} and \eqn{\sum_{i=1}^{K} x_i = 1}. -#' -#' Key properties: -#' \itemize{ -#' \item Each marginal follows a Beta distribution: -#' \eqn{X_i \sim \mathrm{Beta}\!\left(\alpha_i,\, -#' \sum_{l \neq i} \alpha_l\right)}. -#' \item \eqn{E[X_i] = \alpha_i / \sum_{l=1}^{K} \alpha_l}. -#' \item Components are negatively correlated unless one component dominates. -#' } -#' -#' Implementation steps: -#' \enumerate{ -#' \item Generate independent \eqn{Y_i \sim \mathrm{Gamma}(\alpha_i, 1)} for -#' each \eqn{i = 1, \ldots, K}. -#' \item Normalise: \eqn{X_i = Y_i / \sum_{l=1}^{K} Y_l}. -#' } +#' @return A numeric matrix with \code{n} rows and \code{length(alpha)} +#' columns whose rows sum to 1 (a matrix is returned even when +#' \code{n = 1}). Column names are taken from \code{names(alpha)}. #' +#' @family distributions #' @examples -#' # Example 1: Generate 5 samples from Dirichlet(1, 1, 1) - uniform on simplex -#' samples <- rdirichlet(5, c(1, 1, 1)) -#' print(samples) -#' rowSums(samples) # Each row should sum to 1 -#' -#' # Example 2: Generate samples with unequal concentrations -#' samples <- rdirichlet(1000, c(2, 5, 3)) -#' colMeans(samples) # Expected values: approximately c(0.2, 0.5, 0.3) -#' -#' # Example 3: Sparse Dirichlet (small alpha values) -#' samples <- rdirichlet(100, c(0.1, 0.1, 0.1, 0.1)) -#' head(samples) # Most weight concentrated on one component -#' -#' # Example 4: Concentrated Dirichlet (large alpha values) -#' samples <- rdirichlet(100, c(100, 100, 100)) -#' colMeans(samples) # Concentrated around c(1/3, 1/3, 1/3) -#' -#' # Example 5: Bayesian update with Jeffreys prior for 4 categories -#' prior_alpha <- c(0.5, 0.5, 0.5, 0.5) -#' observed_counts <- c(10, 5, 8, 7) -#' posterior_samples <- rdirichlet(1000, prior_alpha + observed_counts) -#' colMeans(posterior_samples) # Posterior mean -#' -#' @importFrom stats rgamma +#' set.seed(1) +#' rdirichlet(3, c(1.5, 0.5, 2, 1)) #' @export rdirichlet <- function(n, alpha) { - - # --- Input validation --- - if (!is.numeric(n) || length(n) != 1L || is.na(n) || - n != floor(n) || n < 1L) { - stop("'n' must be a single positive integer") + check_numeric(n, "n", lower = 1, integer = TRUE) + check_numeric(alpha, "alpha", len = NULL, lower = 0, lower_open = TRUE) + if (length(alpha) < 2L) { + stop("'alpha' must have length 2 or more.", call. = FALSE) } - - if (!is.numeric(alpha) || length(alpha) < 2L || any(is.na(alpha)) || - any(alpha <= 0)) { - stop("'alpha' must be a numeric vector of length >= 2 with all elements strictly positive") - } - - # --- Generate Dirichlet samples via the Gamma representation --- - # Build an (n x k) matrix where column j contains n independent - # Gamma(alpha[j], 1) draws. Using rep(alpha, each = n) ensures that - # the j-th block of n values uses shape alpha[j]; filling column-wise - # (byrow = FALSE, the R default) aligns each block with column j. + n <- as.integer(round(n)) k <- length(alpha) - gamma_samples <- matrix( - rgamma(n * k, shape = rep(alpha, each = n), rate = 1), - nrow = n, - ncol = k - ) - - # Normalise each row so that it sums to 1 - dirichlet_samples <- gamma_samples / rowSums(gamma_samples) - - # Return a plain vector when only one sample is requested - if (n == 1L) { - dirichlet_samples <- as.numeric(dirichlet_samples) - } - - return(dirichlet_samples) + # Column j holds n Gamma(alpha[j], 1) draws + g <- matrix(stats::rgamma(n * k, shape = rep(alpha, each = n)), nrow = n, + ncol = k) + out <- g / rowSums(g) + colnames(out) <- names(alpha) + out } diff --git a/R/recycle_common.R b/R/recycle_common.R new file mode 100644 index 0000000..4174d3d --- /dev/null +++ b/R/recycle_common.R @@ -0,0 +1,20 @@ +#' Recycle arguments to a common length +#' +#' Recycles a named list of vectors to the length of the longest element. +#' Each element must have length 1 or the common length. +#' +#' @param args A named list of vectors. +#' +#' @return A named list of vectors of the common length. +#' @noRd +recycle_common <- function(args) { + lens <- lengths(args) + n <- max(lens) + bad <- names(args)[lens != 1L & lens != n] + if (length(bad) > 0L) { + stop(sprintf("%s must have length 1 or %d.", + paste0("'", bad, "'", collapse = ", "), n), + call. = FALSE) + } + lapply(args, rep_len, length.out = n) +} diff --git a/R/region_cells.R b/R/region_cells.R new file mode 100644 index 0000000..259e8e8 --- /dev/null +++ b/R/region_cells.R @@ -0,0 +1,19 @@ +#' Cells of the nine regions of two continuous endpoints +#' +#' The probabilities of two continuous endpoints are computed on the nine +#' regions of a posterior criterion (Yamaguchi et al., submitted, Table 1). +#' The four regions of a predictive criterion (Table 2) are the regions 1, +#' 3, 7 and 9 of this grid with the target and minimum acceptable values +#' both equal to the null value. +#' +#' @param regions Region numbers of the criterion. +#' @param type \code{"posterior"} or \code{"predictive"}. +#' +#' @return The numbers of the corresponding regions of the nine-region grid. +#' @noRd +region_cells <- function(regions, type) { + if (type == "posterior") { + return(as.integer(regions)) + } + c(1L, 3L, 7L, 9L)[regions] +} diff --git a/R/region_mask.R b/R/region_mask.R new file mode 100644 index 0000000..008b69c --- /dev/null +++ b/R/region_mask.R @@ -0,0 +1,9 @@ +#' Bit mask of a set of regions +#' +#' @param regions Integer vector of region numbers (from 1). +#' +#' @return An integer with bit \code{r - 1} set for each region \code{r}. +#' @noRd +region_mask <- function(regions) { + as.integer(sum(2 ^ (unique(regions) - 1))) +} diff --git a/R/region_prob_binary.R b/R/region_prob_binary.R new file mode 100644 index 0000000..6ec7632 --- /dev/null +++ b/R/region_prob_binary.R @@ -0,0 +1,42 @@ +#' Probabilities of the Go and NoGo regions for a binary endpoint +#' +#' Computes the posterior (or posterior predictive) probabilities of the Go +#' and NoGo regions of a single binary endpoint from the parameters of the +#' Beta posterior distributions of the two groups, or of the treatment group +#' and a fixed control response rate. +#' +#' @param criterion An object of class \code{"qdm_criterion"} for one +#' endpoint. +#' @param a_t,b_t,a_c,b_c Numeric vectors of posterior Beta parameters +#' (\code{a_c} and \code{b_c} are not used for a fixed control). +#' @param fixed Fixed control response rate, or \code{NULL}. +#' +#' @return A list with numeric vectors \code{go} and \code{nogo}. +#' @noRd +region_prob_binary <- function(criterion, a_t, b_t, a_c, b_c, fixed = NULL) { + if (!is.null(fixed)) { + if (criterion$type == "posterior") { + # pi_t - fixed > TV if and only if pi_t > TV + fixed + go <- stats::pbeta(criterion$theta_tv + fixed, a_t, b_t, + lower.tail = FALSE) + nogo <- stats::pbeta(criterion$theta_mav + fixed, a_t, b_t) + } else { + go <- ppred_fixed_binary(criterion$theta_null, criterion$m_t, a_t, b_t, + fixed, lower.tail = FALSE) + nogo <- ppred_fixed_binary(criterion$theta_null, criterion$m_t, a_t, + b_t, fixed) + } + return(list(go = go, nogo = nogo)) + } + if (criterion$type == "posterior") { + go <- pbetadiff(criterion$theta_tv, a_t, b_t, a_c, b_c, + lower.tail = FALSE) + nogo <- pbetadiff(criterion$theta_mav, a_t, b_t, a_c, b_c) + } else { + go <- pbetabinomdiff(criterion$theta_null, criterion$m_t, a_t, b_t, + criterion$m_c, a_c, b_c, lower.tail = FALSE) + nogo <- pbetabinomdiff(criterion$theta_null, criterion$m_t, a_t, b_t, + criterion$m_c, a_c, b_c) + } + list(go = go, nogo = nogo) +} diff --git a/R/region_prob_binary2.R b/R/region_prob_binary2.R new file mode 100644 index 0000000..cd69cb5 --- /dev/null +++ b/R/region_prob_binary2.R @@ -0,0 +1,48 @@ +#' Probabilities of regions for two binary endpoints +#' +#' Computes, for pairs of treatment and control Dirichlet distributions, the +#' probabilities of unions of the regions of the criterion: posterior +#' probabilities by Monte Carlo simulation with \code{nMC} draws shared by +#' all pairs (Yamaguchi et al., submitted, equation A.2), or posterior +#' predictive probabilities computed exactly (equation A.4). +#' +#' @param criterion An object of class \code{"qdm_criterion"} for two +#' endpoints. +#' @param alpha_t,alpha_c Matrices of Dirichlet parameters (one row per +#' distribution; \code{alpha_c} is not used for a fixed control). +#' @param pair_t,pair_c Integer vectors of row indices (from 1) of the pairs +#' (\code{pair_c} is not used for a fixed control). +#' @param sets List of integer vectors of region numbers. +#' @param nMC Number of Monte Carlo draws (posterior criteria). +#' @param fixed Fixed control response rates of the two endpoints, or +#' \code{NULL}. +#' +#' @return A numeric matrix with one row per pair and one column per element +#' of \code{sets}. +#' @noRd +region_prob_binary2 <- function(criterion, alpha_t, alpha_c, pair_t, pair_c, + sets, nMC, fixed = NULL) { + masks <- vapply(sets, region_mask, integer(1)) + value_c <- c(0, 0) + if (!is.null(fixed)) { + # A control matrix without rows makes the C++ code use the fixed values + alpha_c <- matrix(0, 0L, 4L) + pair_c <- rep(1L, length(pair_t)) + value_c <- as.numeric(fixed) + } + storage.mode(alpha_t) <- "double" + storage.mode(alpha_c) <- "double" + pair_t <- as.integer(pair_t) - 1L + pair_c <- as.integer(pair_c) - 1L + if (criterion$type == "posterior") { + cpp_post_regions_binary2(alpha_t, alpha_c, pair_t, pair_c, + as.numeric(criterion$theta_tv), + as.numeric(criterion$theta_mav), masks, + as.integer(nMC), value_c) + } else { + cpp_pred_regions_binary2(alpha_t, alpha_c, pair_t, pair_c, + criterion$m_t, criterion$m_c, + as.numeric(criterion$theta_null), masks, + value_c) + } +} diff --git a/R/region_prob_continuous.R b/R/region_prob_continuous.R new file mode 100644 index 0000000..3bb579c --- /dev/null +++ b/R/region_prob_continuous.R @@ -0,0 +1,63 @@ +#' Probabilities of the Go and NoGo regions for a continuous endpoint +#' +#' Computes the posterior (or posterior predictive) probabilities of the Go +#' and NoGo regions of a single continuous endpoint from the parameters of the +#' Normal-Inverse-chi-squared posterior distributions of the two groups. The +#' posterior distribution of the mean of a group is +#' \eqn{t_{\nu}(\mu, \sigma^2 / \kappa)}, and the posterior predictive +#' distribution of the mean of \eqn{m} future subjects is +#' \eqn{t_{\nu}(\mu, \sigma^2 (1 / \kappa + 1 / m))}. With +#' \code{method = "MC"}, both probabilities are estimated from the same draws, +#' so that they add up to 1 for the predictive criterion. For a fixed control +#' mean, the probabilities are computed exactly from the t distribution of +#' the treatment mean (\code{post_c}, \code{method} and \code{nMC} are not +#' used). +#' +#' @param criterion An object of class \code{"qdm_criterion"} for one +#' endpoint. +#' @param post_t,post_c Lists with elements \code{mu}, \code{kappa}, +#' \code{nu} and \code{sigma2}. +#' @param method One of \code{"NI"}, \code{"MM"} or \code{"MC"}. +#' @param nMC Number of Monte Carlo draws for \code{method = "MC"}. +#' @param fixed Fixed control mean, or \code{NULL}. +#' +#' @return A list with numeric vectors \code{go} and \code{nogo}. +#' @noRd +region_prob_continuous <- function(criterion, post_t, post_c, method, + nMC = 10000L, fixed = NULL) { + if (criterion$type == "posterior") { + scale_t <- sqrt(post_t$sigma2 / post_t$kappa) + q_go <- criterion$theta_tv + q_nogo <- criterion$theta_mav + } else { + scale_t <- sqrt(post_t$sigma2 * (1 / post_t$kappa + 1 / criterion$m_t)) + q_go <- criterion$theta_null + q_nogo <- criterion$theta_null + } + if (!is.null(fixed)) { + # mean_t - fixed > q if and only if mean_t > q + fixed + go <- stats::pt((q_go + fixed - post_t$mu) / scale_t, post_t$nu, + lower.tail = FALSE) + nogo <- stats::pt((q_nogo + fixed - post_t$mu) / scale_t, post_t$nu) + return(list(go = go, nogo = nogo)) + } + scale_c <- if (criterion$type == "posterior") { + sqrt(post_c$sigma2 / post_c$kappa) + } else { + sqrt(post_c$sigma2 * (1 / post_c$kappa + 1 / criterion$m_c)) + } + if (method == "MC") { + a <- recycle_common(list(q_go = q_go, q_nogo = q_nogo, mu_t = post_t$mu, + scale_t = scale_t, df_t = post_t$nu, + mu_c = post_c$mu, scale_c = scale_c, + df_c = post_c$nu)) + p <- cpp_ptdiff_mc_regions(a$q_go, a$q_nogo, a$mu_t, a$scale_t, a$df_t, + a$mu_c, a$scale_c, a$df_c, as.integer(nMC)) + return(list(go = p[, 1L], nogo = p[, 2L])) + } + go <- ptdiff(q_go, post_t$mu, scale_t, post_t$nu, post_c$mu, scale_c, + post_c$nu, method = method, lower.tail = FALSE) + nogo <- ptdiff(q_nogo, post_t$mu, scale_t, post_t$nu, post_c$mu, scale_c, + post_c$nu, method = method) + list(go = go, nogo = nogo) +} diff --git a/R/region_prob_continuous2.R b/R/region_prob_continuous2.R new file mode 100644 index 0000000..e3482ff --- /dev/null +++ b/R/region_prob_continuous2.R @@ -0,0 +1,51 @@ +#' Probabilities of unions of regions for two continuous endpoints +#' +#' @param criterion A criterion for two endpoints. +#' @param dist_t,dist_c Distributions of the treatment and control means (see +#' \code{mean_dist_continuous2()}), with the same number of rows or one +#' row (\code{dist_c} is not used for a fixed control). +#' @param sets List of integer vectors of region numbers of the criterion. +#' @param method \code{"MM"} or \code{"MC"}. +#' @param nMC Number of Monte Carlo draws (MC only). +#' @param fixed Fixed control means of the two endpoints, or \code{NULL}. The +#' control is then represented by a scale matrix of zeros, for which the +#' moment-matching function of the C++ code computes the exact +#' probabilities of the bivariate t distribution of the treatment mean +#' (whatever \code{method}). +#' +#' @return A numeric matrix with one row per pair of distributions and one +#' column per element of \code{sets}. +#' @noRd +region_prob_continuous2 <- function(criterion, dist_t, dist_c, sets, method, + nMC = 10000L, fixed = NULL) { + if (!is.null(fixed)) { + dist_c <- list(loc = matrix(fixed, 1L, 2L), scale = matrix(0, 1L, 3L), + df = 1) + method <- "MM" + } + if (criterion$type == "posterior") { + tv <- as.numeric(criterion$theta_tv) + mav <- as.numeric(criterion$theta_mav) + } else { + tv <- as.numeric(criterion$theta_null) + mav <- tv + } + masks <- vapply(sets, function(s) { + region_mask(region_cells(s, criterion$type)) + }, integer(1)) + n <- max(nrow(dist_t$loc), nrow(dist_c$loc)) + rows <- function(x) { + x <- x[rep_len(seq_len(nrow(x)), n), , drop = FALSE] + storage.mode(x) <- "double" + x + } + args <- list(rows(dist_t$loc), rows(dist_t$scale), + rep_len(as.numeric(dist_t$df), n), rows(dist_c$loc), + rows(dist_c$scale), rep_len(as.numeric(dist_c$df), n), tv, + mav, masks) + if (method == "MC") { + return(do.call(cpp_regions_continuous2_mc, + c(args, list(as.integer(nMC))))) + } + do.call(cpp_regions_continuous2_mm, args) +} diff --git a/R/region_prob_tte.R b/R/region_prob_tte.R new file mode 100644 index 0000000..b204d9e --- /dev/null +++ b/R/region_prob_tte.R @@ -0,0 +1,55 @@ +#' Probabilities of the Go and NoGo regions for a time-to-event endpoint +#' +#' Posterior probabilities are computed exactly from the Gamma distribution +#' of the treatment hazard for a fixed control and by \code{psurvdiff()} +#' otherwise. Posterior predictive probabilities are estimated by +#' simulating \code{design$nMC} future studies for each posterior +#' distribution (\code{cpp_pred_tte()}); the Go and NoGo probabilities are +#' estimated from the same simulations and add up to 1. +#' +#' @param design An object of class \code{"qdm_design_tte"}. +#' @param post_t List with numeric vectors \code{shape} and \code{rate} of the +#' posterior distributions of the treatment hazard. +#' @param post_c The same for the control hazard (vectors of the same length +#' as those of \code{post_t}, or of length 1), or \code{NULL} for a fixed +#' control. +#' +#' @return A list with numeric vectors \code{go} and \code{nogo}. +#' @noRd +region_prob_tte <- function(design, post_t, post_c) { + crit <- design$criterion + t0 <- design$milestone + fixed <- design$fixed_c + if (crit$type == "posterior") { + if (!is.null(fixed)) { + # S_t - fixed > q if and only if S_t > q + fixed + go <- psurv_fixed(crit$theta_tv + fixed, t0, post_t$shape, + post_t$rate, lower.tail = FALSE) + nogo <- psurv_fixed(crit$theta_mav + fixed, t0, post_t$shape, + post_t$rate) + } else { + go <- psurvdiff(crit$theta_tv, t0, post_t$shape, post_t$rate, + post_c$shape, post_c$rate, lower.tail = FALSE) + nogo <- psurvdiff(crit$theta_mav, t0, post_t$shape, post_t$rate, + post_c$shape, post_c$rate) + } + return(list(go = go, nogo = nogo)) + } + n <- length(post_t$shape) + ca <- conduct_args(design$conduct_future) + prior_c <- if (is.null(fixed)) { + c(design$prior_c$shape, design$prior_c$rate) + } else { + c(1, 1) + } + go <- cpp_pred_tte( + as.numeric(post_t$shape), as.numeric(post_t$rate), + if (is.null(fixed)) rep_len(as.numeric(post_c$shape), n) else numeric(0), + if (is.null(fixed)) rep_len(as.numeric(post_c$rate), n) else numeric(0), + if (is.null(fixed)) 0 else fixed, + c(design$prior_t$shape, design$prior_t$rate), prior_c, crit$m_t, + crit$m_c, ca$acc_time, ca$acc_cum, ca$drop_start, ca$drop_hazard, + ca$cut_time, ca$cut_events, t0, crit$theta_null, design$nMC + ) + list(go = go, nogo = 1 - go) +} diff --git a/R/region_sets.R b/R/region_sets.R new file mode 100644 index 0000000..fcc0f3b --- /dev/null +++ b/R/region_sets.R @@ -0,0 +1,21 @@ +#' Regions used by the Go and NoGo criteria of two endpoints +#' +#' @param criterion An object of class \code{"qdm_criterion"} for two +#' endpoints. +#' +#' @return A list with elements \code{go} and \code{nogo}, each a list of +#' integer vectors of region numbers: one vector (the union of regions) for +#' \code{rule = "joint"}, and one per endpoint for the marginal rules +#' (Yamaguchi et al., submitted, equations 4, 5, 9 and 10). +#' @noRd +region_sets <- function(criterion) { + if (criterion$rule == "joint") { + return(list(go = list(criterion$go_regions), + nogo = list(criterion$nogo_regions))) + } + if (criterion$type == "posterior") { + list(go = list(1:3, c(1L, 4L, 7L)), nogo = list(7:9, c(3L, 6L, 9L))) + } else { + list(go = list(1:2, c(1L, 3L)), nogo = list(3:4, c(2L, 4L))) + } +} diff --git a/R/sample_column.R b/R/sample_column.R new file mode 100644 index 0000000..dbd909e --- /dev/null +++ b/R/sample_column.R @@ -0,0 +1,16 @@ +#' Probabilities of a region for one scenario +#' +#' @param p A vector or matrix of probabilities, or a list of two of them +#' (marginal rules). +#' @param j Index of the scenario. +#' @param per_scenario Logical; whether \code{p} has one column per scenario +#' (otherwise \code{p} is the same for all scenarios). +#' +#' @return \code{p} for scenario \code{j}, of the same form. +#' @noRd +sample_column <- function(p, j, per_scenario = is.matrix(p)) { + if (is.list(p)) { + return(lapply(p, sample_column, j = j, per_scenario = per_scenario)) + } + if (per_scenario) p[, j] else p +} diff --git a/R/sample_weights.R b/R/sample_weights.R new file mode 100644 index 0000000..2191535 --- /dev/null +++ b/R/sample_weights.R @@ -0,0 +1,15 @@ +#' Probabilities of the outcomes under one scenario +#' +#' @param sample A list returned by \code{oc_sample()}. +#' @param j Index of the scenario. +#' +#' @return A numeric vector of probabilities, or for enumerated outcomes of +#' two groups a list with elements \code{t} and \code{c} (probabilities of +#' the treatment and control outcomes). +#' @noRd +sample_weights <- function(sample, j) { + if (is.null(sample[["weights"]])) { + return(list(t = sample$weights_t[, j], c = sample$weights_c[, j])) + } + sample[["weights"]][, j] +} diff --git a/R/scenario_columns.R b/R/scenario_columns.R new file mode 100644 index 0000000..f072d1b --- /dev/null +++ b/R/scenario_columns.R @@ -0,0 +1,48 @@ +#' Columns of the scenarios of a design +#' +#' @param design An object of class \code{"qdm_design"}. +#' +#' @return A list with elements \code{names} (the required columns), +#' \code{lower} and \code{upper} (bounds of their values), +#' \code{lower_open} and \code{upper_open} (whether the bounds are +#' excluded), each of the length of \code{names}. +#' @noRd +scenario_columns <- function(design) { + concurrent <- design$control == "concurrent" + cols <- switch( + design$endpoint, + binary = list(names = c("pi_t", "pi_c"), lower = c(0, 0), + upper = c(1, 1), lower_open = c(FALSE, FALSE), + upper_open = c(FALSE, FALSE)), + continuous = list(names = c("mu_t", "sd_t", "mu_c", "sd_c"), + lower = c(-Inf, 0, -Inf, 0), + upper = c(Inf, Inf, Inf, Inf), + lower_open = c(FALSE, TRUE, FALSE, TRUE), + upper_open = rep(FALSE, 4L)), + binary2 = list(names = c("pi_t1", "pi_t2", "rho_t", "pi_c1", "pi_c2", + "rho_c"), + lower = rep(c(0, 0, -1), 2L), upper = rep(1, 6L), + lower_open = rep(c(TRUE, TRUE, FALSE), 2L), + upper_open = rep(c(TRUE, TRUE, FALSE), 2L)), + continuous2 = list(names = c("mu_t1", "mu_t2", "sd_t1", "sd_t2", "rho_t", + "mu_c1", "mu_c2", "sd_c1", "sd_c2", + "rho_c"), + lower = rep(c(-Inf, -Inf, 0, 0, -1), 2L), + upper = rep(c(Inf, Inf, Inf, Inf, 1), 2L), + lower_open = rep(c(FALSE, FALSE, TRUE, TRUE, TRUE), + 2L), + upper_open = rep(c(FALSE, FALSE, FALSE, FALSE, TRUE), + 2L)), + tte = list(names = c("median_t", "median_c"), lower = c(0, 0), + upper = c(Inf, Inf), lower_open = c(TRUE, TRUE), + upper_open = c(FALSE, FALSE)) + ) + # Columns of the treatment group come first; those of the control group + # are required only with a concurrent control group + keep <- if (concurrent) { + seq_along(cols$names) + } else { + seq_len(length(cols$names) / 2L) + } + lapply(cols, `[`, keep) +} diff --git a/R/select_gamma.R b/R/select_gamma.R new file mode 100644 index 0000000..8bbd3b5 --- /dev/null +++ b/R/select_gamma.R @@ -0,0 +1,15 @@ +#' Smallest threshold that meets a target +#' +#' @param grid Increasing numeric vector of thresholds. +#' @param prob Probabilities of meeting the criterion at the thresholds +#' (non-increasing in the threshold). +#' @param target Upper bound for the probability. +#' +#' @return The smallest element of \code{grid} whose probability is at most +#' \code{target} (up to a tolerance of 1e-12), or \code{NA} if there is +#' none. +#' @noRd +select_gamma <- function(grid, prob, target) { + ok <- which(prob <= target + 1e-12) + if (length(ok) == 0L) NA_real_ else grid[min(ok)] +} diff --git a/R/shade_color.R b/R/shade_color.R new file mode 100644 index 0000000..ec992e6 --- /dev/null +++ b/R/shade_color.R @@ -0,0 +1,20 @@ +#' Shades of a color by probability +#' +#' Interpolates linearly in RGB between white (probability 0) and a color +#' (probability 1), channel by channel, and rounds to an integer. Missing +#' probabilities give white. +#' +#' @param prob Numeric vector of probabilities. +#' @param color Colors, of length 1 or the length of \code{prob}. +#' +#' @return A character vector of hexadecimal color codes. +#' @noRd +shade_color <- function(prob, color) { + rgb <- t(grDevices::col2rgb(rep_len(color, length(prob)))) + p <- pmin(pmax(prob, 0), 1) + v <- round(255 + p * (rgb - 255)) + out <- sprintf("#%02X%02X%02X", as.integer(v[, 1L]), as.integer(v[, 2L]), + as.integer(v[, 3L])) + out[is.na(prob)] <- "#FFFFFF" + out +} diff --git a/R/simulate_counts_binary2.R b/R/simulate_counts_binary2.R new file mode 100644 index 0000000..f227f4b --- /dev/null +++ b/R/simulate_counts_binary2.R @@ -0,0 +1,22 @@ +#' Simulated counts of two binary endpoints with common random numbers +#' +#' Assigns each simulated subject to one of the four cells by comparing a +#' uniform random number with the cumulative cell probabilities, so that the +#' same random numbers give similar data under similar scenarios. +#' +#' @param u Numeric matrix of uniform random numbers, one row per simulated +#' study and one column per subject. +#' @param p Cell probabilities (\code{"00"}, \code{"01"}, \code{"10"}, +#' \code{"11"}). +#' +#' @return An integer matrix of counts with one row per simulated study and +#' the columns \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"}. +#' @noRd +simulate_counts_binary2 <- function(u, p) { + cum <- cumsum(p)[1:3] + cell <- 1L + (u > cum[1]) + (u > cum[2]) + (u > cum[3]) + out <- vapply(1:4, function(k) rowSums(cell == k), numeric(nrow(u))) + out <- matrix(as.integer(out), nrow = nrow(u)) + dimnames(out) <- list(NULL, c("00", "01", "10", "11")) + out +} diff --git a/R/split_sets.R b/R/split_sets.R new file mode 100644 index 0000000..cca496b --- /dev/null +++ b/R/split_sets.R @@ -0,0 +1,24 @@ +#' Probabilities of the Go and NoGo criteria from region probabilities +#' +#' @param p Numeric matrix with one column per set of regions: the Go sets +#' followed by the NoGo sets (see \code{region_sets()}). +#' @param n_go Number of Go sets (1 for \code{rule = "joint"}, 2 for the +#' marginal rules). +#' @param dim Optional dimensions given to each column (for example the +#' numbers of treatment and control outcomes). +#' +#' @return A list with elements \code{go} and \code{nogo}: a vector (or array +#' with dimensions \code{dim}) for one set, or a list of two for the +#' marginal rules. +#' @noRd +split_sets <- function(p, n_go, dim = NULL) { + col <- function(k) { + v <- p[, k] + if (!is.null(dim)) { + v <- array(v, dim = dim) + } + v + } + pick <- function(ks) if (length(ks) == 1L) col(ks) else lapply(ks, col) + list(go = pick(seq_len(n_go)), nogo = pick(n_go + seq_len(n_go))) +} diff --git a/R/stats_continuous2.R b/R/stats_continuous2.R new file mode 100644 index 0000000..33f6876 --- /dev/null +++ b/R/stats_continuous2.R @@ -0,0 +1,34 @@ +#' Sufficient statistics of simulated studies with two continuous endpoints +#' +#' With \eqn{\Sigma = L L^T} (Cholesky factor of the covariance matrix of the +#' scenario), the sample mean is \eqn{\bar y = \mu + L z / \sqrt{n}} with +#' \eqn{z = (z_1, z_2)}, and the matrix of sums of squares and +#' cross-products is \eqn{S = L A A^T L^T} with the Bartlett factor +#' \eqn{A = ((\sqrt{x_1}, 0), (z_{12}, \sqrt{x_2}))}, so that \eqn{S} has the +#' Wishart distribution with \eqn{n - 1} degrees of freedom and scale matrix +#' \eqn{\Sigma}, independently of \eqn{\bar y}. +#' +#' @param draws Random numbers from \code{draws_continuous2()}. +#' @param n Number of subjects. +#' @param mu,sd Means and standard deviations of the two endpoints. +#' @param rho Correlation of the two endpoints. +#' +#' @return A list with elements \code{mean} (matrix with two columns) and +#' \code{cov} (sample covariance matrices, matrix with the columns +#' \code{c11}, \code{c12} and \code{c22}). +#' @noRd +stats_continuous2 <- function(draws, n, mu, sd, rho) { + l11 <- sd[1L] + l21 <- rho * sd[2L] + l22 <- sd[2L] * sqrt(1 - rho ^ 2) + mean <- cbind(mu[1L] + l11 * draws$z1 / sqrt(n), + mu[2L] + (l21 * draws$z1 + l22 * draws$z2) / sqrt(n)) + w11 <- draws$x1 + w12 <- sqrt(draws$x1) * draws$z12 + w22 <- draws$z12 ^ 2 + draws$x2 + cov <- cbind(c11 = l11 ^ 2 * w11, + c12 = l11 * (l21 * w11 + l22 * w12), + c22 = l21 ^ 2 * w11 + 2 * l21 * l22 * w12 + l22 ^ 2 * w22) / + (n - 1) + list(mean = mean, cov = cov) +} diff --git a/R/tte_method_label.R b/R/tte_method_label.R new file mode 100644 index 0000000..44fb4a3 --- /dev/null +++ b/R/tte_method_label.R @@ -0,0 +1,17 @@ +#' Description of the computation of the probabilities of a time-to-event +#' design +#' +#' @param design An object of class \code{"qdm_design_tte"}. +#' +#' @return A character string. +#' @noRd +tte_method_label <- function(design) { + if (design$criterion$type == "predictive") { + return(sprintf("simulation of future studies (nMC = %d)", design$nMC)) + } + if (design$control == "fixed") { + "exact computation (fixed control)" + } else { + "numerical integration" + } +} diff --git a/R/warn_miss.R b/R/warn_miss.R new file mode 100644 index 0000000..459b02f --- /dev/null +++ b/R/warn_miss.R @@ -0,0 +1,25 @@ +#' Warn about positive probabilities of Miss decisions +#' +#' @param miss Numeric vector of probabilities of Miss decisions. +#' @param rule Rule of the criterion (\code{"joint"}, \code{"and"} or +#' \code{"or"}), which determines when Miss decisions are impossible. +#' +#' @return \code{NULL}, invisibly. +#' @noRd +warn_miss <- function(miss, rule = "joint") { + k <- sum(miss > 0, na.rm = TRUE) + if (k > 0L) { + hint <- switch( + rule, + joint = "A Miss decision is impossible if gamma_go + gamma_nogo > 1.", + and = paste("A Miss decision is impossible if gamma_go + gamma_nogo >", + "1 for at least one endpoint."), + or = paste("With rule = \"or\", a Miss decision can occur for any", + "thresholds (Go on one endpoint and NoGo on the other).") + ) + warning(sprintf(paste("The Go and NoGo criteria are both met (Miss) with", + "positive probability in %d scenario(s); see the", + "column 'Miss'. %s"), k, hint), call. = FALSE) + } + invisible(NULL) +} diff --git a/R/warn_unused_dots.R b/R/warn_unused_dots.R new file mode 100644 index 0000000..80a692d --- /dev/null +++ b/R/warn_unused_dots.R @@ -0,0 +1,25 @@ +#' Warn about arguments that a plot method does not use +#' +#' Arguments that a \code{plot()} method does not have are collected by +#' \code{...}. They are ignored with a warning that names them, as +#' \pkg{ggplot2} does for unknown parameters, so that a misspelled argument +#' or one that applies only to another plot is not dropped silently. +#' +#' @param dots The arguments in \code{...}, as a list. +#' @param fun Name of the method, used in the warning. +#' +#' @return \code{NULL}, invisibly. +#' @noRd +warn_unused_dots <- function(dots, fun) { + if (length(dots) == 0L) { + return(invisible(NULL)) + } + nms <- names(dots) + if (is.null(nms)) { + nms <- rep("", length(dots)) + } + nms[nms == ""] <- "an unnamed argument" + warning(sprintf("Ignoring unknown argument(s) of %s(): %s.", fun, + paste(nms, collapse = ", ")), call. = FALSE) + invisible(NULL) +} diff --git a/R/with_seed.R b/R/with_seed.R new file mode 100644 index 0000000..499ce62 --- /dev/null +++ b/R/with_seed.R @@ -0,0 +1,34 @@ +#' Evaluate an expression with a temporary random seed +#' +#' If \code{seed} is \code{NULL}, \code{expr} is evaluated with the current +#' random number stream. Otherwise the random number generator is seeded with +#' \code{seed}, \code{expr} is evaluated, and the previous state of the +#' generator (\code{.Random.seed} in the global environment) is restored on +#' exit. +#' +#' @param seed A single number or \code{NULL}. +#' @param expr Expression to evaluate. It is evaluated lazily, after seeding. +#' +#' @return The value of \code{expr}. +#' @noRd +with_seed <- function(seed, expr) { + if (is.null(seed)) { + return(expr) + } + check_numeric(seed, "seed", lower = -.Machine$integer.max, + upper = .Machine$integer.max, integer = TRUE) + env <- globalenv() + has_seed <- exists(".Random.seed", envir = env, inherits = FALSE) + if (has_seed) { + old_seed <- get(".Random.seed", envir = env, inherits = FALSE) + } + on.exit({ + if (has_seed) { + assign(".Random.seed", old_seed, envir = env) + } else if (exists(".Random.seed", envir = env, inherits = FALSE)) { + rm(".Random.seed", envir = env) + } + }, add = TRUE) + set.seed(seed) + expr +} diff --git a/R/zzz.R b/R/zzz.R deleted file mode 100644 index 0d931f5..0000000 --- a/R/zzz.R +++ /dev/null @@ -1,16 +0,0 @@ -# Suppress R CMD check NOTEs for ggplot2 aes() column name references. -# These variables are data frame column names used inside aes() and are not -# true global variables; utils::globalVariables() informs the static analyser. -utils::globalVariables(c( - "Decision", # plot.pbayesdecisionprob1bin, plot.pbayesdecisionprob1cont - "prob", # plot.getgamma1bin, plot.getgamma1cont, - # plot.getgamma2bin, plot.getgamma2cont - "prob_val", # plot.pbayesdecisionprob2bin, plot.pbayesdecisionprob2cont - "pt_grp", # plot.getgamma1bin, plot.getgamma1cont, - # plot.getgamma2bin, plot.getgamma2cont - "Scenario", # plot.getgamma1bin, plot.getgamma1cont, - # plot.getgamma2bin, plot.getgamma2cont - "fill_col", # plot.pbayesdecisionprob2bin (overlay mode) - "y", # plot.pbayesdecisionprob2bin (overlay legend) - "lab" # plot.pbayesdecisionprob2bin (overlay legend) -)) diff --git a/README.Rmd b/README.Rmd new file mode 100644 index 0000000..993ed0f --- /dev/null +++ b/README.Rmd @@ -0,0 +1,165 @@ +--- +output: github_document +--- + + + +```{r, include = FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +library(BayesianQDM) +``` + +# BayesianQDM + + +[![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) +[![CRAN downloads](https://cranlogs.r-pkg.org/badges/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) +[![CRAN downloads total](https://cranlogs.r-pkg.org/badges/grand-total/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) +[![R-CMD-check](https://github.com/gosukehommaEX/BayesianQDM/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/gosukehommaEX/BayesianQDM/actions/workflows/R-CMD-check.yaml) +[![Codecov test coverage](https://codecov.io/gh/gosukehommaEX/BayesianQDM/branch/main/graph/badge.svg)](https://app.codecov.io/gh/gosukehommaEX/BayesianQDM?branch=main) +[![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) + + +## Overview + +BayesianQDM implements Bayesian quantitative decision-making (QDM) for +proof-of-concept (PoC) clinical trials (Kang, Yamaguchi and Han, 2026). The +data of a PoC study lead to one of three decisions: Go (proceed to the next +phase), NoGo (stop the development) or Gray (the evidence is not sufficient +for either). The criteria compare the posterior or posterior predictive +probability of the treatment effect with thresholds, for a target value (TV) +and a minimum acceptable value (MAV) of the effect. + +The package answers four questions for a planned or completed study: + +- Which decision do the observed data lead to? (`qdm_decide()`) +- How often does the design lead to each decision when the true effect is + known? (`qdm_oc()`) +- Which thresholds keep the probabilities of a false Go and a false NoGo + decision below given targets? (`qdm_calibrate()`) +- Which observed data lead to each decision? (`qdm_boundary()`) + +A study is described by small specification objects (priors, data, +external data borrowed through a power prior, a hypothetical control and a +decision criterion), which are combined into a design. + +| Endpoints | Design | Model | Computation of the probabilities | +|---|---|---|---| +| One binary | `design_binary()` | Beta-binomial | Numerical integration (posterior), exact sum (predictive) | +| One continuous | `design_continuous()` | Normal-Inverse-chi-squared or vague | Numerical integration, moment matching or Monte Carlo | +| Two binary | `design_binary2()` | Dirichlet-multinomial | Monte Carlo (posterior), exact sum (predictive) | +| Two continuous | `design_continuous2()` | Normal-Inverse-Wishart or vague | Moment matching or Monte Carlo | +| One time-to-event | `design_tte()` | Exponential with Gamma prior (milestone survival) | Numerical integration (posterior), simulation (predictive) | + +The control group can be a concurrent control group, external control data +only, a hypothetical control, or a fixed value of the control parameter (a +single-arm study compared with a benchmark), and external data can be +borrowed for either group. + +## Installation + +```r +# From CRAN +install.packages("BayesianQDM") + +# Development version from GitHub +# install.packages("pak") +pak::pak("gosukehommaEX/BayesianQDM") +``` + +## Example + +A PoC study with one binary endpoint and 12 subjects in each group, Jeffreys +priors, and a posterior criterion with TV = 0.2 and MAV = 0.1: + +```{r design} +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +``` + +Decision for 9 responders in the treatment group and 4 in the control group: + +```{r decide} +qdm_decide(des, data_t = data_binary(12, 9), data_c = data_binary(12, 4)) +``` + +Operating characteristics for true response rates of the treatment group +from 0.3 to 0.7 with a control rate of 0.3: + +```{r oc} +qdm_oc(des, data.frame(pi_t = seq(0.3, 0.7, by = 0.1), pi_c = 0.3)) +``` + +Thresholds for which the probability of meeting the Go criterion is at most +0.05 when the treatment has no effect, and that of meeting the NoGo +criterion is at most 0.2 when the effect is 0.3: + +```{r calibrate} +qdm_calibrate(des, + scenario_go = data.frame(pi_t = 0.3, pi_c = 0.3), + scenario_nogo = data.frame(pi_t = 0.6, pi_c = 0.3), + target_go = 0.05, target_nogo = 0.2) +``` + +`plot()` draws the operating characteristics, the calibration curves and the +decision boundaries computed by `qdm_boundary()`. The plots are ggplot2 +objects: their arguments set the colors of the decisions, the line widths, +the text sizes and the position of the legend, and ggplot2 functions can be +added to change them further. + +## Documentation + +The vignettes describe the models and the functions with examples: + +- [Overview of BayesianQDM](https://gosukehommaEX.github.io/BayesianQDM/articles/overview.html) +- [Single binary endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-binary.html) +- [Single continuous endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-continuous.html) +- [Two binary endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-binary.html) +- [Two continuous endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-continuous.html) +- [Time-to-event endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/time-to-event.html) +- [Migrating from version 0.1.0](https://gosukehommaEX.github.io/BayesianQDM/articles/migration.html) + +After installation, `vignette(package = "BayesianQDM")` lists them. The +[package website](https://gosukehommaEX.github.io/BayesianQDM/) also has the +function reference. + +Version 1.0.0 is a redesign of version 0.1.0 and is not backward compatible. +The [NEWS](https://gosukehommaEX.github.io/BayesianQDM/news/index.html) file +lists the changes, including corrections of formulas and numerical methods. + +The scripts in `inst/validation/` compare the package with published and +submitted results; `inst/validation/results/summary.md` reports the +comparisons. + +## Citation + +For the framework, please cite + +> Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +> decision-making framework in cell and gene therapy development for rare +> diseases. *Journal of Biopharmaceutical Statistics*. +> + +and for the package + +> Homma, G. and Yamaguchi, Y. (2026). BayesianQDM: Bayesian Quantitative +> Decision-Making Framework for Binary, Continuous and Time-to-Event +> Endpoints. R package version `r packageVersion("BayesianQDM")`. + +## License + +GPL (>= 2) + +## Authors + +- Gosuke Homma (maintainer) +- Yusuke Yamaguchi + +## Issues + +Please report bugs and requests on the +[GitHub issue tracker](https://github.com/gosukehommaEX/BayesianQDM/issues). diff --git a/README.md b/README.md index 471466a..451e6d9 100644 --- a/README.md +++ b/README.md @@ -1,178 +1,193 @@ + + + # BayesianQDM + [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) -[![CRAN downloads](https://cranlogs.r-pkg.org/badges/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) -[![CRAN downloads total](https://cranlogs.r-pkg.org/badges/grand-total/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) -[![R-CMD-check](https://github.com/gosukehommaEX/BayesianQDM/workflows/R-CMD-check/badge.svg)](https://github.com/gosukehommaEX/BayesianQDM/actions) -[![Codecov test coverage](https://codecov.io/gh/gosukehommaEX/BayesianQDM/branch/main/graph/badge.svg)](https://app.codecov.io/gh/gosukehommaEX/BayesianQDM?branch=main) -[![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) +[![CRAN +downloads](https://cranlogs.r-pkg.org/badges/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) +[![CRAN downloads +total](https://cranlogs.r-pkg.org/badges/grand-total/BayesianQDM)](https://cran.r-project.org/package=BayesianQDM) +[![R-CMD-check](https://github.com/gosukehommaEX/BayesianQDM/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/gosukehommaEX/BayesianQDM/actions/workflows/R-CMD-check.yaml) +[![Codecov test +coverage](https://codecov.io/gh/gosukehommaEX/BayesianQDM/branch/main/graph/badge.svg)](https://app.codecov.io/gh/gosukehommaEX/BayesianQDM?branch=main) +[![Lifecycle: +stable](https://img.shields.io/badge/lifecycle-stable-brightgreen.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) ## Overview -BayesianQDM provides a comprehensive framework for **Bayesian Quantitative Decision-Making** in clinical trials. The package enables researchers to compute posterior probabilities, posterior predictive probabilities, and **Go/NoGo/Gray** decision probabilities for both single and two-endpoint analyses with binary and continuous outcomes. The package also provides functions to find optimal Go/NoGo thresholds that satisfy user-specified operating characteristic criteria. - -## Key Features - -- **Single and Two Endpoints**: Supports single binary, single continuous, two binary, and two continuous endpoint analyses -- **Multiple Study Designs**: Controlled, uncontrolled (hypothetical control), and external designs -- **Flexible Prior Specification**: Vague (Jeffreys) priors and conjugate priors (Beta, Normal-Inverse-Chi-squared, Normal-Inverse-Wishart, Dirichlet) -- **Power Priors**: Exact conjugate representation for incorporating historical or external data without MCMC -- **Multiple Calculation Methods**: Numerical integration (NI), Monte Carlo simulation (MC), and Moment-Matching approximation (MM) for continuous endpoints -- **Three-Zone Decision Framework**: Go/NoGo/Gray probability calculation with user-defined thresholds (TV and MAV) -- **Optimal Threshold Search**: Grid-search functions to find Go/NoGo thresholds satisfying target operating characteristics +BayesianQDM implements Bayesian quantitative decision-making (QDM) for +proof-of-concept (PoC) clinical trials (Kang, Yamaguchi and Han, 2026). +The data of a PoC study lead to one of three decisions: Go (proceed to +the next phase), NoGo (stop the development) or Gray (the evidence is +not sufficient for either). The criteria compare the posterior or +posterior predictive probability of the treatment effect with +thresholds, for a target value (TV) and a minimum acceptable value (MAV) +of the effect. + +The package answers four questions for a planned or completed study: + +- Which decision do the observed data lead to? (`qdm_decide()`) +- How often does the design lead to each decision when the true effect + is known? (`qdm_oc()`) +- Which thresholds keep the probabilities of a false Go and a false NoGo + decision below given targets? (`qdm_calibrate()`) +- Which observed data lead to each decision? (`qdm_boundary()`) + +A study is described by small specification objects (priors, data, +external data borrowed through a power prior, a hypothetical control and +a decision criterion), which are combined into a design. + +| Endpoints | Design | Model | Computation of the probabilities | +|----|----|----|----| +| One binary | `design_binary()` | Beta-binomial | Numerical integration (posterior), exact sum (predictive) | +| One continuous | `design_continuous()` | Normal-Inverse-chi-squared or vague | Numerical integration, moment matching or Monte Carlo | +| Two binary | `design_binary2()` | Dirichlet-multinomial | Monte Carlo (posterior), exact sum (predictive) | +| Two continuous | `design_continuous2()` | Normal-Inverse-Wishart or vague | Moment matching or Monte Carlo | +| One time-to-event | `design_tte()` | Exponential with Gamma prior (milestone survival) | Numerical integration (posterior), simulation (predictive) | + +The control group can be a concurrent control group, external control +data only, a hypothetical control, or a fixed value of the control +parameter (a single-arm study compared with a benchmark), and external +data can be borrowed for either group. ## Installation -### From CRAN - -```r +``` r +# From CRAN install.packages("BayesianQDM") -``` - -### Development Version -```r -# install.packages("devtools") -devtools::install_github("gosukehommaEX/BayesianQDM") +# Development version from GitHub +# install.packages("pak") +pak::pak("gosukehommaEX/BayesianQDM") ``` -## Core Functions - -### Posterior / Posterior Predictive Probability Functions - -| Function | Description | -|---|---| -| `pbayespostpred1bin()` | Posterior or predictive probability for a single binary endpoint | -| `pbayespostpred1cont()` | Posterior or predictive probability for a single continuous endpoint | -| `pbayespostpred2bin()` | Joint region probabilities for two binary endpoints | -| `pbayespostpred2cont()` | Joint region probabilities for two continuous endpoints | - -### Decision Probability Functions - -| Function | Description | -|---|---| -| `pbayesdecisionprob1bin()` | Go/NoGo/Gray probabilities for a single binary endpoint | -| `pbayesdecisionprob1cont()` | Go/NoGo/Gray probabilities for a single continuous endpoint | -| `pbayesdecisionprob2bin()` | Go/NoGo/Gray probabilities for two binary endpoints | -| `pbayesdecisionprob2cont()` | Go/NoGo/Gray probabilities for two continuous endpoints | - -### Optimal Threshold Search Functions - -| Function | Description | -|---|---| -| `getgamma1bin()` | Find optimal Go/NoGo thresholds for a single binary endpoint | -| `getgamma1cont()` | Find optimal Go/NoGo thresholds for a single continuous endpoint | -| `getgamma2bin()` | Find optimal Go/NoGo thresholds for two binary endpoints | -| `getgamma2cont()` | Find optimal Go/NoGo thresholds for two continuous endpoints | - -### S3 Methods - -| Function | Description | -|---|---| -| `print.pbayesdecisionprob1bin()` | Print method for `pbayesdecisionprob1bin` objects | -| `print.pbayesdecisionprob1cont()` | Print method for `pbayesdecisionprob1cont` objects | -| `print.pbayesdecisionprob2bin()` | Print method for `pbayesdecisionprob2bin` objects | -| `print.pbayesdecisionprob2cont()` | Print method for `pbayesdecisionprob2cont` objects | -| `plot.pbayesdecisionprob1bin()` | Plot method for `pbayesdecisionprob1bin` objects | -| `plot.pbayesdecisionprob1cont()` | Plot method for `pbayesdecisionprob1cont` objects | -| `plot.pbayesdecisionprob2bin()` | Plot method for `pbayesdecisionprob2bin` objects | -| `plot.pbayesdecisionprob2cont()` | Plot method for `pbayesdecisionprob2cont` objects | -| `plot.getgamma1bin()` | Plot method for `getgamma1bin` objects | -| `plot.getgamma1cont()` | Plot method for `getgamma1cont` objects | -| `plot.getgamma2bin()` | Plot method for `getgamma2bin` objects | -| `plot.getgamma2cont()` | Plot method for `getgamma2cont` objects | - -### Distribution and Utility Functions - -| Function | Description | -|---|---| -| `pbetadiff()` | CDF for the difference of two independent Beta distributions | -| `pbetabinomdiff()` | Beta-binomial posterior predictive probability | -| `ptdiff_NI()` | CDF for the difference of two t-distributions via numerical integration | -| `ptdiff_MC()` | CDF for the difference of two t-distributions via Monte Carlo simulation | -| `ptdiff_MM()` | CDF for the difference of two t-distributions via Moment-Matching approximation | -| `rdirichlet()` | Random sampler for the Dirichlet distribution | -| `getjointbin()` | Joint binary probability from marginals and correlation | -| `allmultinom()` | Enumerate all multinomial outcome combinations | - -## Study Designs +## Example -### Controlled Design -Standard randomised controlled trials with concurrent treatment and control groups. +A PoC study with one binary endpoint and 12 subjects in each group, +Jeffreys priors, and a posterior criterion with TV = 0.2 and MAV = 0.1: -### Uncontrolled Design -Single-arm studies using a hypothetical control distribution specified through prior parameters or a variance scaling factor. - -### External Design -Incorporates historical or external control and/or treatment data through power priors using exact conjugate representations, enabling efficient Bayesian computation without MCMC sampling. - -## Statistical Methods for Continuous Endpoints - -For single continuous endpoints, three methods are available for computing the CDF of the difference between two independent t-distributions: +``` r +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +``` -- **NI** (Numerical Integration): Exact computation via adaptive quadrature (`stats::integrate`) -- **MC** (Monte Carlo): Simulation-based estimation; supports vectorised batch processing -- **MM** (Moment-Matching): Closed-form approximation by matching the first two even moments of the difference distribution to a single t-distribution; fully vectorised and recommended for large-scale simulation studies +Decision for 9 responders in the treatment group and 4 in the control +group: + +``` r +qdm_decide(des, data_t = data_binary(12, 9), data_c = data_binary(12, 4)) +#> Decision: Go +#> Go: P(theta > 0.2 | data) = 0.8517 (threshold 0.5, met) +#> NoGo: P(theta <= 0.1 | data) = 0.05935 (threshold 0.8, not met) +#> Posterior distributions +#> Treatment: Beta(a = 9.5, b = 3.5) +#> Control: Beta(a = 4.5, b = 8.5) +``` -For two continuous endpoints, MC and MM methods are available for computing joint rectangular region probabilities under a bivariate t-distribution approximation. +Operating characteristics for true response rates of the treatment group +from 0.3 to 0.7 with a control rate of 0.3: + +``` r +qdm_oc(des, data.frame(pi_t = seq(0.3, 0.7, by = 0.1), pi_c = 0.3)) +#> Operating characteristics (exact enumeration of the outcomes) +#> pi_t pi_c Go NoGo Gray Miss +#> 0.3 0.3 0.1316 0.41696 0.4514 0 +#> 0.4 0.3 0.2893 0.23249 0.4782 0 +#> 0.5 0.3 0.4883 0.10937 0.4023 0 +#> 0.6 0.3 0.6875 0.04137 0.2711 0 +#> 0.7 0.3 0.8472 0.01150 0.1413 0 +``` -## Optimal Threshold Search +Thresholds for which the probability of meeting the Go criterion is at +most 0.05 when the treatment has no effect, and that of meeting the NoGo +criterion is at most 0.2 when the effect is 0.3: + +``` r +qdm_calibrate(des, + scenario_go = data.frame(pi_t = 0.3, pi_c = 0.3), + scenario_nogo = data.frame(pi_t = 0.6, pi_c = 0.3), + target_go = 0.05, target_nogo = 0.2) +#> Calibration of the decision thresholds (exact enumeration of the outcomes) +#> gamma_go = 0.74: P(Go criterion met | scenario_go) = 0.03587 (target 0.05) +#> gamma_nogo = 0.39: P(NoGo criterion met | scenario_nogo) = 0.182 (target 0.2) +#> Decision probabilities with the chosen thresholds +#> scenario pi_t pi_c Go NoGo Gray Miss +#> scenario_go 0.3 0.3 0.03587 0.7486 0.2155 0 +#> scenario_nogo 0.6 0.3 0.36483 0.1820 0.4531 0 +``` -The `getgamma` family of functions finds optimal Go threshold $\gamma_go$ and NoGo threshold $\gamma_nogo$ by grid search, given user-specified target operating characteristics (e.g., Pr(Go) and Pr(NoGo) under specified true parameter scenarios). The search follows a two-stage precompute-then-sweep strategy for computational efficiency. +`plot()` draws the operating characteristics, the calibration curves and +the decision boundaries computed by `qdm_boundary()`. The plots are +ggplot2 objects: their arguments set the colors of the decisions, the +line widths, the text sizes and the position of the legend, and ggplot2 +functions can be added to change them further. ## Documentation -### Vignettes - -The package includes detailed vignettes with practical examples: - -**Getting Started** -- [Overview of BayesianQDM](https://gosukehommaEX.github.io/BayesianQDM/articles/overview.html) - Framework overview and key concepts +The vignettes describe the models and the functions with examples: + +- [Overview of + BayesianQDM](https://gosukehommaEX.github.io/BayesianQDM/articles/overview.html) +- [Single binary + endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-binary.html) +- [Single continuous + endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-continuous.html) +- [Two binary + endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-binary.html) +- [Two continuous + endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-continuous.html) +- [Time-to-event + endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/time-to-event.html) +- [Migrating from version + 0.1.0](https://gosukehommaEX.github.io/BayesianQDM/articles/migration.html) + +After installation, `vignette(package = "BayesianQDM")` lists them. The +[package website](https://gosukehommaEX.github.io/BayesianQDM/) also has +the function reference. + +Version 1.0.0 is a redesign of version 0.1.0 and is not backward +compatible. The +[NEWS](https://gosukehommaEX.github.io/BayesianQDM/news/index.html) file +lists the changes, including corrections of formulas and numerical +methods. + +The scripts in `inst/validation/` compare the package with published and +submitted results; `inst/validation/results/summary.md` reports the +comparisons. -**Single Endpoint Analysis** -- [Single Binary Endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-binary.html) - Binary endpoint analysis with Go/NoGo/Gray decisions -- [Single Continuous Endpoint](https://gosukehommaEX.github.io/BayesianQDM/articles/single-continuous.html) - Continuous endpoint analysis with multiple computation methods - -**Two Endpoint Analysis** -- [Two Binary Endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-binary.html) - Joint analysis of two binary endpoints -- [Two Continuous Endpoints](https://gosukehommaEX.github.io/BayesianQDM/articles/two-continuous.html) - Joint analysis of two continuous endpoints - -Access vignettes locally after installation: - -```r -vignette(package = "BayesianQDM") -vignette("overview", package = "BayesianQDM") -vignette("single-binary", package = "BayesianQDM") -vignette("single-continuous", package = "BayesianQDM") -vignette("two-binary", package = "BayesianQDM") -vignette("two-continuous", package = "BayesianQDM") -``` - -### Package Website +## Citation -Visit the [pkgdown website](https://gosukehommaEX.github.io/BayesianQDM/) for interactive documentation and the full function reference. +For the framework, please cite -## Citation +> Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +> decision-making framework in cell and gene therapy development for +> rare diseases. *Journal of Biopharmaceutical Statistics*. +> -To cite BayesianQDM in publications, please use: +and for the package -``` -Homma, G., Yamaguchi, Y. (2025). BayesianQDM: Bayesian Quantitative -Decision-Making Framework for Binary and Continuous Endpoints. -R package version 0.1.0. -``` +> Homma, G. and Yamaguchi, Y. (2026). BayesianQDM: Bayesian Quantitative +> Decision-Making Framework for Binary, Continuous and Time-to-Event +> Endpoints. R package version 1.0.0. ## License -This package is licensed under GPL (>= 2). +GPL (\>= 2) ## Authors - Gosuke Homma (maintainer) - Yusuke Yamaguchi -## Issues and Contributions +## Issues -To report bugs or request features, please visit our [GitHub repository](https://github.com/gosukehommaEX/BayesianQDM/issues). +Please report bugs and requests on the [GitHub issue +tracker](https://github.com/gosukehommaEX/BayesianQDM/issues). diff --git a/_pkgdown.yml b/_pkgdown.yml index 50d689a..913f61d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -18,96 +18,96 @@ template: home: title: BayesianQDM description: > - Bayesian Quantitative Decision-Making Framework for Binary and Continuous Endpoints. + Bayesian Quantitative Decision-Making Framework for Binary, Continuous and Time-to-Event Endpoints. logo: man/figures/logo.png reference: -- title: Decision Probability Functions - desc: Go/NoGo/Gray decision probability calculation +- title: Designs + desc: Specification of a proof-of-concept study contents: - - pbayesdecisionprob1bin - - pbayesdecisionprob1cont - - pbayesdecisionprob2bin - - pbayesdecisionprob2cont + - design_binary + - design_continuous + - design_binary2 + - design_continuous2 + - design_tte + - conduct_tte -- title: Print Methods - desc: S3 print methods for decision probability objects +- title: Operations + desc: Decision for observed data, operating characteristics, calibration of the thresholds and decision boundaries contents: - - print.pbayesdecisionprob1bin - - print.pbayesdecisionprob1cont - - print.pbayesdecisionprob2bin - - print.pbayesdecisionprob2cont + - qdm_decide + - qdm_oc + - qdm_calibrate + - qdm_boundary -- title: Plot Methods - desc: S3 plot methods for decision probability and threshold search objects +- title: Priors + desc: Prior distributions of each group contents: - - plot.pbayesdecisionprob1bin - - plot.pbayesdecisionprob1cont - - plot.pbayesdecisionprob2bin - - plot.pbayesdecisionprob2cont - - plot.getgamma1bin - - plot.getgamma1cont - - plot.getgamma2bin - - plot.getgamma2cont + - prior_beta + - prior_nix + - prior_dirichlet + - prior_niw + - prior_gamma + - prior_vague -- title: Posterior and Predictive Probability Functions - desc: Posterior and posterior predictive probability calculation +- title: Data, external data and hypothetical controls + desc: Summaries of the data of one group, external data borrowed through a power prior, and hypothetical controls contents: - - pbayespostpred1bin - - pbayespostpred1cont - - pbayespostpred2bin - - pbayespostpred2cont + - data_binary + - data_continuous + - data_binary2 + - data_continuous2 + - data_tte + - borrow + - hypothetical -- title: Optimal Threshold Search Functions - desc: Grid-search functions for optimal Go/NoGo thresholds +- title: Decision criteria + desc: Criteria based on posterior and posterior predictive probabilities contents: - - getgamma1bin - - getgamma1cont - - getgamma2bin - - getgamma2cont + - criterion_posterior + - criterion_predictive + - qdm_regions -- title: Distribution Functions for Continuous Endpoints - desc: CDF for the difference of two t-distributions - contents: - - ptdiff_NI - - ptdiff_MC - - ptdiff_MM - -- title: Distribution Functions for Binary Endpoints - desc: CDF and related functions for Beta and Beta-binomial distributions +- title: Distribution functions + desc: Distribution functions and random generation used by the decision criteria contents: - pbetadiff - pbetabinomdiff - -- title: Sampling Functions - desc: Random samplers for multivariate distributions - contents: + - ptdiff + - psurvdiff + - cellprob_binary2 - rdirichlet -- title: Utility Functions - desc: Supporting functions for joint probability and multinomial enumeration +- title: Print, format and plot methods contents: - - getjointbin - - allmultinom + - starts_with("print.") + - starts_with("format.") + - starts_with("plot.") articles: -- title: Getting Started +- title: Getting started navbar: ~ contents: - overview -- title: Single Endpoint Analysis - navbar: Guides +- title: One endpoint + navbar: One endpoint contents: - single-binary - single-continuous + - time-to-event -- title: Two Endpoint Analysis - navbar: Guides +- title: Two endpoints + navbar: Two endpoints contents: - two-binary - two-continuous +- title: Version 0.1.0 + navbar: Version 0.1.0 + contents: + - migration + navbar: structure: left: [intro, reference, articles, news] @@ -119,12 +119,17 @@ navbar: - text: Overview of BayesianQDM href: articles/overview.html - text: ------- - - text: Single Binary Endpoint + - text: Single binary endpoint href: articles/single-binary.html - - text: Single Continuous Endpoint + - text: Single continuous endpoint href: articles/single-continuous.html + - text: Time-to-event endpoint + href: articles/time-to-event.html - text: ------- - - text: Two Binary Endpoints + - text: Two binary endpoints href: articles/two-binary.html - - text: Two Continuous Endpoints + - text: Two continuous endpoints href: articles/two-continuous.html + - text: ------- + - text: Migrating from version 0.1.0 + href: articles/migration.html diff --git a/cran-comments.md b/cran-comments.md index 8696f02..65f5bcc 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,54 +1,33 @@ -# CRAN Submission Comments +## Submission -## Test Environments +This is a major update of BayesianQDM from version 0.1.0 to 1.0.0. The +interface has been redesigned and is not backward compatible: a study is +specified by small objects combined into a design, and three functions +compute the decision for observed data, the operating characteristics and +calibrated decision thresholds for any design. Formulas and numerical methods +that were wrong in version 0.1.0 have been corrected. NEWS.md lists the +changes and the correspondence between the old and new functions, and a new +vignette explains the migration. Version 1.0.0 also adds a time-to-event +endpoint, single-arm designs compared with a fixed control value, and +decision boundaries over possible observed data. -* local R installation, R 4.5.1 -* ubuntu-latest (on GitHub Actions), R-release -* windows-latest (on GitHub Actions), R-release -* macOS-latest (on GitHub Actions), R-release -* ubuntu-latest (on GitHub Actions), R-devel +## Test environments -## R CMD check results - -0 errors | 0 warnings | 1 note +* Local: Windows 11, R 4.6.0 +* GitHub Actions: ubuntu-latest (R-devel, R-release and R-oldrel-1), + windows-latest (R-release) and macos-latest (R-release) -* checking for future file timestamps ... NOTE - unable to verify current time - This is a transient network issue in the check environment and is not - related to the package itself. - -## Package Summary +## R CMD check results -BayesianQDM provides a comprehensive Bayesian quantitative decision-making framework -for clinical trials, supporting both single and two-endpoint analyses for binary and -continuous outcomes. The package implements Go/NoGo/Gray decision criteria using -posterior probabilities and posterior predictive probabilities under conjugate Bayesian -models, with support for controlled, uncontrolled, and external designs. -The package also provides grid-search functions to find optimal Go and NoGo thresholds -that satisfy user-specified operating characteristic criteria for all supported -endpoint types and study designs. S3 print() and plot() methods are provided for all -four decision probability classes, enabling formatted display and visualisation of -operating characteristics across treatment scenarios. +0 errors | 0 warnings | 0 notes -## Dependencies +## Reverse dependencies -* Imports: ggplot2 (>= 3.4.0), gridExtra, mvtnorm, stats -* Suggests: testthat (>= 3.0.0), knitr, rmarkdown, dplyr, tidyr, purrr -* All dependencies are well-established CRAN packages +There are no reverse dependencies on CRAN. ## Notes -* No MCMC sampling is used; all computations rely on exact conjugate posterior - representations or closed-form approximations, keeping run times short -* Monte Carlo functions have an adjustable iteration count (`nMC`) to balance - speed and precision; default values are set conservatively for CRAN checks -* All examples in the documentation are designed to complete within a few seconds - -## Resubmission - -This is a resubmission following reviewer feedback. The following changes were made: - -* Expanded the MCMC acronym to "Markov chain Monte Carlo (MCMC)" in DESCRIPTION. -* Added a reference to Kang, Yamaguchi, and Han (2026) in DESCRIPTION. -* Replaced `\dontrun{}` with `\donttest{}` in examples for `getgamma2bin()` and - `getgamma2cont()`. +* The heavy computations (numerical integration and Monte Carlo loops) are + written in C++ with Rcpp. +* The examples, tests and vignettes use small numbers of simulated studies + and Monte Carlo draws; the tests take less than a minute in R CMD check. diff --git a/inst/WORDLIST b/inst/WORDLIST index 3ef9d08..27fca05 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -1,18 +1,27 @@ ACR Appell's +Bartlett Binom +Biopharmaceutical +Bivariate CMD ChiSq +Cholesky Codecov DAS GoRegions HAQ +Homma +Hu +Huang IIa Inv Jeffreys +Kang Kronrod Lifecycle MAV +Maruo Mult NIW NoGo @@ -22,33 +31,48 @@ PoC Precomputation Precompute QDM +QUADPACK RCT +Rcpp +Resubmission +Takeda +Wishart +Yamaguchi +al aug bigl bigr binom +bivariate boldsymbol cdot +cj colour coloured conjugacy deduplicated deduplicates dfrac +doi dt du dx ec ej et +evaluable +exp frac gGo gNoGo ge generalisation getgamma +ggplot +hyperparameters ij infty +integrand investigational ldots le @@ -60,6 +84,8 @@ mathrm minimise modelled modelling +multinomial +nMC nc nj nogo @@ -70,11 +96,13 @@ overset parameterised pbayesdecisionprob pbayespostpred +piecewise pkgdown pmatrix pre precomputation precompute +propto qquad quadratically randomised @@ -83,9 +111,12 @@ reparameterisation responder responders sd +sqrt standardised +textrm texttt th +tj visualisation visualised widehat diff --git a/inst/validation/bivariate_binary2_tables.csv b/inst/validation/bivariate_binary2_tables.csv new file mode 100644 index 0000000..047e058 --- /dev/null +++ b/inst/validation/bivariate_binary2_tables.csv @@ -0,0 +1,145 @@ +table,panel,rho,gamma_go,gamma_nogo,theta1,theta2,Go,Gray,NoGo +3,a,0.0,0.263,0.347,0.0,0.0,0.0495,0.318,0.6325 +3,a,0.0,0.263,0.347,0.1,0.0,0.117,0.4324,0.4506 +3,a,0.0,0.263,0.347,0.15,0.0,0.1522,0.4899,0.3579 +3,a,0.0,0.263,0.347,0.25,0.0,0.2263,0.5674,0.2063 +3,a,0.0,0.263,0.347,0.0,0.1,0.1031,0.4369,0.46 +3,a,0.0,0.263,0.347,0.1,0.1,0.2261,0.4559,0.318 +3,a,0.0,0.263,0.347,0.15,0.1,0.2881,0.4609,0.251 +3,a,0.0,0.263,0.347,0.25,0.1,0.3985,0.4586,0.1429 +3,a,0.0,0.263,0.347,0.0,0.15,0.1314,0.4968,0.3718 +3,a,0.0,0.263,0.347,0.1,0.15,0.2819,0.4608,0.2573 +3,a,0.0,0.263,0.347,0.15,0.15,0.3537,0.4464,0.1999 +3,a,0.0,0.263,0.347,0.25,0.15,0.4822,0.4048,0.113 +3,a,0.0,0.263,0.347,0.0,0.25,0.1865,0.5907,0.2228 +3,a,0.0,0.263,0.347,0.1,0.25,0.3806,0.4691,0.1503 +3,a,0.0,0.263,0.347,0.15,0.25,0.4739,0.4079,0.1182 +3,a,0.0,0.263,0.347,0.25,0.25,0.6241,0.312,0.0639 +3,b,0.3,0.38,0.454,0.0,0.0,0.0497,0.3505,0.5998 +3,b,0.3,0.38,0.454,0.1,0.0,0.0968,0.4759,0.4273 +3,b,0.3,0.38,0.454,0.15,0.0,0.1206,0.5318,0.3476 +3,b,0.3,0.38,0.454,0.25,0.0,0.1604,0.6335,0.2061 +3,b,0.3,0.38,0.454,0.0,0.1,0.0859,0.481,0.4331 +3,b,0.3,0.38,0.454,0.1,0.1,0.1808,0.517,0.3022 +3,b,0.3,0.38,0.454,0.15,0.1,0.2267,0.5292,0.2441 +3,b,0.3,0.38,0.454,0.25,0.1,0.3068,0.5458,0.1474 +3,b,0.3,0.38,0.454,0.0,0.15,0.1033,0.536,0.3607 +3,b,0.3,0.38,0.454,0.1,0.15,0.2226,0.5285,0.2489 +3,b,0.3,0.38,0.454,0.15,0.15,0.2806,0.5199,0.1995 +3,b,0.3,0.38,0.454,0.25,0.15,0.3814,0.5001,0.1185 +3,b,0.3,0.38,0.454,0.0,0.25,0.1337,0.6484,0.2179 +3,b,0.3,0.38,0.454,0.1,0.25,0.2938,0.5543,0.1519 +3,b,0.3,0.38,0.454,0.15,0.25,0.3743,0.5035,0.1222 +3,b,0.3,0.38,0.454,0.25,0.25,0.514,0.4144,0.0716 +3,c,0.6,0.513,0.511,0.0,0.0,0.0496,0.39,0.5604 +3,c,0.6,0.513,0.511,0.1,0.0,0.0978,0.4969,0.4053 +3,c,0.6,0.513,0.511,0.15,0.0,0.1207,0.5553,0.324 +3,c,0.6,0.513,0.511,0.25,0.0,0.1637,0.6433,0.193 +3,c,0.6,0.513,0.511,0.0,0.1,0.0877,0.5159,0.3964 +3,c,0.6,0.513,0.511,0.1,0.1,0.1708,0.5367,0.2925 +3,c,0.6,0.513,0.511,0.15,0.1,0.2177,0.539,0.2433 +3,c,0.6,0.513,0.511,0.25,0.1,0.2932,0.5605,0.1463 +3,c,0.6,0.513,0.511,0.0,0.15,,, +3,c,0.6,0.513,0.511,0.1,0.15,0.2102,0.546,0.2438 +3,c,0.6,0.513,0.511,0.15,0.15,0.2647,0.5361,0.1992 +3,c,0.6,0.513,0.511,0.25,0.15,0.3568,0.5203,0.1229 +3,c,0.6,0.513,0.511,0.0,0.25,,, +3,c,0.6,0.513,0.511,0.1,0.25,0.2824,0.5735,0.1441 +3,c,0.6,0.513,0.511,0.15,0.25,0.3485,0.528,0.1235 +3,c,0.6,0.513,0.511,0.25,0.25,0.4765,0.4421,0.0814 +S1,a,0.0,0.453,0.229,0.0,0.0,0.0481,0.3169,0.635 +S1,a,0.0,0.453,0.229,0.1,0.0,0.1057,0.4406,0.4537 +S1,a,0.0,0.453,0.229,0.15,0.0,0.1394,0.494,0.3666 +S1,a,0.0,0.453,0.229,0.25,0.0,0.207,0.5761,0.2169 +S1,a,0.0,0.453,0.229,0.0,0.15,0.1408,0.4816,0.3776 +S1,a,0.0,0.453,0.229,0.1,0.15,0.2718,0.474,0.2542 +S1,a,0.0,0.453,0.229,0.15,0.15,0.3326,0.4694,0.198 +S1,a,0.0,0.453,0.229,0.25,0.15,0.4638,0.4243,0.1119 +S1,a,0.0,0.453,0.229,0.0,0.25,0.2071,0.559,0.2339 +S1,a,0.0,0.453,0.229,0.1,0.25,0.3716,0.478,0.1504 +S1,a,0.0,0.453,0.229,0.15,0.25,0.4552,0.4273,0.1175 +S1,a,0.0,0.453,0.229,0.25,0.25,0.602,0.3344,0.0636 +S1,a,0.0,0.453,0.229,0.0,0.35,0.2552,0.6207,0.1241 +S1,a,0.0,0.453,0.229,0.1,0.35,0.4505,0.4708,0.0787 +S1,a,0.0,0.453,0.229,0.15,0.35,0.5482,0.3938,0.058 +S1,a,0.0,0.453,0.229,0.25,0.35,0.7054,0.2645,0.0301 +S1,b,0.3,0.537,0.282,0.0,0.0,0.0499,0.3662,0.5839 +S1,b,0.3,0.537,0.282,0.1,0.0,0.0971,0.4931,0.4098 +S1,b,0.3,0.537,0.282,0.15,0.0,0.1224,0.5484,0.3292 +S1,b,0.3,0.537,0.282,0.25,0.0,0.1667,0.6375,0.1958 +S1,b,0.3,0.537,0.282,0.0,0.15,0.1202,0.5241,0.3557 +S1,b,0.3,0.537,0.282,0.1,0.15,0.2279,0.5242,0.2479 +S1,b,0.3,0.537,0.282,0.15,0.15,0.2904,0.5097,0.1999 +S1,b,0.3,0.537,0.282,0.25,0.15,0.3938,0.489,0.1172 +S1,b,0.3,0.537,0.282,0.0,0.25,0.1619,0.6148,0.2233 +S1,b,0.3,0.537,0.282,0.1,0.25,0.3076,0.5373,0.1551 +S1,b,0.3,0.537,0.282,0.15,0.25,0.3864,0.4882,0.1254 +S1,b,0.3,0.537,0.282,0.25,0.25,0.5228,0.4039,0.0733 +S1,b,0.3,0.537,0.282,0.0,0.35,0.1902,0.6836,0.1262 +S1,b,0.3,0.537,0.282,0.1,0.35,0.3693,0.5469,0.0838 +S1,b,0.3,0.537,0.282,0.15,0.35,0.4555,0.4757,0.0688 +S1,b,0.3,0.537,0.282,0.25,0.35,0.6175,0.3421,0.0404 +S1,c,0.6,0.62,0.337,0.0,0.0,0.0476,0.4325,0.5199 +S1,c,0.6,0.62,0.337,0.1,0.0,0.0892,0.5335,0.3773 +S1,c,0.6,0.62,0.337,0.15,0.0,,, +S1,c,0.6,0.62,0.337,0.25,0.0,,, +S1,c,0.6,0.62,0.337,0.0,0.15,0.1143,0.5586,0.3271 +S1,c,0.6,0.62,0.337,0.1,0.15,0.2086,0.548,0.2434 +S1,c,0.6,0.62,0.337,0.15,0.15,0.2533,0.5471,0.1996 +S1,c,0.6,0.62,0.337,0.25,0.15,0.3449,0.5307,0.1244 +S1,c,0.6,0.62,0.337,0.0,0.25,0.1489,0.6251,0.226 +S1,c,0.6,0.62,0.337,0.1,0.25,0.2771,0.5626,0.1603 +S1,c,0.6,0.62,0.337,0.15,0.25,0.3421,0.5301,0.1278 +S1,c,0.6,0.62,0.337,0.25,0.25,0.4637,0.4519,0.0844 +S1,c,0.6,0.62,0.337,0.0,0.35,,, +S1,c,0.6,0.62,0.337,0.1,0.35,0.3236,0.5877,0.0887 +S1,c,0.6,0.62,0.337,0.15,0.35,0.4079,0.5136,0.0785 +S1,c,0.6,0.62,0.337,0.25,0.35,0.5549,0.3943,0.0508 +S2,a,0.0,0.308,0.44,0.0,0.0,0.0483,0.3531,0.5986 +S2,a,0.0,0.308,0.44,0.1,0.0,0.091,0.481,0.428 +S2,a,0.0,0.308,0.44,0.15,0.0,0.1184,0.5195,0.3621 +S2,a,0.0,0.308,0.44,0.25,0.0,0.167,0.6054,0.2276 +S2,a,0.0,0.308,0.44,0.0,0.15,0.1321,0.5132,0.3547 +S2,a,0.0,0.308,0.44,0.1,0.15,0.2359,0.5203,0.2438 +S2,a,0.0,0.308,0.44,0.15,0.15,0.2943,0.5078,0.1979 +S2,a,0.0,0.308,0.44,0.25,0.15,0.3983,0.483,0.1187 +S2,a,0.0,0.308,0.44,0.0,0.25,0.195,0.5841,0.2209 +S2,a,0.0,0.308,0.44,0.1,0.25,0.3364,0.5157,0.1479 +S2,a,0.0,0.308,0.44,0.15,0.25,0.4102,0.4724,0.1174 +S2,a,0.0,0.308,0.44,0.25,0.25,0.5366,0.395,0.0684 +S2,a,0.0,0.308,0.44,0.0,0.35,0.2536,0.623,0.1234 +S2,a,0.0,0.308,0.44,0.1,0.35,0.4174,0.5025,0.0801 +S2,a,0.0,0.308,0.44,0.15,0.35,0.5008,0.4361,0.0631 +S2,a,0.0,0.308,0.44,0.25,0.35,0.643,0.3217,0.0353 +S2,b,0.3,0.398,0.51,0.0,0.0,0.0496,0.4199,0.5305 +S2,b,0.3,0.398,0.51,0.1,0.0,0.0858,0.5477,0.3665 +S2,b,0.3,0.398,0.51,0.15,0.0,0.1052,0.5987,0.2961 +S2,b,0.3,0.398,0.51,0.25,0.0,0.1401,0.6837,0.1762 +S2,b,0.3,0.398,0.51,0.0,0.15,0.1234,0.5209,0.3557 +S2,b,0.3,0.398,0.51,0.1,0.15,0.2226,0.5295,0.2479 +S2,b,0.3,0.398,0.51,0.15,0.15,0.2665,0.5336,0.1999 +S2,b,0.3,0.398,0.51,0.25,0.15,0.3519,0.5295,0.1186 +S2,b,0.3,0.398,0.51,0.0,0.25,0.1729,0.5858,0.2413 +S2,b,0.3,0.398,0.51,0.1,0.25,0.3002,0.5315,0.1683 +S2,b,0.3,0.398,0.51,0.15,0.25,0.3638,0.5002,0.136 +S2,b,0.3,0.398,0.51,0.25,0.25,0.4779,0.4398,0.0823 +S2,b,0.3,0.398,0.51,0.0,0.35,0.2101,0.6477,0.1422 +S2,b,0.3,0.398,0.51,0.1,0.35,0.3736,0.5249,0.1015 +S2,b,0.3,0.398,0.51,0.15,0.35,0.448,0.4691,0.0829 +S2,b,0.3,0.398,0.51,0.25,0.35,0.583,0.366,0.051 +S2,c,0.6,0.581,0.607,0.0,0.0,0.0418,0.4536,0.5046 +S2,c,0.6,0.581,0.607,0.1,0.0,0.0785,0.5549,0.3666 +S2,c,0.6,0.581,0.607,0.15,0.0,,, +S2,c,0.6,0.581,0.607,0.25,0.0,,, +S2,c,0.6,0.581,0.607,0.0,0.15,0.1021,0.5951,0.3028 +S2,c,0.6,0.581,0.607,0.1,0.15,0.1765,0.5894,0.2341 +S2,c,0.6,0.581,0.607,0.15,0.15,0.212,0.5883,0.1997 +S2,c,0.6,0.581,0.607,0.25,0.15,0.283,0.591,0.126 +S2,c,0.6,0.581,0.607,0.0,0.25,0.1362,0.68,0.1838 +S2,c,0.6,0.581,0.607,0.1,0.25,0.246,0.6028,0.1512 +S2,c,0.6,0.581,0.607,0.15,0.25,0.2937,0.5762,0.1301 +S2,c,0.6,0.581,0.607,0.25,0.25,0.3914,0.5176,0.091 +S2,c,0.6,0.581,0.607,0.0,0.35,,, +S2,c,0.6,0.581,0.607,0.1,0.35,0.2899,0.6275,0.0826 +S2,c,0.6,0.581,0.607,0.15,0.35,0.3591,0.5675,0.0734 +S2,c,0.6,0.581,0.607,0.25,0.35,0.4812,0.4655,0.0533 diff --git a/inst/validation/bivariate_continuous2_tables.csv b/inst/validation/bivariate_continuous2_tables.csv new file mode 100644 index 0000000..ca11ec6 --- /dev/null +++ b/inst/validation/bivariate_continuous2_tables.csv @@ -0,0 +1,97 @@ +table,panel,rho,gamma_go,gamma_nogo,theta1,theta2,Go,Gray,NoGo +4,a,0.0,0.296,0.244,0.0,0.0,0.0499,0.3163,0.6338 +4,a,0.0,0.296,0.244,5.0,0.0,0.0654,0.3745,0.5601 +4,a,0.0,0.296,0.244,10.0,0.0,0.0802,0.4274,0.4924 +4,a,0.0,0.296,0.244,15.0,0.0,0.1023,0.4884,0.4093 +4,a,0.0,0.296,0.244,0.0,1.0,0.1185,0.4124,0.4691 +4,a,0.0,0.296,0.244,5.0,1.0,0.1526,0.4394,0.408 +4,a,0.0,0.296,0.244,10.0,1.0,0.1875,0.4652,0.3473 +4,a,0.0,0.296,0.244,15.0,1.0,0.2343,0.4862,0.2795 +4,a,0.0,0.296,0.244,0.0,2.0,0.2302,0.4941,0.2757 +4,a,0.0,0.296,0.244,5.0,2.0,0.2896,0.4779,0.2325 +4,a,0.0,0.296,0.244,10.0,2.0,0.3433,0.4572,0.1995 +4,a,0.0,0.296,0.244,15.0,2.0,0.3991,0.4401,0.1608 +4,a,0.0,0.296,0.244,0.0,3.0,0.3424,0.5289,0.1287 +4,a,0.0,0.296,0.244,5.0,3.0,0.4193,0.4733,0.1074 +4,a,0.0,0.296,0.244,10.0,3.0,0.5022,0.409,0.0888 +4,a,0.0,0.296,0.244,15.0,3.0,0.568,0.3605,0.0715 +4,b,0.4,0.428,0.357,0.0,0.0,0.0495,0.3793,0.5712 +4,b,0.4,0.428,0.357,5.0,0.0,0.0647,0.4376,0.4977 +4,b,0.4,0.428,0.357,10.0,0.0,0.0773,0.4994,0.4233 +4,b,0.4,0.428,0.357,15.0,0.0,0.0867,0.5525,0.3608 +4,b,0.4,0.428,0.357,0.0,1.0,0.1224,0.4475,0.4301 +4,b,0.4,0.428,0.357,5.0,1.0,0.1532,0.4674,0.3794 +4,b,0.4,0.428,0.357,10.0,1.0,0.1784,0.5059,0.3157 +4,b,0.4,0.428,0.357,15.0,1.0,0.2023,0.5289,0.2688 +4,b,0.4,0.428,0.357,0.0,2.0,0.2075,0.5369,0.2556 +4,b,0.4,0.428,0.357,5.0,2.0,0.2507,0.5186,0.2307 +4,b,0.4,0.428,0.357,10.0,2.0,0.3074,0.4932,0.1994 +4,b,0.4,0.428,0.357,15.0,2.0,0.3586,0.4753,0.1661 +4,b,0.4,0.428,0.357,0.0,3.0,0.2905,0.5909,0.1186 +4,b,0.4,0.428,0.357,5.0,3.0,0.3596,0.5319,0.1085 +4,b,0.4,0.428,0.357,10.0,3.0,0.4273,0.4794,0.0933 +4,b,0.4,0.428,0.357,15.0,3.0,0.501,0.4226,0.0764 +4,c,0.8,0.6,0.485,0.0,0.0,0.0496,0.4172,0.5332 +4,c,0.8,0.6,0.485,5.0,0.0,0.0547,0.4788,0.4665 +4,c,0.8,0.6,0.485,10.0,0.0,0.055,0.564,0.381 +4,c,0.8,0.6,0.485,15.0,0.0,0.058,0.6291,0.3129 +4,c,0.8,0.6,0.485,0.0,1.0,0.1088,0.4731,0.4181 +4,c,0.8,0.6,0.485,5.0,1.0,0.1335,0.5031,0.3634 +4,c,0.8,0.6,0.485,10.0,1.0,0.1501,0.5319,0.318 +4,c,0.8,0.6,0.485,15.0,1.0,0.1614,0.5776,0.261 +4,c,0.8,0.6,0.485,0.0,2.0,0.1789,0.583,0.2381 +4,c,0.8,0.6,0.485,5.0,2.0,0.2236,0.5515,0.2249 +4,c,0.8,0.6,0.485,10.0,2.0,0.2699,0.5308,0.1993 +4,c,0.8,0.6,0.485,15.0,2.0,0.2983,0.5267,0.175 +4,c,0.8,0.6,0.485,0.0,3.0,0.2217,0.6809,0.0974 +4,c,0.8,0.6,0.485,5.0,3.0,0.2818,0.6234,0.0948 +4,c,0.8,0.6,0.485,10.0,3.0,0.3532,0.5565,0.0903 +4,c,0.8,0.6,0.485,15.0,3.0,0.4159,0.4984,0.0857 +S3,a,0.0,0.239,0.559,0.0,0.0,0.0498,0.3075,0.6427 +S3,a,0.0,0.239,0.559,1.5,0.0,0.112,0.453,0.435 +S3,a,0.0,0.239,0.559,3.0,0.0,0.1848,0.6021,0.2131 +S3,a,0.0,0.239,0.559,4.5,0.0,0.2363,0.6923,0.0714 +S3,a,0.0,0.239,0.559,0.0,1.0,0.1236,0.4698,0.4066 +S3,a,0.0,0.239,0.559,1.5,1.0,0.2704,0.4559,0.2737 +S3,a,0.0,0.239,0.559,3.0,1.0,0.4168,0.447,0.1362 +S3,a,0.0,0.239,0.559,4.5,1.0,0.5171,0.4411,0.0418 +S3,a,0.0,0.239,0.559,0.0,2.0,0.202,0.6187,0.1793 +S3,a,0.0,0.239,0.559,1.5,2.0,0.4201,0.4663,0.1136 +S3,a,0.0,0.239,0.559,3.0,2.0,0.6486,0.2949,0.0565 +S3,a,0.0,0.239,0.559,4.5,2.0,0.7805,0.2039,0.0156 +S3,a,0.0,0.239,0.559,0.0,3.0,0.2384,0.718,0.0436 +S3,a,0.0,0.239,0.559,1.5,3.0,0.5067,0.4641,0.0292 +S3,a,0.0,0.239,0.559,3.0,3.0,0.7605,0.2258,0.0137 +S3,a,0.0,0.239,0.559,4.5,3.0,0.9028,0.0928,0.0044 +S3,b,0.4,0.483,0.701,0.0,0.0,0.0498,0.3397,0.6105 +S3,b,0.4,0.483,0.701,1.5,0.0,0.1013,0.4937,0.405 +S3,b,0.4,0.483,0.701,3.0,0.0,0.1444,0.6571,0.1985 +S3,b,0.4,0.483,0.701,4.5,0.0,0.1623,0.7775,0.0602 +S3,b,0.4,0.483,0.701,0.0,1.0,0.1014,0.5231,0.3755 +S3,b,0.4,0.483,0.701,1.5,1.0,0.2222,0.5058,0.272 +S3,b,0.4,0.483,0.701,3.0,1.0,0.3496,0.5101,0.1403 +S3,b,0.4,0.483,0.701,4.5,1.0,0.4139,0.5379,0.0482 +S3,b,0.4,0.483,0.701,0.0,2.0,0.1501,0.6975,0.1524 +S3,b,0.4,0.483,0.701,1.5,2.0,0.3398,0.5399,0.1203 +S3,b,0.4,0.483,0.701,3.0,2.0,0.5557,0.3784,0.0659 +S3,b,0.4,0.483,0.701,4.5,2.0,0.6825,0.2901,0.0274 +S3,b,0.4,0.483,0.701,0.0,3.0,0.1645,0.7963,0.0392 +S3,b,0.4,0.483,0.701,1.5,3.0,0.3936,0.5766,0.0298 +S3,b,0.4,0.483,0.701,3.0,3.0,0.6633,0.3153,0.0214 +S3,b,0.4,0.483,0.701,4.5,3.0,0.8399,0.1522,0.0079 +S3,c,0.8,0.559,0.867,0.0,0.0,0.0498,0.3797,0.5705 +S3,c,0.8,0.559,0.867,1.5,0.0,0.0917,0.559,0.3493 +S3,c,0.8,0.559,0.867,3.0,0.0,0.1017,0.7519,0.1464 +S3,c,0.8,0.559,0.867,4.5,0.0,0.0969,0.8604,0.0427 +S3,c,0.8,0.559,0.867,0.0,1.0,0.0881,0.5743,0.3376 +S3,c,0.8,0.559,0.867,1.5,1.0,0.1979,0.5437,0.2584 +S3,c,0.8,0.559,0.867,3.0,1.0,0.2941,0.5757,0.1302 +S3,c,0.8,0.559,0.867,4.5,1.0,0.3159,0.6471,0.037 +S3,c,0.8,0.559,0.867,0.0,2.0,0.0998,0.7895,0.1107 +S3,c,0.8,0.559,0.867,1.5,2.0,0.2787,0.6182,0.1031 +S3,c,0.8,0.559,0.867,3.0,2.0,0.4879,0.4399,0.0722 +S3,c,0.8,0.559,0.867,4.5,2.0,0.6066,0.3659,0.0275 +S3,c,0.8,0.559,0.867,0.0,3.0,0.1068,0.8696,0.0236 +S3,c,0.8,0.559,0.867,1.5,3.0,0.2976,0.6821,0.0203 +S3,c,0.8,0.559,0.867,3.0,3.0,0.5664,0.4147,0.0189 +S3,c,0.8,0.559,0.867,4.5,3.0,0.7813,0.2068,0.0119 diff --git a/inst/validation/kang2026_supplement.csv b/inst/validation/kang2026_supplement.csv new file mode 100644 index 0000000..33b1ef1 --- /dev/null +++ b/inst/validation/kang2026_supplement.csv @@ -0,0 +1,431 @@ +table,row,criterion,a_t,b_t,a_c,b_c,n_t,n_c,m_t,m_c,n_e,y_et,y_ec,a0_t,a0_c,setting,theta_tv,theta_mav,theta_null,gamma_go,gamma_nogo,pi_c,effect,pi_t,Go,NoGo,Gray +2,1,posterior,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +2,1,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +2,2,posterior,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +2,2,predictive,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +2,3,posterior,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +2,3,predictive,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +2,4,posterior,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +2,4,predictive,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +2,5,posterior,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +2,5,predictive,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +2,6,posterior,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +2,6,predictive,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +2,7,posterior,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.002,0.775,0.223 +2,7,predictive,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.002,0.562,0.436 +2,8,posterior,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.917,0.083 +2,8,predictive,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.562,0.438 +2,9,posterior,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.917,0.083 +2,9,predictive,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.775,0.225 +2,10,posterior,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.812,0.175 +2,10,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.677,0.317 +2,11,posterior,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.007,0.820,0.174 +2,11,predictive,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.720,0.276 +2,12,posterior,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.003,0.858,0.138 +2,12,predictive,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.001,0.783,0.215 +2,13,posterior,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.034,0.663,0.304 +2,13,predictive,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.015,0.491,0.494 +2,14,posterior,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.662,0.325 +2,14,predictive,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.485,0.508 +2,15,posterior,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.007,0.711,0.282 +2,15,predictive,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.517,0.480 +2,16,posterior,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.061,0.461,0.477 +2,16,predictive,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.031,0.312,0.657 +2,17,posterior,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.034,0.486,0.480 +2,17,predictive,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.017,0.298,0.685 +2,18,posterior,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.485,0.502 +2,18,predictive,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.010,0.310,0.680 +2,19,posterior,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.418,0.433 +2,19,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.267,0.657 +2,20,posterior,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.131,0.359,0.509 +2,20,predictive,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.068,0.268,0.664 +2,21,posterior,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.109,0.379,0.511 +2,21,predictive,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.044,0.279,0.677 +2,22,posterior,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.197,0.271,0.532 +2,22,predictive,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.118,0.180,0.702 +2,23,posterior,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.266,0.585 +2,23,predictive,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.149,0.776 +2,24,posterior,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.131,0.245,0.624 +2,24,predictive,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.074,0.139,0.787 +2,25,posterior,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.243,0.219,0.539 +2,25,predictive,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.129,0.114,0.757 +2,26,posterior,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.197,0.157,0.646 +2,26,predictive,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.118,0.073,0.809 +2,27,posterior,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.149,0.703 +2,27,predictive,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.0,0.4,0.090,0.071,0.838 +2,28,posterior,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +2,28,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.003,0.258 +2,29,posterior,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.891,0.003,0.106 +2,29,predictive,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.770,0.001,0.229 +2,30,posterior,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.917,0.002,0.081 +2,30,predictive,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.823,0.000,0.176 +2,31,posterior,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.815,0.008,0.176 +2,31,predictive,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.732,0.004,0.265 +2,32,posterior,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.003,0.144 +2,32,predictive,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.001,0.260 +2,33,posterior,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.891,0.001,0.108 +2,33,predictive,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.812,0.000,0.188 +2,34,posterior,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.753,0.012,0.235 +2,34,predictive,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.604,0.006,0.390 +2,35,posterior,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.815,0.003,0.181 +2,35,predictive,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.732,0.001,0.268 +2,36,posterior,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.001,0.146 +2,36,predictive,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.767,0.000,0.232 +2,37,posterior,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +2,37,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +2,38,posterior,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +2,38,predictive,0.5,0.5,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +2,39,posterior,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +2,39,predictive,0.5,0.5,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +2,40,posterior,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +2,40,predictive,3.0,2.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +2,41,posterior,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +2,41,predictive,3.0,2.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +2,42,posterior,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +2,42,predictive,3.0,2.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +2,43,posterior,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.943,0.000,0.057 +2,43,predictive,6.0,4.0,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.943,0.000,0.057 +2,44,posterior,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +2,44,predictive,6.0,4.0,2.0,3.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +2,45,posterior,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +2,45,predictive,6.0,4.0,4.0,6.0,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +3,1,posterior,0.5,0.5,0.5,0.5,6,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +3,2,posterior,0.5,0.5,0.5,0.5,12,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +3,3,posterior,0.5,0.5,0.5,0.5,12,12,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +3,4,posterior,0.5,0.5,0.5,0.5,24,24,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +3,5,posterior,0.5,0.5,0.5,0.5,6,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.040,0.691,0.269 +3,6,posterior,0.5,0.5,0.5,0.5,12,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.024,0.737,0.239 +3,7,posterior,0.5,0.5,0.5,0.5,12,12,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.812,0.175 +3,8,posterior,0.5,0.5,0.5,0.5,24,24,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.001,0.925,0.074 +3,9,posterior,0.5,0.5,0.5,0.5,6,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0,0.4,0.188,0.387,0.425 +3,10,posterior,0.5,0.5,0.5,0.5,12,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0,0.4,0.194,0.352,0.453 +3,11,posterior,0.5,0.5,0.5,0.5,12,12,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0,0.4,0.149,0.418,0.433 +3,12,posterior,0.5,0.5,0.5,0.5,24,24,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0,0.4,0.092,0.442,0.466 +3,13,posterior,0.5,0.5,0.5,0.5,6,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.728,0.036,0.237 +3,14,posterior,0.5,0.5,0.5,0.5,12,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.796,0.023,0.181 +3,15,posterior,0.5,0.5,0.5,0.5,12,12,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +3,16,posterior,0.5,0.5,0.5,0.5,24,24,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.947,0.001,0.052 +3,17,posterior,0.5,0.5,0.5,0.5,6,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.959,0.004,0.037 +3,18,posterior,0.5,0.5,0.5,0.5,12,6,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.959,0.004,0.037 +3,19,posterior,0.5,0.5,0.5,0.5,12,12,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +3,20,posterior,0.5,0.5,0.5,0.5,24,24,,,0,0,0,0,0,,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +4,1,predictive,0.5,0.5,0.5,0.5,6,6,25,25,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.953,0.047 +4,2,predictive,0.5,0.5,0.5,0.5,12,6,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.953,0.047 +4,3,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +4,4,predictive,0.5,0.5,0.5,0.5,24,24,100,100,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +4,5,predictive,0.5,0.5,0.5,0.5,6,6,25,25,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.008,0.679,0.313 +4,6,predictive,0.5,0.5,0.5,0.5,12,6,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.010,0.660,0.330 +4,7,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.677,0.317 +4,8,predictive,0.5,0.5,0.5,0.5,24,24,100,100,0,0,0,0,0,,,,0,0.9,0.7,0.4,-0.2,0.2,0.001,0.856,0.142 +4,9,predictive,0.5,0.5,0.5,0.5,6,6,25,25,0,0,0,0,0,,,,0,0.9,0.7,0.4,0,0.4,0.084,0.385,0.532 +4,10,predictive,0.5,0.5,0.5,0.5,12,6,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0,0.4,0.071,0.308,0.621 +4,11,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0,0.4,0.076,0.267,0.657 +4,12,predictive,0.5,0.5,0.5,0.5,24,24,100,100,0,0,0,0,0,,,,0,0.9,0.7,0.4,0,0.4,0.067,0.329,0.604 +4,13,predictive,0.5,0.5,0.5,0.5,6,6,25,25,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.527,0.035,0.439 +4,14,predictive,0.5,0.5,0.5,0.5,12,6,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.641,0.014,0.345 +4,15,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.003,0.258 +4,16,predictive,0.5,0.5,0.5,0.5,24,24,100,100,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.4,0.8,0.930,0.000,0.069 +4,17,predictive,0.5,0.5,0.5,0.5,6,6,25,25,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.959,0.000,0.041 +4,18,predictive,0.5,0.5,0.5,0.5,12,6,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.959,0.000,0.041 +4,19,predictive,0.5,0.5,0.5,0.5,12,12,50,50,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +4,20,predictive,0.5,0.5,0.5,0.5,24,24,100,100,0,0,0,0,0,,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,1,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,1,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +5,2,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,2,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +5,3,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,3,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +5,4,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.812,0.175 +5,4,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.677,0.317 +5,5,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.812,0.175 +5,5,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.677,0.317 +5,6,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.812,0.175 +5,6,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.006,0.677,0.317 +5,7,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.418,0.433 +5,7,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.267,0.657 +5,8,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.418,0.433 +5,8,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.267,0.657 +5,9,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.418,0.433 +5,9,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.267,0.657 +5,10,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +5,10,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.003,0.258 +5,11,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +5,11,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.003,0.258 +5,12,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +5,12,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.739,0.003,0.258 +5,13,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,13,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.0,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,14,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,14,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.0,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,15,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,15,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.0,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,16,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,16,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,17,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,17,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,18,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,18,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,19,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.771,0.216 +5,19,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.676,0.320 +5,20,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.010,0.829,0.161 +5,20,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.717,0.279 +5,21,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.007,0.830,0.163 +5,21,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.767,0.229 +5,22,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.150,0.307,0.543 +5,22,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.074,0.259,0.667 +5,23,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.145,0.399,0.456 +5,23,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.072,0.276,0.652 +5,24,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.130,0.422,0.448 +5,24,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.072,0.307,0.622 +5,25,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.892,0.003,0.106 +5,25,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.812,0.001,0.187 +5,26,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.004,0.143 +5,26,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.768,0.003,0.229 +5,27,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.010,0.137 +5,27,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.738,0.003,0.259 +5,28,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,28,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.2,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,29,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,29,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.2,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,30,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,30,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.2,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,31,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,31,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,32,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,32,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,33,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,33,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,34,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.770,0.216 +5,34,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.647,0.348 +5,35,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.007,0.829,0.164 +5,35,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.002,0.720,0.278 +5,36,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.003,0.864,0.132 +5,36,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.001,0.801,0.198 +5,37,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.180,0.298,0.522 +5,37,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.105,0.198,0.697 +5,38,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.131,0.399,0.469 +5,38,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.056,0.298,0.646 +5,39,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.083,0.437,0.480 +5,39,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.042,0.359,0.599 +5,40,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.931,0.001,0.068 +5,40,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.866,0.001,0.134 +5,41,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.891,0.004,0.105 +5,41,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.770,0.001,0.229 +5,42,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.842,0.005,0.153 +5,42,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.759,0.002,0.238 +5,43,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,43,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.4,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,44,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,44,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.4,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,45,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,45,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.4,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,46,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,46,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,47,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,47,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,48,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,48,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,1.000,0.000 +5,49,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.014,0.715,0.271 +5,49,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.007,0.578,0.415 +5,50,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.003,0.858,0.139 +5,50,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.001,0.784,0.215 +5,51,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.002,0.913,0.085 +5,51,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.000,0.853,0.147 +5,52,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.219,0.243,0.539 +5,52,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.139,0.132,0.729 +5,53,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.102,0.379,0.519 +5,53,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.044,0.279,0.677 +5,54,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.068,0.493,0.439 +5,54,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.029,0.378,0.593 +5,55,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.962,0.000,0.038 +5,55,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.930,0.000,0.070 +5,56,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.893,0.002,0.105 +5,56,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.816,0.001,0.184 +5,57,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.005,0.142 +5,57,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.730,0.002,0.268 +5,58,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,58,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.0,0.8,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,59,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,59,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.0,0.8,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,60,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,60,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.0,0.8,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,61,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +5,61,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +5,62,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.998,0.002 +5,62,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +5,63,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.998,0.002 +5,63,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +5,64,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.034,0.662,0.304 +5,64,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.017,0.491,0.491 +5,65,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.014,0.665,0.321 +5,65,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.007,0.662,0.330 +5,66,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.809,0.179 +5,66,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.007,0.662,0.330 +5,67,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.197,0.267,0.536 +5,67,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.118,0.180,0.702 +5,68,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.289,0.562 +5,68,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.090,0.266,0.644 +5,69,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.148,0.418,0.434 +5,69,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.267,0.658 +5,70,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.854,0.005,0.141 +5,70,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.733,0.003,0.265 +5,71,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.844,0.010,0.147 +5,71,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.730,0.004,0.267 +5,72,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.815,0.011,0.175 +5,72,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.729,0.005,0.265 +5,73,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,73,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.0,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,74,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,74,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.0,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,75,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,75,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.0,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,76,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +5,76,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +5,77,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.998,0.002 +5,77,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +5,78,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,78,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.998,0.002 +5,79,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.038,0.662,0.300 +5,79,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.014,0.485,0.501 +5,80,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.717,0.270 +5,80,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.662,0.333 +5,81,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.012,0.809,0.179 +5,81,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.664,0.333 +5,82,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.266,0.266,0.468 +5,82,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.149,0.149,0.703 +5,83,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.276,0.575 +5,83,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.072,0.266,0.662 +5,84,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.148,0.418,0.434 +5,84,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.071,0.266,0.662 +5,85,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.931,0.003,0.066 +5,85,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.853,0.001,0.146 +5,86,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.004,0.143 +5,86,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.730,0.003,0.267 +5,87,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.852,0.010,0.138 +5,87,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.729,0.003,0.268 +5,88,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,88,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.2,0.2,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,89,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,89,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.2,0.2,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,90,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,90,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.2,0.2,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,91,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.917,0.083 +5,91,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.002,0.775,0.223 +5,92,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +5,92,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +5,93,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +5,93,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +5,94,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.058,0.491,0.450 +5,94,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.032,0.367,0.601 +5,95,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.034,0.664,0.302 +5,95,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.015,0.491,0.494 +5,96,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.018,0.674,0.309 +5,96,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.011,0.569,0.420 +5,97,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.268,0.181,0.552 +5,97,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.154,0.131,0.715 +5,98,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.197,0.289,0.514 +5,98,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.092,0.181,0.727 +5,99,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.139,0.329,0.532 +5,99,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.078,0.255,0.667 +5,100,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.868,0.005,0.127 +5,100,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.773,0.002,0.225 +5,101,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.815,0.010,0.175 +5,101,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.706,0.005,0.289 +5,102,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.740,0.013,0.246 +5,102,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.602,0.008,0.390 +5,103,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,103,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.0,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,104,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,104,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.0,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.943,0.000,0.057 +5,105,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.943,0.000,0.057 +5,105,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.0,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.943,0.000,0.057 +5,106,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.917,0.083 +5,106,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.775,0.225 +5,107,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.998,0.002 +5,107,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.917,0.083 +5,108,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,1.000,0.000 +5,108,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +5,109,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.087,0.428,0.485 +5,109,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.038,0.310,0.652 +5,110,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.664,0.323 +5,110,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.490,0.506 +5,111,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.004,0.809,0.188 +5,111,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.002,0.662,0.335 +5,112,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.417,0.090,0.493 +5,112,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.266,0.063,0.671 +5,113,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.266,0.585 +5,113,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.072,0.149,0.780 +5,114,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.071,0.418,0.511 +5,114,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.030,0.266,0.704 +5,115,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.971,0.000,0.028 +5,115,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.931,0.000,0.069 +5,116,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.003,0.144 +5,116,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.730,0.001,0.269 +5,117,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.729,0.010,0.261 +5,117,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.589,0.003,0.408 +5,118,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,118,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.4,0.4,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,119,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,119,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.4,0.4,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,120,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,120,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.4,0.4,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,121,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.020,0.562,0.419 +5,121,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.020,0.562,0.419 +5,122,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.002,0.775,0.223 +5,122,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.002,0.775,0.223 +5,123,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.917,0.083 +5,123,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.002,0.775,0.223 +5,124,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.145,0.312,0.543 +5,124,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.062,0.199,0.739 +5,125,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.054,0.505,0.440 +5,125,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.031,0.368,0.601 +5,126,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.026,0.580,0.394 +5,126,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.015,0.461,0.524 +5,127,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.378,0.113,0.509 +5,127,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.275,0.068,0.657 +5,128,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.205,0.222,0.573 +5,128,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.129,0.139,0.732 +5,129,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.152,0.315,0.533 +5,129,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.080,0.219,0.701 +5,130,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.884,0.003,0.113 +5,130,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.777,0.001,0.222 +5,131,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.750,0.012,0.238 +5,131,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.604,0.006,0.390 +5,132,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.669,0.023,0.308 +5,132,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.531,0.011,0.458 +5,133,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.985,0.000,0.015 +5,133,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.0,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,0.985,0.000,0.015 +5,134,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.943,0.000,0.057 +5,134,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.0,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.943,0.000,0.057 +5,135,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.943,0.003,0.054 +5,135,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.0,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.842,0.000,0.158 +5,136,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.002,0.335,0.663 +5,136,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,,,0,0.9,0.7,0.4,-0.4,0.0,0.002,0.158,0.840 +5,137,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.980,0.020 +5,137,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.775,0.225 +5,138,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.4,0.0,0.000,0.998,0.002 +5,138,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,,,0,0.9,0.7,0.4,-0.4,0.0,0.000,0.980,0.020 +5,139,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.191,0.076,0.733 +5,139,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,,,0,0.9,0.7,0.4,-0.2,0.2,0.148,0.028,0.824 +5,140,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.013,0.519,0.468 +5,140,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,,,0,0.9,0.7,0.4,-0.2,0.2,0.004,0.310,0.686 +5,141,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,-0.2,0.2,0.001,0.809,0.191 +5,141,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,,,0,0.9,0.7,0.4,-0.2,0.2,0.001,0.662,0.337 +5,142,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.582,0.010,0.408 +5,142,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,,,0,0.9,0.7,0.4,0.0,0.4,0.422,0.003,0.575 +5,143,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.149,0.151,0.700 +5,143,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,,,0,0.9,0.7,0.4,0.0,0.4,0.076,0.071,0.853 +5,144,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.0,0.4,0.029,0.418,0.553 +5,144,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,,,0,0.9,0.7,0.4,0.0,0.4,0.023,0.266,0.711 +5,145,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.990,0.000,0.010 +5,145,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,,,0,0.9,0.7,0.4,0.4,0.8,0.976,0.000,0.024 +5,146,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.853,0.001,0.146 +5,146,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,,,0,0.9,0.7,0.4,0.4,0.8,0.730,0.000,0.270 +5,147,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.4,0.8,0.565,0.010,0.425 +5,147,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,,,0,0.9,0.7,0.4,0.4,0.8,0.565,0.003,0.432 +5,148,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,1.000,0.000,0.000 +5,148,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,8,2,0.8,0.8,Setting 1,,,0,0.9,0.7,0.4,0.6,1.0,1.000,0.000,0.000 +5,149,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.997,0.000,0.003 +5,149,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,6,4,0.8,0.8,Setting 2,,,0,0.9,0.7,0.4,0.6,1.0,0.997,0.000,0.003 +5,150,posterior,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,0.2,0.1,,0.5,0.8,0.4,0.6,1.0,0.943,0.000,0.057 +5,150,predictive,0.5,0.5,0.5,0.5,12,12,50,50,10,5,5,0.8,0.8,Setting 3,,,0,0.9,0.7,0.4,0.6,1.0,0.943,0.000,0.057 diff --git a/inst/validation/results/continuous.csv b/inst/validation/results/continuous.csv new file mode 100644 index 0000000..be46669 --- /dev/null +++ b/inst/validation/results/continuous.csv @@ -0,0 +1,44 @@ +"study","quantity","setting","method","published","computed","abs_diff","verdict","reason" +"Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2","P(Delta < 0 | data)","glaucoma example","NI",0.9949,0.99489804097447,1.95902552990734e-06,"PASS","" +"Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2","P(Delta <= -2 | data)","glaucoma example","NI",0.7011,0.701087911524612,1.20884753875838e-05,"PASS","" +"Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2","P(Delta < 0 | data)","glaucoma example","MM",0.9949,0.994896813063079,3.18693692069605e-06,"PASS","" +"Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2","P(Delta <= -2 | data)","glaucoma example","MM",0.7011,0.701095827640321,4.17235967942187e-06,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior mean","a0 = 0.25","NI",2.7,2.7,0,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior SD","a0 = 0.25","NI",0.64,0.639572443162547,0.000427556837452658,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior mean","a0 = 0.25","NI",-0.57,-0.566666666666667,0.0033333333333333,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior SD","a0 = 0.25","NI",0.589,0.588460461106534,0.000539538893466363,"EXPLAINED","huang_mc" +"Huang et al. (submitted), Table 3","Effect posterior mean","a0 = 0.25","NI",-3.27,-3.26666666666667,0.00333333333333341,"PASS","" +"Huang et al. (submitted), Table 3","Effect posterior SD","a0 = 0.25","NI",0.87,0.869102194415952,0.000897805584047506,"EXPLAINED","huang_mc" +"Huang et al. (submitted), Table 3","P(delta < -2 | data)","a0 = 0.25","NI",0.928,0.928043116982112,4.31169821116795e-05,"PASS","" +"Huang et al. (submitted), Table 3","95% credible interval, lower","a0 = 0.25","NI",-4.98,-4.97427978280296,0.00572021719703919,"EXPLAINED","huang_mc" +"Huang et al. (submitted), Table 3","95% credible interval, upper","a0 = 0.25","NI",-1.56,-1.55905355050631,0.000946449493685719,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior mean","a0 = 0.5","NI",2.65,2.65,0,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior SD","a0 = 0.5","NI",0.543,0.543316650265883,0.000316650265883345,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior mean","a0 = 0.5","NI",-0.6,-0.6,0,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior SD","a0 = 0.5","NI",0.504,0.503691054479403,0.000308945520596793,"PASS","" +"Huang et al. (submitted), Table 3","Effect posterior mean","a0 = 0.5","NI",-3.25,-3.25,0,"PASS","" +"Huang et al. (submitted), Table 3","Effect posterior SD","a0 = 0.5","NI",0.741,0.740876279022829,0.000123720977170616,"PASS","" +"Huang et al. (submitted), Table 3","P(delta < -2 | data)","a0 = 0.5","NI",0.954,0.9542781099147,0.000278109914700453,"PASS","" +"Huang et al. (submitted), Table 3","95% credible interval, lower","a0 = 0.5","NI",-4.71,-4.70474620931163,0.0052537906883714,"EXPLAINED","huang_mc" +"Huang et al. (submitted), Table 3","95% credible interval, upper","a0 = 0.5","NI",-1.8,-1.79525379071133,0.00474620928866565,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior mean","a0 = 0.75","NI",2.62,2.62,0,"PASS","" +"Huang et al. (submitted), Table 3","Control posterior SD","a0 = 0.75","NI",0.48,0.480322037032717,0.000322037032717437,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior mean","a0 = 0.75","NI",-0.62,-0.62,0,"PASS","" +"Huang et al. (submitted), Table 3","Treatment posterior SD","a0 = 0.75","NI",0.448,0.447375060150255,0.000624939849744877,"EXPLAINED","huang_mc" +"Huang et al. (submitted), Table 3","Effect posterior mean","a0 = 0.75","NI",-3.24,-3.24,0,"PASS","" +"Huang et al. (submitted), Table 3","Effect posterior SD","a0 = 0.75","NI",0.656,0.656394472633418,0.000394472633418408,"PASS","" +"Huang et al. (submitted), Table 3","P(delta < -2 | data)","a0 = 0.75","NI",0.97,0.970439712721793,0.000439712721793439,"PASS","" +"Huang et al. (submitted), Table 3","95% credible interval, lower","a0 = 0.75","NI",-4.53,-4.52837739639474,0.00162260360526023,"PASS","" +"Huang et al. (submitted), Table 3","95% credible interval, upper","a0 = 0.75","NI",-1.95,-1.95162260358573,0.00162260358573496,"PASS","" +"Kang et al. (2026), Table 4","P(theta > TV | data)","PoC data only","NI",0.499,0.5,0.001,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","PoC data only","NI",0.999,0.91215971273531,0.0868402872646904,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > TV | data)","External treatment data","NI",0.598,0.515512070991627,0.082487929008373,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","External treatment data","NI",0.999,0.927658569447442,0.0713414305525585,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > TV | data)","External treatment and control data, a0c = 0.2","NI",0.62,0.517868192312756,0.102131807687244,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","External treatment and control data, a0c = 0.2","NI",1,0.953275213340017,0.0467247866599831,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > TV | data)","External treatment and control data, a0c = 0.4","NI",0.628,0.5192088066968,0.1087911933032,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","External treatment and control data, a0c = 0.4","NI",1,0.963588456370292,0.036411543629708,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > TV | data)","External treatment and control data, a0c = 0.6","NI",0.636,0.520063935879579,0.115936064120421,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","External treatment and control data, a0c = 0.6","NI",1,0.968799893226806,0.0312001067731943,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > TV | data)","External treatment and control data, a0c = 0.8","NI",0.64,0.520653400397736,0.119346599602264,"INFO","kang2026_table4" +"Kang et al. (2026), Table 4","P(theta > MAV | data)","External treatment and control data, a0c = 0.8","NI",1,0.971854099775939,0.028145900224061,"INFO","kang2026_table4" diff --git a/inst/validation/results/kang2026_binary.csv b/inst/validation/results/kang2026_binary.csv new file mode 100644 index 0000000..2634ef7 --- /dev/null +++ b/inst/validation/results/kang2026_binary.csv @@ -0,0 +1,431 @@ +"table","row","criterion","setting","a0_t","a0_c","effect","Go","NoGo","Gray","Miss","pub_Go","pub_NoGo","pub_Gray","sensitivity","max_abs_diff","verdict","reason" +2,1,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,1,"predictive","",0,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +2,2,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,2,"predictive","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,3,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,3,"predictive","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,4,"posterior","",0,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0.063852281856,0.000408958976000018,"PASS","" +2,4,"predictive","",0,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +2,5,"posterior","",0,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0.017414258688,0.000408958976000018,"PASS","" +2,5,"predictive","",0,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +2,6,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +2,6,"predictive","",0,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +2,7,"posterior","",0,0,-0.4,0.002176782336,0.77466271744,0.223160500224,0,0.002,0.775,0.223,0,0.000337282559999874,"PASS","" +2,7,"predictive","",0,0,-0.4,0.002176782336,0.56182177792,0.436001439744,0,0.002,0.562,0.436,0,0.000178222079999846,"PASS","" +2,8,"posterior","",0,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0.14189395968,0.000443322880000041,"PASS","" +2,8,"predictive","",0,0,-0.4,0,0.56182177792,0.43817822208,0,0,0.562,0.438,0.21284093952,0.000178222079999846,"PASS","" +2,9,"posterior","",0,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +2,9,"predictive","",0,0,-0.4,0,0.77466271744,0.22533728256,0,0,0.775,0.225,0,0.000337282559999874,"PASS","" +2,10,"posterior","",0,0,-0.2,0.0128992947212501,0.812334507315822,0.174766197962927,0,0.013,0.812,0.175,0,0.000334507315822408,"PASS","" +2,10,"predictive","",0,0,-0.2,0.00647037779946708,0.676832005588406,0.316697616612127,0,0.006,0.677,0.317,0.0431535034416205,0.000470377799467077,"PASS","" +2,11,"posterior","",0,0,-0.2,0.0066833996881912,0.81978764183296,0.173528958478849,0,0.007,0.82,0.174,0.00938523820024531,0.000471041521151211,"PASS","" +2,11,"predictive","",0,0,-0.2,0.00365286461154141,0.720099619205384,0.276247516183074,0,0.004,0.72,0.276,0.0524928120471004,0.000347135388458591,"PASS","" +2,12,"posterior","",0,0,-0.2,0.00336063272492965,0.858199820149005,0.138439547126065,0,0.003,0.858,0.138,0.000651751438292595,0.000439547126065226,"PASS","" +2,12,"predictive","",0,0,-0.2,0.00144838667708603,0.783361880414647,0.215189732908266,0,0.001,0.783,0.215,0.000780164008230972,0.000448386677086027,"PASS","" +2,13,"posterior","",0,0,-0.2,0.0336556520199586,0.662617901982731,0.30372644599731,0,0.034,0.663,0.304,0.0352047348330721,0.000382098017268739,"PASS","" +2,13,"predictive","",0,0,-0.2,0.0172432551880673,0.491404786882031,0.491351957929901,0,0.015,0.491,0.494,0.00220691067395269,0.00264804207009883,"EXPLAINED","kang2026_mc" +2,14,"posterior","",0,0,-0.2,0.0128992947212501,0.662471619341471,0.324629085937279,0,0.013,0.662,0.325,0.00119669874808324,0.000471619341470997,"PASS","" +2,14,"predictive","",0,0,-0.2,0.00647037779946708,0.485347215436785,0.508182406763748,0,0.006,0.485,0.508,0.00570813676670395,0.000470377799467077,"PASS","" +2,15,"posterior","",0,0,-0.2,0.00668339968942815,0.711146539707365,0.282170060603207,0,0.007,0.711,0.282,0.0490707741025055,0.00031660031057185,"PASS","" +2,15,"predictive","",0,0,-0.2,0.00365286461154141,0.516551616290003,0.479795519098456,0,0.004,0.517,0.48,0.0147503023095943,0.000448383709997335,"PASS","" +2,16,"posterior","",0,0,-0.2,0.0611531584077119,0.461384862522767,0.477461979069521,0,0.061,0.461,0.477,0.0234630517785334,0.000461979069520779,"PASS","" +2,16,"predictive","",0,0,-0.2,0.0344029444224641,0.311724238340831,0.653872817236704,0,0.031,0.312,0.657,0.0453152819192348,0.00340294442246411,"EXPLAINED","kang2026_mc" +2,17,"posterior","",0,0,-0.2,0.0341044140492529,0.486041803558993,0.479853782391754,0,0.034,0.486,0.48,0.0188626957353988,0.000146217608246069,"PASS","" +2,17,"predictive","",0,0,-0.2,0.0172432551880673,0.297615732923291,0.685141011888642,0,0.017,0.298,0.685,0.0202163714219873,0.000384267076708855,"PASS","" +2,18,"posterior","",0,0,-0.2,0.0128992947212501,0.485347215436785,0.501753489841965,0,0.013,0.485,0.502,0,0.000347215436785231,"PASS","" +2,18,"predictive","",0,0,-0.2,0.00647037779946708,0.309805911606452,0.683723710594081,0,0.01,0.31,0.68,0.00874285440125384,0.00372371059408094,"EXPLAINED","kang2026_mc" +2,19,"posterior","",0,0,0,0.148541996906618,0.4179812911142,0.433476711979181,0,0.149,0.418,0.433,0,0.000476711979181144,"PASS","" +2,19,"predictive","",0,0,0,0.075517912705864,0.267387711401037,0.657094375893099,0,0.076,0.267,0.657,0.0129494868450069,0.000482087294135972,"PASS","" +2,20,"posterior","",0,0,0,0.131395751171349,0.359392416390252,0.509211832438398,0,0.131,0.359,0.509,0.0400926273368263,0.00039575117134924,"PASS","" +2,20,"predictive","",0,0,0,0.0739574329840184,0.267965846937828,0.658076720078154,0,0.068,0.268,0.664,0.0480923598289328,0.00595743298401842,"EXPLAINED","kang2026_mc" +2,21,"posterior","",0,0,0,0.109379103954265,0.379259848204833,0.511361047840902,0,0.109,0.379,0.511,0.00742385622680159,0.000379103954264867,"PASS","" +2,21,"predictive","",0,0,0,0.0583711675786759,0.276909150607944,0.66471968181338,0,0.044,0.279,0.677,0.017011384934988,0.0143711675786759,"EXPLAINED","kang2026_mc" +2,22,"posterior","",0,0,0,0.196692285184361,0.271041136074034,0.532266578741605,0,0.197,0.271,0.532,0.0204272255837134,0.000307714815638682,"PASS","" +2,22,"predictive","",0,0,0,0.117704804681097,0.180271135740244,0.702024059578659,0,0.118,0.18,0.702,0.0260503526751608,0.000295195318902805,"PASS","" +2,23,"posterior","",0,0,0,0.148541996906618,0.266237106747109,0.585220896346273,0,0.149,0.266,0.585,3.79121172561537e-05,0.000458003093381648,"PASS","" +2,23,"predictive","",0,0,0,0.075517912705864,0.148541996906618,0.775940090387518,0,0.076,0.149,0.776,0.0184669584487147,0.000482087294135972,"PASS","" +2,24,"posterior","",0,0,0,0.131395756237899,0.244754691318045,0.623849552444057,0,0.131,0.245,0.624,0.0538886275812452,0.000395756237898809,"PASS","" +2,24,"predictive","",0,0,0,0.0739574329840184,0.139142347784939,0.786900219231043,0,0.074,0.139,0.787,0.037638358438358,0.000142347784938601,"PASS","" +2,25,"posterior","",0,0,0,0.242562814472699,0.218767144355323,0.538670041171977,0,0.243,0.219,0.539,0.037583272148183,0.00043718552730071,"PASS","" +2,25,"predictive","",0,0,0,0.132244010207511,0.113862610003923,0.753893379788565,0,0.129,0.114,0.757,0.0281885997374348,0.00324401020751122,"EXPLAINED","kang2026_mc" +2,26,"posterior","",0,0,0,0.196730192235068,0.157363145328221,0.645906662436711,0,0.197,0.157,0.646,0.0611203763012968,0.000363145328220738,"PASS","" +2,26,"predictive","",0,0,0,0.117704804681097,0.0830390775258318,0.799256117793071,0,0.118,0.073,0.809,0.0566090205873376,0.0100390775258318,"EXPLAINED","kang2026_mc" +2,27,"posterior","",0,0,0,0.148541996906618,0.148541996906618,0.702916006186763,0,0.149,0.149,0.703,0,0.000458003093381648,"PASS","" +2,27,"predictive","",0,0,0,0.075517912705864,0.0714896678088889,0.852992419485247,0,0.09,0.071,0.838,0.0767432478375427,0.014992419485247,"EXPLAINED","kang2026_mc" +2,28,"posterior","",0,0,0.4,0.853069343654709,0.009800963570752,0.137129692774539,0,0.853,0.01,0.137,0,0.000199036429248001,"PASS","" +2,28,"predictive","",0,0,0.4,0.738863579235717,0.00297769357471495,0.258158727189568,0,0.739,0.003,0.258,0.0094368488877113,0.000158727189567609,"PASS","" +2,29,"posterior","",0,0,0.4,0.891340632404827,0.00301963806129271,0.105639729533881,0,0.891,0.003,0.106,0.000662669113767386,0.000360270466119389,"PASS","" +2,29,"predictive","",0,0,0.4,0.81192917845,0.00116825825948704,0.186902563290513,0,0.77,0.001,0.229,0.0427731925207753,0.0420974367094867,"EXPLAINED","kang2026_mc" +2,30,"posterior","",0,0,0.4,0.916674017196502,0.00191456853906307,0.0814114142644346,0,0.917,0.002,0.081,0.000651751438292594,0.000411414264434556,"PASS","" +2,30,"predictive","",0,0,0.4,0.823375130673483,0.000473772913880232,0.176151096412637,0,0.823,0,0.176,0.00780429554184156,0.000473772913880232,"PASS","" +2,31,"posterior","",0,0,0.4,0.815448786223637,0.00824642920572854,0.176304784570635,0,0.815,0.008,0.176,0.0015642316109288,0.000448786223636977,"PASS","" +2,31,"predictive","",0,0,0.4,0.73175287275477,0.00352392748858823,0.264723199756642,0,0.732,0.004,0.265,0.0776004370233494,0.000476072511411767,"PASS","" +2,32,"posterior","",0,0,0.4,0.853069343654709,0.00288861776328584,0.144042038582005,0,0.853,0.003,0.144,3.45883584262413e-06,0.000111382236714159,"PASS","" +2,32,"predictive","",0,0,0.4,0.738863579235717,0.000726747459896696,0.260409673304386,0,0.739,0.001,0.26,0.0374911740689634,0.000409673304385849,"PASS","" +2,33,"posterior","",0,0,0.4,0.89136138499191,0.000833068381725417,0.107805546626365,0,0.891,0.001,0.108,0.0240356779099038,0.00036138499190963,"PASS","" +2,33,"predictive","",0,0,0.4,0.81192917845,0.000215264197149037,0.187855557352851,0,0.812,0,0.188,0.0720132057397606,0.000215264197149037,"PASS","" +2,34,"posterior","",0,0,0.4,0.753348923771326,0.0116886233081489,0.234962452920525,0,0.753,0.012,0.235,9.1652546009896e-05,0.000348923771325782,"PASS","" +2,34,"predictive","",0,0,0.4,0.658040559554916,0.00555976294188923,0.336399677503194,0,0.604,0.006,0.39,0.0605739778357354,0.0540405595549165,"EXPLAINED","kang2026_mc" +2,35,"posterior","",0,0,0.4,0.81544878665161,0.00312648327336041,0.18142473007503,0,0.815,0.003,0.181,0.0328257869250227,0.000448786651609745,"PASS","" +2,35,"predictive","",0,0,0.4,0.73175287275477,0.000739258488753223,0.267507868756477,0,0.732,0.001,0.268,0.0373428899584869,0.00049213124352343,"PASS","" +2,36,"posterior","",0,0,0.4,0.853069343654709,0.000726747459896696,0.146203908885394,0,0.853,0.001,0.146,0,0.000273252540103304,"PASS","" +2,36,"predictive","",0,0,0.4,0.738863579235717,0.000153884401286978,0.260982536362996,0,0.767,0,0.232,0.122882250903834,0.0289825363629956,"EXPLAINED","kang2026_mc" +2,37,"posterior","",0,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0,0.000206593535999997,"PASS","" +2,37,"predictive","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.002491416576,0.000189816319999996,"PASS","" +2,38,"posterior","",0,0,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +2,38,"predictive","",0,0,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +2,39,"posterior","",0,0,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +2,39,"predictive","",0,0,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +2,40,"posterior","",0,0,0.6,0.98473273344,0.000318767104,0.014948499456,0,0.985,0,0.015,0,0.000318767104,"PASS","" +2,40,"predictive","",0,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0.04204265472,0.00026726656000009,"PASS","" +2,41,"posterior","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +2,41,"predictive","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +2,42,"posterior","",0,0,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0.000301989888,1.6777216000019e-05,"PASS","" +2,42,"predictive","",0,0,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0.000301989888,1.6777216000019e-05,"PASS","" +2,43,"posterior","",0,0,0.6,0.94269007872,0.000318767104,0.056991154176,0,0.943,0,0.057,0,0.000318767104,"PASS","" +2,43,"predictive","",0,0,0.6,0.94269007872,0.000318767104,0.056991154176,0,0.943,0,0.057,0.100902371328,0.000318767104,"PASS","" +2,44,"posterior","",0,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +2,44,"predictive","",0,0,0.6,0.98473273344,0,0.01526726656,0,0.985,0,0.015,0.04204265472,0.00026726656000009,"PASS","" +2,45,"posterior","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +2,45,"predictive","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +3,1,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +3,2,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +3,3,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +3,4,"posterior","",0,0,-0.4,0,1,0,0,0,1,0,0,2.22044604925031e-16,"PASS","" +3,5,"posterior","",0,0,-0.2,0.04025935872,0.69093425152,0.26880638976,0,0.04,0.691,0.269,0,0.000259358719999991,"PASS","" +3,6,"posterior","",0,0,-0.2,0.0243564428722176,0.73672783626974,0.238915720858042,0,0.024,0.737,0.239,0.0110233556877312,0.000356442872217595,"PASS","" +3,7,"posterior","",0,0,-0.2,0.0128992947212501,0.812334507315822,0.174766197962927,0,0.013,0.812,0.175,0,0.000334507315822408,"PASS","" +3,8,"posterior","",0,0,-0.2,0.00135900394968927,0.924804339063338,0.0738366569869727,0,0.001,0.925,0.074,0.00963271467597612,0.000359003949689272,"PASS","" +3,9,"posterior","",0,0,0,0.18844213248,0.38685435904,0.42470350848,0,0.188,0.387,0.425,0,0.000442132480000024,"PASS","" +3,10,"posterior","",0,0,0,0.194467602943181,0.352219279663563,0.453313117393256,0,0.194,0.352,0.453,0.00707942248611839,0.00046760294318085,"PASS","" +3,11,"posterior","",0,0,0,0.148541996906618,0.4179812911142,0.433476711979181,0,0.149,0.418,0.433,0,0.000476711979181144,"PASS","" +3,12,"posterior","",0,0,0,0.0920332016457371,0.442320352698475,0.465646445655788,0,0.092,0.442,0.466,0.0431829297953294,0.000353554344212303,"PASS","" +3,13,"posterior","",0,0,0.4,0.72775729152,0.03567167488,0.2365710336,0,0.728,0.036,0.237,0,0.00042896639999998,"PASS","" +3,14,"posterior","",0,0,0.4,0.795854351263334,0.023239813799084,0.180905834937582,0,0.796,0.023,0.181,0.008710822821888,0.00023981379908404,"PASS","" +3,15,"posterior","",0,0,0.4,0.853069343654709,0.009800963570752,0.137129692774539,0,0.853,0.01,0.137,0,0.000199036429248001,"PASS","" +3,16,"posterior","",0,0,0.4,0.94731575659211,0.000870867538317164,0.0518133758695731,0,0.947,0.001,0.052,0.0422226479730421,0.000315756592109584,"PASS","" +3,17,"posterior","",0,0,0.6,0.95904,0.004096,0.036864,0,0.959,0.004,0.037,0,0.000135999999999969,"PASS","" +3,18,"posterior","",0,0,0.6,0.95904,0.004096,0.036864,0,0.959,0.004,0.037,0,0.000135999999999969,"PASS","" +3,19,"posterior","",0,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0,0.000206593535999997,"PASS","" +3,20,"posterior","",0,0,0.6,0.999891900133328,1.04145741382943e-08,0.000108089452097264,0,1,0,0,0,0.000108099866671596,"PASS","" +4,1,"predictive","",0,0,-0.4,0,0.953344,0.046656,0,0,0.953,0.047,0,0.000344000000000011,"PASS","" +4,2,"predictive","",0,0,-0.4,0,0.953344,0.046656,0,0,0.953,0.047,0.046656,0.000344000000000011,"PASS","" +4,3,"predictive","",0,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +4,4,"predictive","",0,0,-0.4,0,0.999995261618661,4.73838133832161e-06,0,0,1,0,0,4.73838133852045e-06,"PASS","" +4,5,"predictive","",0,0,-0.2,0.01976887296,0.678703398912,0.301527728128,0,0.008,0.679,0.313,0.01147502592,0.01176887296,"EXPLAINED","kang2026_mc" +4,6,"predictive","",0,0,-0.2,0.0103336070487736,0.660044669811425,0.329621723139801,0,0.01,0.66,0.33,0.0171216742561874,0.000378276860198978,"PASS","" +4,7,"predictive","",0,0,-0.2,0.00647037779946708,0.676832005588406,0.316697616612127,0,0.006,0.677,0.317,0.0431535034416205,0.000470377799467077,"PASS","" +4,8,"predictive","",0,0,-0.2,0.00150589203785575,0.85695170490931,0.141542403052834,0,0.001,0.856,0.142,0.00162655909743672,0.000951704909309958,"EXPLAINED","kang2026_mc" +4,9,"predictive","",0,0,0,0.08365400064,0.384660799488,0.531685199872,0,0.084,0.385,0.532,0.01507811328,0.000345999359999988,"PASS","" +4,10,"predictive","",0,0,0,0.0711968840975647,0.307523735865262,0.621279380037173,0,0.071,0.308,0.621,0.0403644986511852,0.000476264134737947,"PASS","" +4,11,"predictive","",0,0,0,0.075517912705864,0.267387711401037,0.657094375893099,0,0.076,0.267,0.657,0.0129494868450069,0.000482087294135972,"PASS","" +4,12,"predictive","",0,0,0,0.075728349202955,0.329407256564131,0.594864394232913,0,0.067,0.329,0.604,0.0613683056706518,0.00913560576708683,"EXPLAINED","kang2026_mc" +4,13,"predictive","",0,0,0.4,0.52731150336,0.034594947072,0.438093549568,0,0.527,0.035,0.439,0.03695542272,0.000906450431999994,"EXPLAINED","kang2026_mc" +4,14,"predictive","",0,0,0.4,0.640669546407002,0.0142322683399373,0.345098185253061,0,0.641,0.014,0.345,0.0812689525395948,0.00033045359299777,"PASS","" +4,15,"predictive","",0,0,0.4,0.738863579235717,0.00297769357471495,0.258158727189568,0,0.739,0.003,0.258,0.0094368488877113,0.000158727189567609,"PASS","" +4,16,"predictive","",0,0,0.4,0.934653589248946,0.000292259424183513,0.0650541513268704,0,0.93,0,0.069,0.0325009125758555,0.00465358924894577,"EXPLAINED","kang2026_mc" +4,17,"predictive","",0,0,0.6,0.95904,0,0.04096,0,0.959,0,0.041,0.13824,4.000000000004e-05,"PASS","" +4,18,"predictive","",0,0,0.6,0.95904,0,0.04096,0,0.959,0,0.041,0,4.000000000004e-05,"PASS","" +4,19,"predictive","",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.002491416576,0.000189816319999996,"PASS","" +4,20,"predictive","",0,0,0.6,0.999999814789465,0,1.85210534675612e-07,0,1,0,0,0,1.8521053490872e-07,"PASS","" +5,1,"posterior","Setting 1",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,1,"predictive","Setting 1",0,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,2,"posterior","Setting 2",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,2,"predictive","Setting 2",0,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,3,"posterior","Setting 3",0,0,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,3,"predictive","Setting 3",0,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,4,"posterior","Setting 1",0,0,-0.2,0.0128992947212501,0.812334507315822,0.174766197962927,0,0.013,0.812,0.175,0,0.000334507315822408,"PASS","" +5,4,"predictive","Setting 1",0,0,-0.2,0.00647037779946708,0.676832005588406,0.316697616612127,0,0.006,0.677,0.317,0.0431535034416205,0.000470377799467077,"PASS","" +5,5,"posterior","Setting 2",0,0,-0.2,0.0128992947212501,0.812334507315822,0.174766197962927,0,0.013,0.812,0.175,0,0.000334507315822408,"PASS","" +5,5,"predictive","Setting 2",0,0,-0.2,0.00647037779946708,0.676832005588406,0.316697616612127,0,0.006,0.677,0.317,0.0431535034416205,0.000470377799467077,"PASS","" +5,6,"posterior","Setting 3",0,0,-0.2,0.0128992947212501,0.812334507315822,0.174766197962927,0,0.013,0.812,0.175,0,0.000334507315822408,"PASS","" +5,6,"predictive","Setting 3",0,0,-0.2,0.00647037779946708,0.676832005588406,0.316697616612127,0,0.006,0.677,0.317,0.0431535034416205,0.000470377799467077,"PASS","" +5,7,"posterior","Setting 1",0,0,0,0.148541996906618,0.4179812911142,0.433476711979181,0,0.149,0.418,0.433,0,0.000476711979181144,"PASS","" +5,7,"predictive","Setting 1",0,0,0,0.075517912705864,0.267387711401037,0.657094375893099,0,0.076,0.267,0.657,0.0129494868450069,0.000482087294135972,"PASS","" +5,8,"posterior","Setting 2",0,0,0,0.148541996906618,0.4179812911142,0.433476711979181,0,0.149,0.418,0.433,0,0.000476711979181144,"PASS","" +5,8,"predictive","Setting 2",0,0,0,0.075517912705864,0.267387711401037,0.657094375893099,0,0.076,0.267,0.657,0.0129494868450069,0.000482087294135972,"PASS","" +5,9,"posterior","Setting 3",0,0,0,0.148541996906618,0.4179812911142,0.433476711979181,0,0.149,0.418,0.433,0,0.000476711979181144,"PASS","" +5,9,"predictive","Setting 3",0,0,0,0.075517912705864,0.267387711401037,0.657094375893099,0,0.076,0.267,0.657,0.0129494868450069,0.000482087294135972,"PASS","" +5,10,"posterior","Setting 1",0,0,0.4,0.853069343654709,0.009800963570752,0.137129692774539,0,0.853,0.01,0.137,0,0.000199036429248001,"PASS","" +5,10,"predictive","Setting 1",0,0,0.4,0.738863579235717,0.00297769357471495,0.258158727189568,0,0.739,0.003,0.258,0.0094368488877113,0.000158727189567609,"PASS","" +5,11,"posterior","Setting 2",0,0,0.4,0.853069343654709,0.009800963570752,0.137129692774539,0,0.853,0.01,0.137,0,0.000199036429248001,"PASS","" +5,11,"predictive","Setting 2",0,0,0.4,0.738863579235717,0.00297769357471495,0.258158727189568,0,0.739,0.003,0.258,0.0094368488877113,0.000158727189567609,"PASS","" +5,12,"posterior","Setting 3",0,0,0.4,0.853069343654709,0.009800963570752,0.137129692774539,0,0.853,0.01,0.137,0,0.000199036429248001,"PASS","" +5,12,"predictive","Setting 3",0,0,0.4,0.738863579235717,0.00297769357471495,0.258158727189568,0,0.739,0.003,0.258,0.0094368488877113,0.000158727189567609,"PASS","" +5,13,"posterior","Setting 1",0,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0,0.000206593535999997,"PASS","" +5,13,"predictive","Setting 1",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.002491416576,0.000189816319999996,"PASS","" +5,14,"posterior","Setting 2",0,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0,0.000206593535999997,"PASS","" +5,14,"predictive","Setting 2",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.002491416576,0.000189816319999996,"PASS","" +5,15,"posterior","Setting 3",0,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0,0.000206593535999997,"PASS","" +5,15,"predictive","Setting 3",0,0,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.002491416576,0.000189816319999996,"PASS","" +5,16,"posterior","Setting 1",0,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,16,"predictive","Setting 1",0,0.2,-0.4,0,1,0,0,0,1,0,0.002176782336,0,"PASS","" +5,17,"posterior","Setting 2",0,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,17,"predictive","Setting 2",0,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,18,"posterior","Setting 3",0,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,18,"predictive","Setting 3",0,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,19,"posterior","Setting 1",0,0.2,-0.2,0.0129052982401773,0.771072030430683,0.21602267132914,0,0.013,0.771,0.216,0.0307726398960239,9.47017598227178e-05,"PASS","" +5,19,"predictive","Setting 1",0,0.2,-0.2,0.00416707110344109,0.676287148493544,0.319545780403015,0,0.004,0.676,0.32,0.00848843732398948,0.000454219596985439,"PASS","" +5,20,"posterior","Setting 2",0,0.2,-0.2,0.0100711590260067,0.828724100518378,0.161204740455616,0,0.01,0.829,0.161,0.00156420721748903,0.000275899481622432,"PASS","" +5,20,"predictive","Setting 2",0,0.2,-0.2,0.00364267854491899,0.717203966099471,0.27915335535561,0,0.004,0.717,0.279,0.0502784045375525,0.000357321455081014,"PASS","" +5,21,"posterior","Setting 3",0,0.2,-0.2,0.00667739616926403,0.830434575771249,0.162888028059487,0,0.007,0.83,0.163,0.00279469362828085,0.000434575771248724,"PASS","" +5,21,"predictive","Setting 3",0,0.2,-0.2,0.0036422421042237,0.767481934196329,0.228875823699448,0,0.004,0.767,0.229,0.0014616398885102,0.000481934196328582,"PASS","" +5,22,"posterior","Setting 1",0,0.2,0,0.149907495588006,0.306956045536521,0.543136458875473,0,0.15,0.307,0.543,0.0560540783966248,0.000136458875472756,"PASS","" +5,22,"predictive","Setting 1",0,0.2,0,0.0742663052490349,0.258602337425024,0.667131357325941,0,0.074,0.259,0.667,0.03624638401977,0.000397662574976088,"PASS","" +5,23,"posterior","Setting 2",0,0.2,0,0.144526699260438,0.399443338030824,0.456029962708738,0,0.145,0.399,0.456,0.0178218110390343,0.000473300739562366,"PASS","" +5,23,"predictive","Setting 2",0,0.2,0,0.0717540049001676,0.276451945440364,0.651794049659468,0,0.072,0.276,0.652,0.0304522335309884,0.000451945440364365,"PASS","" +5,24,"posterior","Setting 3",0,0.2,0,0.130030252489962,0.422058313533051,0.447911433976987,0,0.13,0.422,0.448,0.0298903899914523,8.8566023012715e-05,"PASS","" +5,24,"predictive","Setting 3",0,0.2,0,0.0715026150596833,0.306652789130869,0.621844595809448,0,0.072,0.307,0.622,0.0258438084937708,0.000497384940316689,"PASS","" +5,25,"posterior","Setting 1",0,0.2,0.4,0.89156190690742,0.00290152246046539,0.105536570632115,0,0.892,0.003,0.106,0.0235810163049547,0.000463429367885418,"PASS","" +5,25,"predictive","Setting 1",0,0.2,0.4,0.811929303988694,0.00116764109097672,0.186903054920329,0,0.812,0.001,0.187,0.045276201389416,0.00016764109097672,"PASS","" +5,26,"posterior","Setting 2",0,0.2,0.4,0.853231388173458,0.00360967269229704,0.143158939134245,0,0.853,0.004,0.143,0.00438914936856516,0.000390327307702961,"PASS","" +5,26,"predictive","Setting 2",0,0.2,0.4,0.767628201160679,0.00288924414212792,0.229482554697193,0,0.768,0.003,0.229,0.0286148523007671,0.000482554697193105,"PASS","" +5,27,"posterior","Setting 3",0,0.2,0.4,0.852848069152116,0.00973782907312611,0.137414101774758,0,0.853,0.01,0.137,0.00667801003942011,0.000414101774758258,"PASS","" +5,27,"predictive","Setting 3",0,0.2,0.4,0.739025623754467,0.00290151903668282,0.25807285720885,0,0.738,0.003,0.259,0.0371341201176476,0.0010256237544668,"EXPLAINED","kang2026_mc" +5,28,"posterior","Setting 1",0,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,28,"predictive","Setting 1",0,0.2,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,29,"posterior","Setting 2",0,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0.002491416576,0.000318767104000028,"PASS","" +5,29,"predictive","Setting 2",0,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,30,"posterior","Setting 3",0,0.2,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,30,"predictive","Setting 3",0,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,31,"posterior","Setting 1",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,31,"predictive","Setting 1",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,32,"posterior","Setting 2",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,32,"predictive","Setting 2",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,33,"posterior","Setting 3",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,33,"predictive","Setting 3",0,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,34,"posterior","Setting 1",0,0.4,-0.2,0.0132369681883771,0.770377587302241,0.216385444509381,0,0.013,0.77,0.216,0.000651751438292595,0.000385444509381466,"PASS","" +5,34,"predictive","Setting 1",0,0.4,-0.2,0.00377088593945927,0.647452679528658,0.348776434531883,0,0.004,0.647,0.348,0.00122124090809416,0.000776434531882697,"EXPLAINED","kang2026_mc" +5,35,"posterior","Setting 2",0,0.4,-0.2,0.0066833996881912,0.829172862544373,0.164143737767435,0,0.007,0.829,0.164,0.0451093464228261,0.0003166003118088,"PASS","" +5,35,"predictive","Setting 2",0,0.4,-0.2,0.0024278681582051,0.770377587302241,0.227194544539553,0,0.002,0.72,0.278,0.053144563485393,0.0508054554604466,"EXPLAINED","kang2026_mc" +5,36,"posterior","Setting 3",0,0.4,-0.2,0.0034814624463379,0.86425571139418,0.132262826159482,0,0.003,0.864,0.132,0.00593265740029251,0.0004814624463379,"PASS","" +5,36,"predictive","Setting 3",0,0.4,-0.2,0.000966662261228037,0.801237500642349,0.197795837096422,0,0.001,0.801,0.198,0.0483777623138345,0.000237500642349397,"PASS","" +5,37,"posterior","Setting 1",0,0.4,0,0.17996217199586,0.298166690628332,0.521871137375808,0,0.18,0.298,0.522,0.00742385622680159,0.000166690628331911,"PASS","" +5,37,"predictive","Setting 1",0,0.4,0,0.0836078894208623,0.197846870770466,0.718545239808672,0,0.105,0.198,0.697,0.0217857801608767,0.021545239808672,"EXPLAINED","kang2026_mc" +5,38,"posterior","Setting 2",0,0.4,0,0.131395751171349,0.399481240014981,0.46912300881367,0,0.131,0.399,0.469,0.0865351833862747,0.000481240014981066,"PASS","" +5,38,"predictive","Setting 2",0,0.4,0,0.0673408984900447,0.298166690628332,0.634492410881623,0,0.056,0.298,0.646,0.0555162160557344,0.0115075891183767,"EXPLAINED","kang2026_mc" +5,39,"posterior","Setting 3",0,0.4,0,0.0830390775258318,0.437432390752974,0.479528531721194,0,0.083,0.437,0.48,0.0230514040648317,0.000471468278806175,"PASS","" +5,39,"predictive","Setting 3",0,0.4,0,0.0417447179236944,0.355168845962362,0.603086436113944,0,0.042,0.359,0.599,0.0616020136870926,0.00408643611394388,"EXPLAINED","kang2026_mc" +5,40,"posterior","Setting 1",0,0.4,0.4,0.931157107003719,0.00118053315404193,0.0676623598422393,0,0.931,0.001,0.068,0.000651751438292594,0.000337640157760735,"PASS","" +5,40,"predictive","Setting 1",0,0.4,0.4,0.854528479345843,0.000564292510792244,0.144907228143365,0,0.866,0.001,0.134,0.0118262948907895,0.0114715206541572,"EXPLAINED","kang2026_mc" +5,41,"posterior","Setting 2",0,0.4,0.4,0.891340632404827,0.00360621435575604,0.105053153239417,0,0.891,0.004,0.105,0.0266299018335809,0.00039378564424396,"PASS","" +5,41,"predictive","Setting 2",0,0.4,0.4,0.770158108320686,0.00118053315404193,0.228661358525272,0,0.77,0.001,0.229,0.0434249439590679,0.000338641474728091,"PASS","" +5,42,"posterior","Setting 3",0,0.4,0.4,0.842074076872782,0.00517860107069486,0.152747322056523,0,0.842,0.005,0.153,0.0113137479932583,0.000252677943477192,"PASS","" +5,42,"predictive","Setting 3",0,0.4,0.4,0.759058432957739,0.00261222027927941,0.238329346762982,0,0.759,0.002,0.238,0.0595701822850606,0.00061222027927941,"EXPLAINED","kang2026_mc" +5,43,"posterior","Setting 1",0,0.4,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,43,"predictive","Setting 1",0,0.4,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,44,"posterior","Setting 2",0,0.4,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,44,"predictive","Setting 2",0,0.4,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,45,"posterior","Setting 3",0,0.4,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,45,"predictive","Setting 3",0,0.4,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,46,"posterior","Setting 1",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,46,"predictive","Setting 1",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,47,"posterior","Setting 2",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,47,"predictive","Setting 2",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,48,"posterior","Setting 3",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,48,"predictive","Setting 3",0,0.8,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,49,"posterior","Setting 1",0,0.8,-0.2,0.0142780574451003,0.714983843802922,0.270738098751978,0,0.014,0.715,0.271,0.0239128169846447,0.0002780574451003,"PASS","" +5,49,"predictive","Setting 1",0,0.8,-0.2,0.00677510666957868,0.577948066643313,0.415276826687109,0,0.007,0.578,0.415,0.0157012629915961,0.000276826687108656,"PASS","" +5,50,"posterior","Setting 2",0,0.8,-0.2,0.00326898011954613,0.858199976895383,0.138531042985071,0,0.003,0.858,0.139,0.0104024449428427,0.000468957014928911,"PASS","" +5,50,"predictive","Setting 2",0,0.8,-0.2,0.000977030666804362,0.783555000660051,0.215467968673144,0,0.001,0.784,0.215,0.000587052411585465,0.000467968673144192,"PASS","" +5,51,"posterior","Setting 3",0,0.8,-0.2,0.00156622511553826,0.913172578343789,0.085261196540673,0,0.002,0.913,0.085,0.00156549709935032,0.000433774884461742,"PASS","" +5,51,"predictive","Setting 3",0,0.8,-0.2,0.000470535790540079,0.853263437826768,0.146266026382692,0,0,0.853,0.147,0.00591087522564226,0.000733973617308287,"EXPLAINED","kang2026_mc" +5,52,"posterior","Setting 1",0,0.8,0,0.218766391972711,0.242631193019222,0.538602415008067,0,0.219,0.243,0.539,0.0376516506947059,0.000397584991932876,"PASS","" +5,52,"predictive","Setting 1",0,0.8,0,0.138851497176006,0.131940753801859,0.729207749022135,0,0.139,0.132,0.729,0.05448716042383,0.000207749022135273,"PASS","" +5,53,"posterior","Setting 2",0,0.8,0,0.101955156529571,0.379272544661424,0.518772298809006,0,0.102,0.379,0.519,0.0514662448437416,0.000272544661423513,"PASS","" +5,53,"predictive","Setting 2",0,0.8,0,0.0440536393719518,0.279109517070881,0.676836843557167,0,0.044,0.279,0.677,0.014811632632858,0.000163156442833268,"PASS","" +5,54,"posterior","Setting 3",0,0.8,0,0.0679152817225835,0.492936292590232,0.439148425687184,0,0.068,0.493,0.439,0.017922753093805,0.000148425687183928,"PASS","" +5,54,"predictive","Setting 3",0,0.8,0,0.0292308913697447,0.378147908050774,0.592621200579481,0,0.029,0.378,0.593,0.0239404900045579,0.000378799420518661,"PASS","" +5,55,"posterior","Setting 1",0,0.8,0.4,0.961502226444471,0.00046122183419785,0.0380365517213307,0,0.962,0,0.038,0.000107703803054666,0.000497773555528491,"PASS","" +5,55,"predictive","Setting 1",0,0.8,0.4,0.918936115143841,0.000109151428394439,0.0809547334277644,0,0.93,0,0.07,0.036357123210879,0.0110638848561588,"EXPLAINED","kang2026_mc" +5,56,"posterior","Setting 2",0,0.8,0.4,0.89314870765672,0.00195469561174294,0.104896596731537,0,0.893,0.002,0.105,0.0241074763033354,0.000148707656720259,"PASS","" +5,56,"predictive","Setting 2",0,0.8,0.4,0.815771177697705,0.00066911373296766,0.183559708569327,0,0.816,0.001,0.184,0.00754892624332091,0.000440291430673062,"PASS","" +5,57,"posterior","Setting 3",0,0.8,0.4,0.852964874318541,0.00488570115976108,0.142149424521698,0,0.853,0.005,0.142,0.00240887833181351,0.000149424521697555,"PASS","" +5,57,"predictive","Setting 3",0,0.8,0.4,0.733069172039233,0.00191449321584648,0.26501633474492,0,0.73,0.002,0.268,0.0328807002655115,0.00306917203923351,"EXPLAINED","kang2026_mc" +5,58,"posterior","Setting 1",0,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,58,"predictive","Setting 1",0,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,59,"posterior","Setting 2",0,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,59,"predictive","Setting 2",0,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,60,"posterior","Setting 3",0,0.8,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,60,"predictive","Setting 3",0,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,61,"posterior","Setting 1",0.2,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,61,"predictive","Setting 1",0.2,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,62,"posterior","Setting 2",0.2,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,62,"predictive","Setting 2",0.2,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,63,"posterior","Setting 3",0.2,0,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,63,"predictive","Setting 3",0.2,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,64,"posterior","Setting 1",0.2,0,-0.2,0.0336560967776004,0.66247823018269,0.30386567303971,0,0.034,0.662,0.304,0.00343915272987174,0.000478230182689554,"PASS","" +5,64,"predictive","Setting 1",0.2,0,-0.2,0.0172432552390915,0.491404643138478,0.49135210162243,0,0.017,0.491,0.491,0.0351393563476241,0.000404643138478378,"PASS","" +5,65,"posterior","Setting 2",0.2,0,-0.2,0.0135163341945833,0.665378804178181,0.321104861627235,0,0.014,0.665,0.321,0.0272796066295221,0.000483665805416743,"PASS","" +5,65,"predictive","Setting 2",0.2,0,-0.2,0.0104811801193381,0.662471764335238,0.327047055545424,0,0.007,0.662,0.33,0.00340022863461616,0.00348118011933808,"EXPLAINED","kang2026_mc" +5,66,"posterior","Setting 3",0.2,0,-0.2,0.0128988499636084,0.808594834514684,0.178506315521708,0,0.013,0.809,0.179,0.120677307049918,0.00049368447829215,"PASS","" +5,66,"predictive","Setting 3",0.2,0,-0.2,0.00708741727280022,0.662478230123316,0.330434352603884,0,0.007,0.662,0.33,0.00340761983861317,0.000478230123315937,"PASS","" +5,67,"posterior","Setting 1",0.2,0,0,0.196956580476606,0.266792720292757,0.536250699230637,0,0.197,0.267,0.536,0.0418256847015256,0.000250699230637252,"PASS","" +5,67,"predictive","Setting 1",0.2,0,0,0.117705013676267,0.180240008759576,0.702054977564157,0,0.118,0.18,0.702,0.0880303609859662,0.000294986323732593,"PASS","" +5,68,"posterior","Setting 2",0.2,0,0,0.148668083974115,0.288896293002515,0.56243562302337,0,0.149,0.289,0.562,0.0438107344181776,0.000435623023369858,"PASS","" +5,68,"predictive","Setting 2",0.2,0,0,0.0901404047448031,0.266268900260522,0.643590694994675,0,0.09,0.266,0.644,0.0150201338057843,0.000409305005325211,"PASS","" +5,69,"posterior","Setting 3",0.2,0,0,0.148277701614374,0.417679503483765,0.434042794901861,0,0.148,0.418,0.434,0.0897821128732492,0.00032049651623528,"PASS","" +5,69,"predictive","Setting 3",0.2,0,0,0.0756439997733611,0.266792629094864,0.657563371131775,0,0.076,0.267,0.658,0.0177644728977377,0.000436628868225486,"PASS","" +5,70,"posterior","Setting 1",0.2,0,0.4,0.853574855545872,0.00528486377961956,0.141140280674509,0,0.854,0.005,0.141,0.00639011223338716,0.000425144454128112,"PASS","" +5,70,"predictive","Setting 1",0.2,0,0.4,0.732608916971941,0.00287313932803469,0.264517943700025,0,0.733,0.003,0.265,0.0112961050341377,0.000482056299975442,"PASS","" +5,71,"posterior","Setting 2",0.2,0,0.4,0.843545861154088,0.00978988014187664,0.146664258704035,0,0.844,0.01,0.147,0.00058760257328933,0.000454138845911611,"PASS","" +5,71,"predictive","Setting 2",0.2,0,0.4,0.729552206913005,0.0035673642703261,0.266880428816669,0,0.73,0.004,0.267,0.0018673519259533,0.000447793086994608,"PASS","" +5,72,"posterior","Setting 3",0.2,0,0.4,0.814943274332474,0.0105071966172191,0.174549529050307,0,0.815,0.011,0.175,0.0418635722648186,0.000492803382780941,"PASS","" +5,72,"predictive","Setting 3",0.2,0,0.4,0.729340096735097,0.00522260601837079,0.265437297246532,0,0.729,0.005,0.265,0.103896453275428,0.000437297246532464,"PASS","" +5,73,"posterior","Setting 1",0.2,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,0.01245708288,0.000206593535999997,"PASS","" +5,73,"predictive","Setting 1",0.2,0,0.6,0.99718981632,1.6777216e-05,0.002793406464,0,0.997,0,0.003,1.6777216e-05,0.000206593535999997,"PASS","" +5,74,"posterior","Setting 2",0.2,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,74,"predictive","Setting 2",0.2,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,75,"posterior","Setting 3",0.2,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0.000301989888,0.00026726656000009,"PASS","" +5,75,"predictive","Setting 3",0.2,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,76,"posterior","Setting 1",0.2,0.2,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,76,"predictive","Setting 1",0.2,0.2,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,77,"posterior","Setting 2",0.2,0.2,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,77,"predictive","Setting 2",0.2,0.2,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,78,"posterior","Setting 3",0.2,0.2,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,78,"predictive","Setting 3",0.2,0.2,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,79,"posterior","Setting 1",0.2,0.2,-0.2,0.0378074140203466,0.662471619341471,0.299720966638182,0,0.038,0.662,0.3,0.0294777864804908,0.000471619341470997,"PASS","" +5,79,"predictive","Setting 1",0.2,0.2,-0.2,0.0135163425217346,0.485347215436785,0.50113644204148,0,0.014,0.485,0.501,0.00411365438435956,0.000483657478265429,"PASS","" +5,80,"posterior","Setting 2",0.2,0.2,-0.2,0.0128992947212501,0.717054523750071,0.270046181528679,0,0.013,0.717,0.27,0.0502844338849356,0.000100705278749882,"PASS","" +5,80,"predictive","Setting 2",0.2,0.2,-0.2,0.00415644031999628,0.662471619341471,0.333371940338533,0,0.004,0.662,0.333,0.0023139374794708,0.000471619341470997,"PASS","" +5,81,"posterior","Setting 3",0.2,0.2,-0.2,0.0123850881783262,0.808744411022095,0.178870500799579,0,0.012,0.809,0.179,0.00925706094417773,0.000385088178326227,"PASS","" +5,81,"predictive","Setting 3",0.2,0.2,-0.2,0.00364223377707239,0.663668318089554,0.332689448133373,0,0.004,0.664,0.333,0.00110912976568455,0.000357766222927612,"PASS","" +5,82,"posterior","Setting 1",0.2,0.2,0,0.266237106747109,0.266237106747109,0.467525786505782,0,0.266,0.266,0.468,0.0679150275891152,0.000474213494217723,"PASS","" +5,82,"predictive","Setting 1",0.2,0.2,0,0.14868103122491,0.148541996906618,0.702776971868472,0,0.149,0.149,0.703,0.00247474003319589,0.000458003093381648,"PASS","" +5,83,"posterior","Setting 2",0.2,0.2,0,0.148541996906618,0.276479000290964,0.574979002802417,0,0.149,0.276,0.575,0.0307245725248464,0.00047900029096426,"PASS","" +5,83,"predictive","Setting 2",0.2,0.2,0,0.0717987490690757,0.266237106747109,0.661964144183815,0,0.072,0.266,0.662,0.00371916363678835,0.000237106747108806,"PASS","" +5,84,"posterior","Setting 3",0.2,0.2,0,0.148232915646432,0.417677943510655,0.434089140842913,0,0.148,0.418,0.434,0.0770523290977294,0.00032205648934458,"PASS","" +5,84,"predictive","Setting 3",0.2,0.2,0,0.0714896678088889,0.266275018864365,0.662235313326746,0,0.071,0.266,0.662,0.0264030521049863,0.000489667808888955,"PASS","" +5,85,"posterior","Setting 1",0.2,0.2,0.4,0.930896674576718,0.00288861776328584,0.0662147076599959,0,0.931,0.003,0.066,0.00107859043828154,0.000214707659995914,"PASS","" +5,85,"predictive","Setting 1",0.2,0.2,0.4,0.853240561913545,0.000726747459896696,0.146032690626558,0,0.853,0.001,0.146,0.00256913696106625,0.000273252540103304,"PASS","" +5,86,"posterior","Setting 2",0.2,0.2,0.4,0.853069343654709,0.00356683771874748,0.143363818626544,0,0.853,0.004,0.143,0.00166751664259958,0.000433162281252523,"PASS","" +5,86,"predictive","Setting 2",0.2,0.2,0.4,0.730187092750875,0.00288861776328584,0.266924289485839,0,0.73,0.003,0.267,0.00867648648484259,0.000187092750874918,"PASS","" +5,87,"posterior","Setting 3",0.2,0.2,0.4,0.852213173898844,0.00973870238572066,0.138048123715435,0,0.852,0.01,0.138,0.123738420659699,0.000261297614279343,"PASS","" +5,87,"predictive","Setting 3",0.2,0.2,0.4,0.72933092299501,0.00289207659912847,0.267777000405862,0,0.729,0.003,0.268,0.0903090546615234,0.00033092299501003,"PASS","" +5,88,"posterior","Setting 1",0.2,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,88,"predictive","Setting 1",0.2,0.2,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,89,"posterior","Setting 2",0.2,0.2,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,89,"predictive","Setting 2",0.2,0.2,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,90,"posterior","Setting 3",0.2,0.2,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0.01245708288,0.00026726656000009,"PASS","" +5,90,"predictive","Setting 3",0.2,0.2,0.6,0.98473273344,0,0.01526726656,0,0.985,0,0.015,0.01245708288,0.00026726656000009,"PASS","" +5,91,"posterior","Setting 1",0.4,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,91,"predictive","Setting 1",0.4,0,-0.4,0.002176782336,0.77466271744,0.223160500224,0,0.002,0.775,0.223,0,0.000337282559999874,"PASS","" +5,92,"posterior","Setting 2",0.4,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,92,"predictive","Setting 2",0.4,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,93,"posterior","Setting 3",0.4,0,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,93,"predictive","Setting 3",0.4,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,94,"posterior","Setting 1",0.4,0,-0.2,0.0581782926849736,0.49141125267011,0.450410454644916,0,0.058,0.491,0.45,0.0234630517785334,0.00041125267010983,"PASS","" +5,94,"predictive","Setting 1",0.4,0,-0.2,0.0315206658961089,0.367404276635896,0.601075057467995,0,0.032,0.367,0.601,0.00505422136098811,0.000479334103891053,"PASS","" +5,95,"posterior","Setting 2",0.4,0,-0.2,0.0336556520199586,0.664182105434634,0.302162242545408,0,0.034,0.664,0.302,0.00911680070355172,0.000344347980041383,"PASS","" +5,95,"predictive","Setting 2",0.4,0,-0.2,0.0150435740734096,0.49141125267011,0.493545173256481,0,0.015,0.491,0.494,0.0256699624524861,0.000454826743519487,"PASS","" +5,96,"posterior","Setting 3",0.4,0,-0.2,0.0175015269129283,0.673568044566944,0.308930428520127,0,0.018,0.674,0.309,0.000117839649766153,0.000498473087071662,"PASS","" +5,96,"predictive","Setting 3",0.4,0,-0.2,0.0109160651461369,0.568643798107782,0.420440136746081,0,0.011,0.569,0.42,0.00775756063153408,0.000440136746080788,"PASS","" +5,97,"posterior","Setting 1",0.4,0,0,0.267657643155667,0.180794864574586,0.551547492269747,0,0.268,0.181,0.552,0.037583272148183,0.000452507730252849,"PASS","" +5,97,"predictive","Setting 1",0.4,0,0,0.153888018390469,0.131396508901987,0.714715472707544,0,0.154,0.131,0.715,0.0106571071551174,0.000396508901986531,"PASS","" +5,98,"posterior","Setting 2",0.4,0,0,0.196692285184361,0.288858391018358,0.514449323797281,0,0.197,0.289,0.514,0.0523863282323116,0.00044932379728102,"PASS","" +5,98,"predictive","Setting 2",0.4,0,0,0.0926181130611261,0.180794864574586,0.726587022364288,0,0.092,0.181,0.727,0.0636336248233438,0.000618113061126149,"EXPLAINED","kang2026_mc" +5,99,"posterior","Setting 3",0.4,0,0,0.139142347784939,0.329102393556965,0.531755258658096,0,0.139,0.329,0.532,0.00954641574719995,0.000244741341903998,"PASS","" +5,99,"predictive","Setting 3",0.4,0,0,0.0868790670146983,0.254834573550813,0.658286359434489,0,0.078,0.255,0.667,0.0301641919368214,0.00887906701469826,"EXPLAINED","kang2026_mc" +5,100,"posterior","Setting 1",0.4,0,0.4,0.868088773547859,0.00517916923663292,0.126732057215508,0,0.868,0.005,0.127,9.1652546009896e-05,0.000267942784491992,"PASS","" +5,100,"predictive","Setting 1",0.4,0,0.4,0.743098633123994,0.00188517701676956,0.255016189859236,0,0.773,0.002,0.225,0.0310229003985015,0.0300161898592365,"EXPLAINED","kang2026_mc" +5,101,"posterior","Setting 2",0.4,0,0.4,0.815448786223637,0.00981063265763076,0.174740581118732,0,0.815,0.01,0.175,0.0466903034500602,0.000448786223636977,"PASS","" +5,101,"predictive","Setting 2",0.4,0,0.4,0.705862187940337,0.00517916923663292,0.28895864282303,0,0.706,0.005,0.289,0.0776920895693593,0.000179169236632917,"PASS","" +5,102,"posterior","Setting 3",0.4,0,0.4,0.74017626591564,0.013339860948618,0.246483873135743,0,0.74,0.013,0.246,0.0335695566213674,0.000483873135742524,"PASS","" +5,102,"predictive","Setting 3",0.4,0,0.4,0.602176840533263,0.00751849136336169,0.390304668103375,0,0.602,0.008,0.39,0.0314352843809714,0.000481508636638308,"PASS","" +5,103,"posterior","Setting 1",0.4,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,103,"predictive","Setting 1",0.4,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0.01245708288,0.00026726656000009,"PASS","" +5,104,"posterior","Setting 2",0.4,0,0.6,0.98473273344,0.000318767104,0.014948499456,0,0.985,0,0.015,0,0.000318767104,"PASS","" +5,104,"predictive","Setting 2",0.4,0,0.6,0.94269007872,1.6777216e-05,0.057293144064,0,0.943,0,0.057,0.04204265472,0.000309921280000069,"PASS","" +5,105,"posterior","Setting 3",0.4,0,0.6,0.94269007872,0.000318767104,0.056991154176,0,0.943,0,0.057,0.04204265472,0.000318767104,"PASS","" +5,105,"predictive","Setting 3",0.4,0,0.6,0.94269007872,1.6777216e-05,0.057293144064,0,0.943,0,0.057,0,0.000309921280000069,"PASS","" +5,106,"posterior","Setting 1",0.4,0.4,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,106,"predictive","Setting 1",0.4,0.4,-0.4,0,0.77466271744,0.22533728256,0,0,0.775,0.225,0,0.000337282559999874,"PASS","" +5,107,"posterior","Setting 2",0.4,0.4,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0,0.000176782336000048,"PASS","" +5,107,"predictive","Setting 2",0.4,0.4,-0.4,0,0.980408958976,0.019591041024,0,0,0.917,0.083,0.063852281856,0.063408958976,"EXPLAINED","kang2026_mc" +5,108,"posterior","Setting 3",0.4,0.4,-0.4,0,1,0,0,0,1,0,0,0,"PASS","" +5,108,"predictive","Setting 3",0.4,0.4,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,109,"posterior","Setting 1",0.4,0.4,-0.2,0.0872184708042923,0.427799977329765,0.484981551865943,0,0.087,0.428,0.485,0.160616718556731,0.000218470804292326,"PASS","" +5,109,"predictive","Setting 1",0.4,0.4,-0.2,0.0382561760508778,0.309805911606452,0.65193791234267,0,0.038,0.31,0.652,0.0342293324945312,0.000256176050877771,"PASS","" +5,110,"posterior","Setting 2",0.4,0.4,-0.2,0.0128992947212501,0.663668318089554,0.323432387189195,0,0.013,0.664,0.323,0,0.000432387189195471,"PASS","" +5,110,"predictive","Setting 2",0.4,0.4,-0.2,0.00415644031999628,0.489735110906897,0.506108448773107,0,0.004,0.49,0.506,0.00670183294958247,0.000264889093103127,"PASS","" +5,111,"posterior","Setting 3",0.4,0.4,-0.2,0.00364223377707239,0.808744411022095,0.187613355200833,0,0.004,0.809,0.188,0,0.000386644799167196,"PASS","" +5,111,"predictive","Setting 3",0.4,0.4,-0.2,0.00113110776255526,0.662471619341471,0.336397272895974,0,0.002,0.662,0.335,0.000925591523632839,0.00139727289597358,"EXPLAINED","kang2026_mc" +5,112,"posterior","Setting 1",0.4,0.4,0,0.416522600193914,0.0902657075177903,0.493211692288296,0,0.417,0.09,0.493,0.193401156665096,0.000477399806086243,"PASS","" +5,112,"predictive","Setting 1",0.4,0.4,0,0.266275018864365,0.0714896678088889,0.662235313326746,0,0.266,0.063,0.671,0.0940089984339148,0.00876468667325403,"EXPLAINED","kang2026_mc" +5,113,"posterior","Setting 2",0.4,0.4,0,0.148541996906618,0.266275018864365,0.585182984229017,0,0.149,0.266,0.585,0,0.000458003093381648,"PASS","" +5,113,"predictive","Setting 2",0.4,0.4,0,0.0717987490690757,0.14868103122491,0.779520219706014,0,0.072,0.149,0.78,0.00385819795507983,0.000479780293985543,"PASS","" +5,114,"posterior","Setting 3",0.4,0.4,0,0.0714896678088889,0.417677943510655,0.510832388680456,0,0.071,0.418,0.511,0,0.000489667808888955,"PASS","" +5,114,"predictive","Setting 3",0.4,0.4,0,0.0296967466107592,0.266237106747109,0.704066146642132,0,0.03,0.266,0.704,0.00398403648802773,0.000303253389240792,"PASS","" +5,115,"posterior","Setting 1",0.4,0.4,0.4,0.971455809860228,0.000331418400475998,0.0282127717392958,0,0.971,0,0.028,0.0414095336219321,0.000455809860228307,"PASS","" +5,115,"predictive","Setting 1",0.4,0.4,0.4,0.930917427591774,0.000153884401286978,0.068928688006939,0,0.931,0,0.069,0.0388982780658712,0.000153884401286978,"PASS","" +5,116,"posterior","Setting 2",0.4,0.4,0.4,0.853069343654709,0.00289207659912847,0.144038579746163,0,0.853,0.003,0.144,0,0.000107923400871535,"PASS","" +5,116,"predictive","Setting 2",0.4,0.4,0.4,0.730187092750875,0.000731503522642145,0.269081403726483,0,0.73,0.001,0.269,0.00868124254758804,0.000268496477357855,"PASS","" +5,117,"posterior","Setting 3",0.4,0.4,0.4,0.72933092299501,0.00973870238572066,0.260930374619269,0,0.729,0.01,0.261,0,0.00033092299501003,"PASS","" +5,117,"predictive","Setting 3",0.4,0.4,0.4,0.567973957423989,0.00288861776328584,0.429137424812725,0,0.589,0.003,0.408,0.0208597227075839,0.0211374248127248,"EXPLAINED","kang2026_mc" +5,118,"posterior","Setting 1",0.4,0.4,0.6,0.999681232896,0,0.000318767104,0,1,0,0,0,0.000318767104000028,"PASS","" +5,118,"predictive","Setting 1",0.4,0.4,0.6,0.999983222784,0,1.6777216e-05,0,1,0,0,0,1.6777216000019e-05,"PASS","" +5,119,"posterior","Setting 2",0.4,0.4,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,119,"predictive","Setting 2",0.4,0.4,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,120,"posterior","Setting 3",0.4,0.4,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,120,"predictive","Setting 3",0.4,0.4,0.6,0.98473273344,0,0.01526726656,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,121,"posterior","Setting 1",0.8,0,-0.4,0.019591041024,0.56182177792,0.418587181056,0,0.02,0.562,0.419,0,0.000412818944000193,"PASS","" +5,121,"predictive","Setting 1",0.8,0,-0.4,0.019591041024,0.56182177792,0.418587181056,0,0.02,0.562,0.419,0.244444594176,0.000412818944000193,"PASS","" +5,122,"posterior","Setting 2",0.8,0,-0.4,0.002176782336,0.77466271744,0.223160500224,0,0.002,0.775,0.223,0,0.000337282559999874,"PASS","" +5,122,"predictive","Setting 2",0.8,0,-0.4,0.002176782336,0.77466271744,0.223160500224,0,0.002,0.775,0.223,0,0.000337282559999874,"PASS","" +5,123,"posterior","Setting 3",0.8,0,-0.4,0,0.91655667712,0.08344332288,0,0,0.917,0.083,0,0.000443322880000041,"PASS","" +5,123,"predictive","Setting 3",0.8,0,-0.4,0.002176782336,0.77466271744,0.223160500224,0,0.002,0.775,0.223,0,0.000337282559999874,"PASS","" +5,124,"posterior","Setting 1",0.8,0,-0.2,0.144991814058186,0.31171776177644,0.543290424165374,0,0.145,0.312,0.543,0.0474559690133312,0.000290424165374392,"PASS","" +5,124,"predictive","Setting 1",0.8,0,-0.2,0.0623600607791401,0.198523722995961,0.739116216224899,0,0.062,0.199,0.739,0.0592966627863485,0.000476277004039433,"PASS","" +5,125,"posterior","Setting 2",0.8,0,-0.2,0.0542635705170016,0.505263816498206,0.440472612984792,0,0.054,0.505,0.44,0.00486371494647191,0.000472612984792065,"PASS","" +5,125,"predictive","Setting 2",0.8,0,-0.2,0.0307997549672515,0.36806264838337,0.601137596649378,0,0.031,0.368,0.601,1.30936341546695e-05,0.000200245032748549,"PASS","" +5,126,"posterior","Setting 3",0.8,0,-0.2,0.0264339124491371,0.579615827885915,0.393950259664948,0,0.026,0.58,0.394,0.0746551647498789,0.000433912449137087,"PASS","" +5,126,"predictive","Setting 3",0.8,0,-0.2,0.0150687952432687,0.461384862032935,0.523546342723796,0,0.015,0.461,0.524,0.0723898446086002,0.000453657276203612,"PASS","" +5,127,"posterior","Setting 1",0.8,0,0,0.378147908050774,0.113332674013026,0.5085194179362,0,0.378,0.113,0.509,0.0113774262855626,0.000480582063799972,"PASS","" +5,127,"predictive","Setting 1",0.8,0,0,0.244831559482159,0.0583710763807835,0.696797364137057,0,0.275,0.068,0.657,0.0841379515217635,0.0397973641370574,"EXPLAINED","kang2026_mc" +5,128,"posterior","Setting 2",0.8,0,0,0.204676285918864,0.222473611535522,0.572850102545615,0,0.205,0.222,0.573,0.0554309985883231,0.000473611535521584,"PASS","" +5,128,"predictive","Setting 2",0.8,0,0,0.12911261809641,0.139381433166903,0.731505948736686,0,0.129,0.139,0.732,0.00282982856632691,0.000494051263313922,"PASS","" +5,129,"posterior","Setting 3",0.8,0,0,0.152300230779708,0.314701458037177,0.532998311183115,0,0.152,0.315,0.533,0.0547911434395149,0.000300230779708283,"PASS","" +5,129,"predictive","Setting 3",0.8,0,0,0.0803513674070918,0.218766391972711,0.700882240620198,0,0.08,0.219,0.701,0.0519164571366629,0.00035136740709181,"PASS","" +5,130,"posterior","Setting 1",0.8,0,0.4,0.883673523873423,0.00319828471467881,0.113128191411898,0,0.884,0.003,0.113,0.000672548661355717,0.000326476126576658,"PASS","" +5,130,"predictive","Setting 1",0.8,0,0.4,0.818752039603577,0.00102005351640943,0.180227906880014,0,0.777,0.001,0.222,0.0452251712832755,0.0417720931199859,"EXPLAINED","kang2026_mc" +5,131,"posterior","Setting 2",0.8,0,0.4,0.750049428691187,0.0116886651543804,0.238261906154433,0,0.75,0.012,0.238,0.0256655695855037,0.000311334845619635,"PASS","" +5,131,"predictive","Setting 2",0.8,0,0.4,0.604410723494486,0.00556994742990904,0.390019329075605,0,0.604,0.006,0.39,0.0605637907957295,0.000430052570090962,"PASS","" +5,132,"posterior","Setting 3",0.8,0,0.4,0.669353023620794,0.0231413708417157,0.30750560553749,0,0.669,0.023,0.308,0.000587572234771538,0.000494394462509817,"PASS","" +5,132,"predictive","Setting 3",0.8,0,0.4,0.530559249302991,0.0111749967778466,0.458265753919163,0,0.531,0.011,0.458,0.0932425524642198,0.000440750697009218,"PASS","" +5,133,"posterior","Setting 1",0.8,0,0.6,0.98473273344,0.000318767104,0.014948499456,0,0.985,0,0.015,0.000301989888,0.000318767104,"PASS","" +5,133,"predictive","Setting 1",0.8,0,0.6,0.98473273344,1.6777216e-05,0.015250489344,0,0.985,0,0.015,0,0.00026726656000009,"PASS","" +5,134,"posterior","Setting 2",0.8,0,0.6,0.94269007872,0.000318767104,0.056991154176,0,0.943,0,0.057,0,0.000318767104,"PASS","" +5,134,"predictive","Setting 2",0.8,0,0.6,0.94269007872,0.000318767104,0.056991154176,0,0.943,0,0.057,0.100902371328,0.000318767104,"PASS","" +5,135,"posterior","Setting 3",0.8,0,0.6,0.94269007872,0.00281018368,0.0544997376,0,0.943,0.003,0.054,0,0.000499737600000029,"PASS","" +5,135,"predictive","Setting 3",0.8,0,0.6,0.841787707392,0.000318767104,0.157893525504,0,0.842,0,0.158,0,0.000318767104,"PASS","" +5,136,"posterior","Setting 1",0.8,0.8,-0.4,0.002176782336,0.334791442432,0.663031775232,0,0.002,0.335,0.663,0,0.000208557567999812,"PASS","" +5,136,"predictive","Setting 1",0.8,0.8,-0.4,0.002176782336,0.158212292608,0.839610925056,0,0.002,0.158,0.84,0,0.00038907494400009,"PASS","" +5,137,"posterior","Setting 2",0.8,0.8,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,137,"predictive","Setting 2",0.8,0.8,-0.4,0,0.77466271744,0.22533728256,0,0,0.775,0.225,0,0.000337282559999874,"PASS","" +5,138,"posterior","Setting 3",0.8,0.8,-0.4,0,0.997823217664,0.002176782336,0,0,0.998,0.002,0.002176782336,0.000176782336000048,"PASS","" +5,138,"predictive","Setting 3",0.8,0.8,-0.4,0,0.980408958976,0.019591041024,0,0,0.98,0.02,0,0.000408958976000018,"PASS","" +5,139,"posterior","Setting 1",0.8,0.8,-0.2,0.191405176321072,0.0758661002175108,0.732728723461417,0,0.191,0.076,0.733,0,0.000405176321072009,"PASS","" +5,139,"predictive","Setting 1",0.8,0.8,-0.2,0.147962742393772,0.0277220471178675,0.824315210488361,0,0.148,0.028,0.824,0.0769617977461026,0.000315210488360584,"PASS","" +5,140,"posterior","Setting 2",0.8,0.8,-0.2,0.0128992947212501,0.518987764306787,0.468112940971963,0,0.013,0.519,0.468,0.0895875082737346,0.000112940971962683,"PASS","" +5,140,"predictive","Setting 2",0.8,0.8,-0.2,0.00415644031999628,0.309805911606452,0.686037648073552,0,0.004,0.31,0.686,0.00282814402239469,0.00019408839354812,"PASS","" +5,141,"posterior","Setting 3",0.8,0.8,-0.2,0.000841866438654976,0.808594823678928,0.190563309882417,0,0.001,0.809,0.191,0.000149587343166807,0.000436690117582961,"PASS","" +5,141,"predictive","Setting 3",0.8,0.8,-0.2,0.000841866438654976,0.662471619341471,0.336686514219874,0,0.001,0.662,0.337,0.000569009556478105,0.000471619341470997,"PASS","" +5,142,"posterior","Setting 1",0.8,0.8,0,0.582326795152158,0.00998307448540771,0.407690130362434,0,0.582,0.01,0.408,0,0.000326795152157833,"PASS","" +5,142,"predictive","Setting 1",0.8,0.8,0,0.442353686876522,0.00278765704266958,0.554858656080808,0,0.422,0.003,0.575,0.160262182983184,0.0203536868765223,"EXPLAINED","kang2026_mc" +5,143,"posterior","Setting 2",0.8,0.8,0,0.148541996906618,0.151155771258106,0.700302231835276,0,0.149,0.151,0.7,0.0161698654607912,0.000458003093381648,"PASS","" +5,143,"predictive","Setting 2",0.8,0.8,0,0.0717987490690757,0.0714896678088889,0.856711583122035,0,0.076,0.071,0.853,0.00402824489697508,0.00420125093092433,"EXPLAINED","kang2026_mc" +5,144,"posterior","Setting 3",0.8,0.8,0,0.029232732854535,0.417673204847842,0.553094062297623,0,0.029,0.418,0.553,4.73866281329832e-06,0.000326795152157888,"PASS","" +5,144,"predictive","Setting 3",0.8,0.8,0,0.029232732854535,0.266237106747109,0.704530160398356,0,0.023,0.266,0.711,0.0187537698842222,0.00646983960164382,"EXPLAINED","kang2026_mc" +5,145,"posterior","Setting 1",0.8,0.8,0.4,0.9902624505447,3.93845684403647e-06,0.00973361099845591,0,0.99,0,0.01,0,0.000266389001544088,"PASS","" +5,145,"predictive","Setting 1",0.8,0.8,0.4,0.975711026768109,4.61206863988391e-07,0.0242885120250274,0,0.976,0,0.024,0.0175022590361519,0.000288973231891365,"PASS","" +5,146,"posterior","Setting 2",0.8,0.8,0.4,0.853069343654709,0.000802868438227319,0.146127787907064,0,0.853,0.001,0.146,0.000403333882285728,0.000197131561772681,"PASS","" +5,146,"predictive","Setting 2",0.8,0.8,0.4,0.730187092750875,0.000153884401286978,0.269659022847838,0,0.73,0,0.27,0.00953265624070749,0.000340977152161859,"PASS","" +5,147,"posterior","Setting 3",0.8,0.8,0.4,0.56508367834279,0.00973754945529995,0.42517877220191,0,0.565,0.01,0.425,1.1529304207073e-06,0.000262450544700052,"PASS","" +5,147,"predictive","Setting 3",0.8,0.8,0.4,0.56508367834279,0.00288861776328584,0.432027703893924,0,0.565,0.003,0.432,0.17355500688712,0.000111382236714159,"PASS","" +5,148,"posterior","Setting 1",0.8,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,148,"predictive","Setting 1",0.8,0.8,0.6,1,0,0,0,1,0,0,0,0,"PASS","" +5,149,"posterior","Setting 2",0.8,0.8,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0,0.000189816319999996,"PASS","" +5,149,"predictive","Setting 2",0.8,0.8,0.6,0.99718981632,0,0.00281018368,0,0.997,0,0.003,0.01245708288,0.000189816319999996,"PASS","" +5,150,"posterior","Setting 3",0.8,0.8,0.6,0.94269007872,0,0.05730992128,0,0.943,0,0.057,1.6777216e-05,0.000309921280000069,"PASS","" +5,150,"predictive","Setting 3",0.8,0.8,0.6,0.94269007872,0,0.05730992128,0,0.943,0,0.057,0,0.000309921280000069,"PASS","" diff --git a/inst/validation/results/summary.md b/inst/validation/results/summary.md new file mode 100644 index 0000000..b14af67 --- /dev/null +++ b/inst/validation/results/summary.md @@ -0,0 +1,111 @@ +# Validation of BayesianQDM against published results + +Generated by `inst/validation/run_validation.R` with BayesianQDM 1.0.0. + +## Kang, Yamaguchi and Han (2026), Supplemental Tables 2 to 5 (one binary endpoint) + +| Table | Criterion | Checks | PASS | EXPLAINED | FAIL | Largest difference | +|---|---|---|---|---|---|---| +| 2 | posterior | 45 | 45 | 0 | 0 | 0.0005 | +| 2 | predictive | 45 | 34 | 11 | 0 | 0.0540 | +| 3 | posterior | 20 | 20 | 0 | 0 | 0.0005 | +| 4 | predictive | 20 | 15 | 5 | 0 | 0.0118 | +| 5 | posterior | 150 | 150 | 0 | 0 | 0.0005 | +| 5 | predictive | 150 | 126 | 24 | 0 | 0.0634 | + +Largest probability of a Miss decision: 0. + +## Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted), Table 3 and Supplemental Tables S1 and S2 (two binary endpoints) + +| Table | Checks | PASS | EXPLAINED | FAIL | Not evaluable (NE) | Largest difference | Largest sensitivity | +|---|---|---|---|---|---|---|---| +| Table 3 | 48 | 2 | 46 | 0 | 2 | 0.0094 | 0.0738 | +| Supplemental Table S1 | 48 | 3 | 45 | 0 | 3 | 0.0183 | 0.0749 | +| Supplemental Table S2 | 48 | 3 | 45 | 0 | 3 | 0.0087 | 0.0604 | + +One check per scenario (largest difference of Go, Gray and NoGo). The scenarios that the article reports as not evaluable (NE) are PASS when the probabilities of BayesianQDM are NA (correlation outside the feasible range). +Largest probability of a Miss decision: 2.59e-05. + +## Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted), Table 4 and Supplemental Table S3 (two continuous endpoints) + +| Table | Checks | PASS | EXPLAINED | FAIL | INFO | Largest difference (except INFO) | Largest difference / tolerance | +|---|---|---|---|---|---|---|---| +| Table 4 | 48 | 0 | 48 | 0 | 0 | 0.0135 | 0.20 | +| Supplemental Table S3 | 48 | 0 | 32 | 0 | 16 | 0.0124 | 0.27 | + +One check per scenario (Go, NoGo and Gray), with 10000 simulated studies and the moment-matching approximation. For Supplemental Table S3 the verdict uses the predictive scale of the article; the probabilities of BayesianQDM (corrected scale) are in the columns package_Go, package_NoGo and package_Gray of the details. + +INFO rows (published; computed with the scale of the article; +BayesianQDM), Go / NoGo / Gray: + +| Table | Panel | theta1 | theta2 | Published | Article scale | BayesianQDM | +|---|---|---|---|---|---|---| +| S3 | c | 0.0 | 0 | 0.0498 / 0.5705 / 0.3797 | 0.0833 / 0.5643 / 0.3524 | 0.0579 / 0.2850 / 0.6571 | +| S3 | c | 1.5 | 0 | 0.0917 / 0.3493 / 0.5590 | 0.1262 / 0.3630 / 0.5108 | 0.0952 / 0.1483 / 0.7565 | +| S3 | c | 3.0 | 0 | 0.1017 / 0.1464 / 0.7519 | 0.1412 / 0.1507 / 0.7081 | 0.1184 / 0.0460 / 0.8356 | +| S3 | c | 4.5 | 0 | 0.0969 / 0.0427 / 0.8604 | 0.1433 / 0.0371 / 0.8196 | 0.1258 / 0.0089 / 0.8653 | +| S3 | c | 0.0 | 1 | 0.0881 / 0.3376 / 0.5743 | 0.1386 / 0.3342 / 0.5272 | 0.1047 / 0.1346 / 0.7607 | +| S3 | c | 1.5 | 1 | 0.1979 / 0.2584 / 0.5437 | 0.2877 / 0.2633 / 0.4490 | 0.2243 / 0.0863 / 0.6894 | +| S3 | c | 3.0 | 1 | 0.2941 / 0.1302 / 0.5757 | 0.3880 / 0.1334 / 0.4786 | 0.3241 / 0.0337 / 0.6422 | +| S3 | c | 4.5 | 1 | 0.3159 / 0.0370 / 0.6471 | 0.4169 / 0.0360 / 0.5471 | 0.3711 / 0.0080 / 0.6209 | +| S3 | c | 0.0 | 2 | 0.0998 / 0.1107 / 0.7895 | 0.1528 / 0.1147 / 0.7325 | 0.1293 / 0.0320 / 0.8387 | +| S3 | c | 1.5 | 2 | 0.2787 / 0.1031 / 0.6182 | 0.3645 / 0.1076 / 0.5279 | 0.3162 / 0.0264 / 0.6574 | +| S3 | c | 3.0 | 2 | 0.4879 / 0.0722 / 0.4399 | 0.5881 / 0.0750 / 0.3369 | 0.5173 / 0.0134 / 0.4693 | +| S3 | c | 4.5 | 2 | 0.6066 / 0.0275 / 0.3659 | 0.6982 / 0.0280 / 0.2738 | 0.6389 / 0.0048 / 0.3563 | +| S3 | c | 0.0 | 3 | 0.1068 / 0.0236 / 0.8696 | 0.1538 / 0.0205 / 0.8257 | 0.1334 / 0.0043 / 0.8623 | +| S3 | c | 1.5 | 3 | 0.2976 / 0.0203 / 0.6821 | 0.3789 / 0.0200 / 0.6011 | 0.3441 / 0.0040 / 0.6519 | +| S3 | c | 3.0 | 3 | 0.5664 / 0.0189 / 0.4147 | 0.6555 / 0.0183 / 0.3262 | 0.6070 / 0.0026 / 0.3904 | +| S3 | c | 4.5 | 3 | 0.7813 / 0.0119 / 0.2068 | 0.8457 / 0.0103 / 0.1440 | 0.7984 / 0.0011 / 0.2005 | + +## Published numbers for one continuous endpoint + +| Source | Checks | PASS | EXPLAINED | FAIL | INFO | Largest difference (except INFO) | +|---|---|---|---|---|---|---| +| Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2 | 4 | 4 | 0 | 0 | 0 | 0.0000 | +| Huang et al. (submitted), Table 3 | 27 | 22 | 5 | 0 | 0 | 0.0057 | +| Kang et al. (2026), Table 4 | 12 | 0 | 0 | 0 | 12 | - | + +Numbers that are not PASS (except INFO): + +| Source | Quantity | Setting | Method | Published | Computed | Verdict | +|---|---|---|---|---|---|---| +| Huang et al. (submitted), Table 3 | Treatment posterior SD | a0 = 0.25 | NI | 0.589 | 0.5885 | EXPLAINED | +| Huang et al. (submitted), Table 3 | Effect posterior SD | a0 = 0.25 | NI | 0.870 | 0.8691 | EXPLAINED | +| Huang et al. (submitted), Table 3 | 95% credible interval, lower | a0 = 0.25 | NI | -4.980 | -4.9743 | EXPLAINED | +| Huang et al. (submitted), Table 3 | 95% credible interval, lower | a0 = 0.5 | NI | -4.710 | -4.7047 | EXPLAINED | +| Huang et al. (submitted), Table 3 | Treatment posterior SD | a0 = 0.75 | NI | 0.448 | 0.4474 | EXPLAINED | + +INFO rows (published and computed values): + +| Source | Quantity | Setting | Published | Computed | +|---|---|---|---|---| +| Kang et al. (2026), Table 4 | P(theta > TV | data) | PoC data only | 0.499 | 0.5000 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | PoC data only | 0.999 | 0.9122 | +| Kang et al. (2026), Table 4 | P(theta > TV | data) | External treatment data | 0.598 | 0.5155 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | External treatment data | 0.999 | 0.9277 | +| Kang et al. (2026), Table 4 | P(theta > TV | data) | External treatment and control data, a0c = 0.2 | 0.620 | 0.5179 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | External treatment and control data, a0c = 0.2 | 1.000 | 0.9533 | +| Kang et al. (2026), Table 4 | P(theta > TV | data) | External treatment and control data, a0c = 0.4 | 0.628 | 0.5192 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | External treatment and control data, a0c = 0.4 | 1.000 | 0.9636 | +| Kang et al. (2026), Table 4 | P(theta > TV | data) | External treatment and control data, a0c = 0.6 | 0.636 | 0.5201 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | External treatment and control data, a0c = 0.6 | 1.000 | 0.9688 | +| Kang et al. (2026), Table 4 | P(theta > TV | data) | External treatment and control data, a0c = 0.8 | 0.640 | 0.5207 | +| Kang et al. (2026), Table 4 | P(theta > MAV | data) | External treatment and control data, a0c = 0.8 | 1.000 | 0.9719 | + +Total: 713 checks, 424 PASS, 261 EXPLAINED, 0 FAIL, 28 INFO. + +Registered reasons: +- `kang2026_mc`: the article computes the posterior predictive probability by Monte Carlo simulation. The difference is at most the probability of the outcomes whose exact predictive probability is within 0.01 of a threshold (plus 0.0005 for rounding), whose decisions Monte Carlo error can change. +- `bivariate_mc`: the article and BayesianQDM estimate the posterior probabilities of the regions by Monte Carlo simulation. The difference is at most the probability of the outcomes whose posterior probability of the Go or NoGo region is within 0.01 of its threshold (plus 0.00005 for rounding), whose decisions Monte Carlo error can change. +- `bivariate_cont_mc`: the article estimates the decision probabilities of two continuous endpoints by simulating studies (10000 assumed; the number is not stated) and the region probabilities by Monte Carlo simulation. The difference is at most 4 standard errors of both simulations plus the probability of the studies whose probability of the Go or NoGo region is within 0.01 of its threshold (plus 0.00005 for rounding). +- `c1_predictive_scale`: the article computes the posterior predictive probabilities of two continuous endpoints with the scale ((1 + kappa) / kappa) Lambda / ((nu - 1) m) for the mean of m future subjects, which BayesianQDM corrects to (1 / kappa + 1 / m) Lambda / (nu - 1). With the scale of the article the published values are reproduced within the tolerance of `bivariate_cont_mc`. +- `s3_rho08`: Supplemental Table S3, panel (c) (rho = 0.8), is not reproduced from the stated thresholds with either scale (for example, the probability of Go under the null scenario is 0.08 to 0.09 with the scale of the article and about 0.06 with the corrected scale, instead of 0.0498). Monte Carlo draws shared across the simulated studies, as in version 0.1.0, do not explain the difference. Reported for information. +- `huang_mc`: the article summarizes Monte Carlo samples of the posterior distributions (its Section 6.3); the difference from the exact value is at most 0.01 beyond rounding. +- `kang2026_table4`: the case study of Kang et al. (2026, Section 6) is not reproduced from the inputs stated in the article (vague priors, standard deviations 25, 30 and 20); the article used Markov chain Monte Carlo sampling. Reported for information until the inputs are clarified. + +Self-check: shifting the published Go probabilities by 0.02 gives FAIL in 215 of 215 posterior rows (PASS). +Self-check: shifting the published Go probabilities of two binary endpoints by 0.15 gives FAIL in 136 of 136 evaluable scenarios (PASS). +Self-check: shifting the published Go probabilities of two continuous endpoints by 0.2 gives FAIL in 80 of 80 scenarios other than INFO (PASS). +Self-check: shifting the published continuous numbers by 0.05 gives FAIL in 31 of 31 rows other than INFO (PASS). + +Details: `inst/validation/results/kang2026_binary.csv`, `inst/validation/results/yamaguchi_binary2.csv`, `inst/validation/results/yamaguchi_continuous2.csv` and `inst/validation/results/continuous.csv`. diff --git a/inst/validation/results/yamaguchi_binary2.csv b/inst/validation/results/yamaguchi_binary2.csv new file mode 100644 index 0000000..31c597b --- /dev/null +++ b/inst/validation/results/yamaguchi_binary2.csv @@ -0,0 +1,145 @@ +"table","panel","rho","gamma_go","gamma_nogo","theta1","theta2","Go","NoGo","Gray","Miss","pub_Go","pub_NoGo","pub_Gray","sensitivity","max_abs_diff","verdict","reason" +"3","a",0,0.263,0.347,0,0,0.0508054773512665,0.632188873471964,0.31698567981987,1.99693569064227e-05,0.0495,0.6325,0.318,0.0161319640028639,0.00130547735126649,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.1,0,0.118550587973894,0.449336003052154,0.432089039932556,2.43690414039319e-05,0.117,0.4506,0.4324,0.0228798090645508,0.00155058797389361,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.15,0,0.155120956100425,0.360050559460057,0.484805674808214,2.28096313121382e-05,0.1522,0.3579,0.4899,0.0243408741018873,0.00509432519178599,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.25,0,0.224384401859142,0.207838119772017,0.567761257309789,1.62210590584174e-05,0.2263,0.2063,0.5674,0.0242722456988841,0.00191559814085784,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0,0.1,0.103118718621965,0.459347833985586,0.437514989416386,1.84579760711704e-05,0.1031,0.46,0.4369,0.0225953739433829,0.000652166014413924,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.1,0.1,0.226068242623858,0.319898405235955,0.454007493357761,2.58587824331476e-05,0.2261,0.318,0.4559,0.0289438263661478,0.00189840523595547,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.15,0.1,0.288334054123178,0.253896295266063,0.457743742022937,2.59085878297155e-05,0.2881,0.251,0.4609,0.0292070805978605,0.00315625797706337,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.25,0.1,0.399555118929167,0.143937450574843,0.456486586179189,2.08443168073122e-05,0.3985,0.1429,0.4586,0.0257992420369968,0.00211341382081076,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0,0.15,0.131581308580502,0.373576554071635,0.494826370159778,1.5767188092169e-05,0.1314,0.3718,0.4968,0.0247335630024997,0.0019736298402217,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.1,0.15,0.28096977643907,0.257551233811361,0.461455233167544,2.3756582032036e-05,0.2819,0.2573,0.4608,0.0298783455406864,0.000930223560930143,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.15,0.15,0.354505288767759,0.203435058208218,0.442035124720448,2.45283035821557e-05,0.3537,0.1999,0.4464,0.0294425827575503,0.00436487527955187,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.25,0.15,0.482423120691731,0.114278424500054,0.403277777000217,2.0677808004516e-05,0.4822,0.113,0.4048,0.0248307245496898,0.00152222299978255,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0,0.25,0.187408681607357,0.222855662123388,0.589725996468712,9.65980055173391e-06,0.1865,0.2228,0.5907,0.0279269253685521,0.00097400353128807,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.1,0.25,0.382152582463514,0.15061134687792,0.46721938030748,1.66903510946626e-05,0.3806,0.1503,0.4691,0.0293360823264778,0.00188061969252046,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.15,0.25,0.473210257157301,0.117827872699609,0.408943785565567,1.80845775298098e-05,0.4739,0.1182,0.4079,0.0274531922729826,0.00104378556556706,"EXPLAINED","bivariate_mc" +"3","a",0,0.263,0.347,0.25,0.25,0.624067016910962,0.0649701132458781,0.310946558221577,1.6311621589182e-05,0.6241,0.0639,0.312,0.021218164522048,0.00107011324587808,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0,0,0.048875951210841,0.599155726510207,0.351968322278959,0,0.0497,0.5998,0.3505,0.023270232844927,0.00146832227895916,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.1,0,0.0977144513119547,0.427314646724275,0.474970901963779,0,0.0968,0.4273,0.4759,0.0285050155364497,0.000929098036220821,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.15,0,0.120826934503812,0.346235379767137,0.53293768572906,0,0.1206,0.3476,0.5318,0.0285958993305333,0.00136462023286305,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.25,0,0.159371804264495,0.207459564417928,0.633168631317584,0,0.1604,0.2061,0.6335,0.0281473511357867,0.00135956441792798,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0,0.1,0.0863609918748599,0.43554621564722,0.478092792477929,0,0.0859,0.4331,0.481,0.0262227326848664,0.00290720752207096,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.1,0.1,0.180704187548919,0.305345271394531,0.513950541056559,0,0.1808,0.3022,0.517,0.0340156247904255,0.00314527139453069,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.15,0.1,0.226995312447467,0.246022530150661,0.526982157401879,0,0.2267,0.2441,0.5292,0.0353766217183409,0.00221784259812086,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.25,0.1,0.306842367354325,0.146683121182989,0.546474511462694,0,0.3068,0.1474,0.5458,0.0373692619841355,0.000716878817011407,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0,0.15,0.104049516961851,0.356956385300514,0.538994097737643,0,0.1033,0.3607,0.536,0.0255300593809382,0.00374361469948598,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.1,0.15,0.221471741489302,0.248673108473842,0.529855150036863,0,0.2226,0.2489,0.5285,0.0340512367422382,0.00135515003686348,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.15,0.15,0.27971172422279,0.199894789529665,0.520393486247552,0,0.2806,0.1995,0.5199,0.0359426460790291,0.000888275777209679,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.25,0.15,0.381004479459959,0.118880824818858,0.50011469572119,0,0.3814,0.1185,0.5001,0.0387702884796123,0.000395520540040606,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0,0.25,0.133615849580341,0.219094333622694,0.647289816796972,0,0.1337,0.2179,0.6484,0.0221836409207656,0.00119433362269408,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.1,0.25,0.292613268517853,0.151526276080384,0.55586045540177,0,0.2938,0.1519,0.5543,0.0319225263512268,0.00156045540177008,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.15,0.25,0.372608168813746,0.121445871062186,0.505945960124076,0,0.3743,0.1222,0.5035,0.0345186141896375,0.00244596012407572,"EXPLAINED","bivariate_mc" +"3","b",0.3,0.38,0.454,0.25,0.25,0.512746115067195,0.0719797808600399,0.415274104072774,0,0.514,0.0716,0.4144,0.0375276313795272,0.00125388493280543,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0,0,0.0489528844314039,0.554754449346494,0.396292666222112,0,0.0496,0.5604,0.39,0.0578123125444658,0.00629266622211183,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.1,0,0.0963569635128447,0.402646487077789,0.500996549409375,0,0.0978,0.4053,0.4969,0.0691735626638836,0.00409654940937498,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.15,0,0.120762837756787,0.328708770647702,0.550528391595519,0,0.1207,0.324,0.5553,0.0738049965166227,0.00477160840448099,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.25,0,0.163624790269947,0.19977782370908,0.636597386020981,0,0.1637,0.193,0.6433,0.0725622082622142,0.00677782370907998,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0,0.1,0.0871507952077907,0.39498416574329,0.517865039048928,0,0.0877,0.3964,0.5159,0.0693921336961245,0.00196503904892842,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.1,0.1,0.169341617999738,0.291790540392296,0.538867841607975,0,0.1708,0.2925,0.5367,0.0662868761703634,0.00216784160797523,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.15,0.1,0.211612394983613,0.239961768755825,0.548425836260572,0,0.2177,0.2433,0.539,0.0666538310861865,0.00942583626057159,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.25,0.1,0.290305771446497,0.147015485717037,0.562678742836474,0,0.2932,0.1463,0.5605,0.0625187129226984,0.00289422855350252,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0,0.15,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"3","c",0.6,0.513,0.511,0.1,0.15,0.207115356607267,0.238826270200497,0.554058373192245,0,0.2102,0.2438,0.546,0.0656159581273183,0.00805837319224467,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.15,0.15,0.258306768542536,0.197994159091092,0.543699072366379,0,0.2647,0.1992,0.5361,0.0650065280540804,0.0075990723663788,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.25,0.15,0.353700426778081,0.123011543171056,0.523288030050872,0,0.3568,0.1229,0.5203,0.0604084029468467,0.00309957322191878,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0,0.25,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"3","c",0.6,0.513,0.511,0.1,0.25,0.277791535078114,0.144633370704264,0.577575094217632,0,0.2824,0.1441,0.5735,0.0594731286871856,0.00460846492188616,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.15,0.25,0.346426149474853,0.122585671240395,0.530988179284761,0,0.3485,0.1235,0.528,0.0589624386138288,0.00298817928476058,"EXPLAINED","bivariate_mc" +"3","c",0.6,0.513,0.511,0.25,0.25,0.471477500468975,0.0796139847316533,0.448908514799381,0,0.4765,0.0814,0.4421,0.0559660853817702,0.00680851479938138,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0,0,0.0505266294564777,0.627809031518647,0.321664339024876,0,0.0481,0.635,0.3169,0.0635966967070887,0.00719096848135348,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.1,0,0.108154577646763,0.446861487089017,0.444983935264221,0,0.1057,0.4537,0.4406,0.06534464029596,0.00683851291098309,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.15,0,0.141275236089644,0.361094110970044,0.497630652940312,0,0.1394,0.3666,0.494,0.063812590762023,0.00550588902995597,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.25,0,0.20943653913092,0.213737548618625,0.576825912250456,0,0.207,0.2169,0.5761,0.0573685658991023,0.00316245138137461,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0,0.15,0.140848383409043,0.377637559745493,0.481514056845465,0,0.1408,0.3776,0.4816,0.0748613783300471,8.59431545350287e-05,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.1,0.15,0.270033780038196,0.252939396925473,0.477026823036332,0,0.2718,0.2542,0.474,0.0708075060053342,0.00302682303633195,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.15,0.15,0.337148690630839,0.198561282973197,0.464290026395965,0,0.3326,0.198,0.4694,0.0666701607528367,0.00510997360403476,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.25,0.15,0.463167922720332,0.111212733554719,0.42561934372495,0,0.4638,0.1119,0.4243,0.0567665513873984,0.00131934372494991,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0,0.25,0.203588198557587,0.23163703103672,0.564774770405694,0,0.2071,0.2339,0.559,0.0667961546346173,0.0057747704056943,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.1,0.25,0.371500454938153,0.149729840947709,0.478769704114139,0,0.3716,0.1504,0.478,0.0623487777404316,0.000769704114138792,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.15,0.25,0.454293466099813,0.115527956813878,0.43017857708631,0,0.4552,0.1175,0.4273,0.0580282878204244,0.00287857708630979,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.25,0.25,0.602046724228459,0.0625630776217204,0.335390198149821,0,0.602,0.0636,0.3344,0.0476787655919921,0.00103692237827961,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0,0.35,0.258754489717948,0.122983081531619,0.618262428750434,0,0.2552,0.1241,0.6207,0.0576536098740469,0.00355448971794808,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.1,0.35,0.454017316794625,0.0768924333667043,0.469090249838671,0,0.4505,0.0787,0.4708,0.0531329579080932,0.00351731679462508,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.15,0.35,0.546185213517555,0.0583708353282609,0.395443951154185,0,0.5482,0.058,0.3938,0.0488604357572792,0.00201478648244546,"EXPLAINED","bivariate_mc" +"S1","a",0,0.453,0.229,0.25,0.35,0.703508275429989,0.0306105645358646,0.265881160034147,0,0.7054,0.0301,0.2645,0.0384218411361869,0.00189172457001063,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0,0,0.0541964928080421,0.581559300264742,0.364244206927217,0,0.0499,0.5839,0.3662,0.0586336904573658,0.00429649280804214,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.1,0,0.0995175136690618,0.411712096723787,0.488770389607152,0,0.0971,0.4098,0.4931,0.0601050860178211,0.00432961039284796,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.15,0,0.122980117485695,0.332413690721482,0.544606191792823,0,0.1224,0.3292,0.5484,0.0567920835436125,0.00379380820717679,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.25,0,0.167501876180621,0.197457203532342,0.635040920287038,0,0.1667,0.1958,0.6375,0.0466591617968647,0.00245907971296233,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0,0.15,0.125621722992323,0.356565083414022,0.517813193593657,0,0.1202,0.3557,0.5241,0.051988722042241,0.00628680640634338,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.1,0.15,0.23653123240306,0.248471561839308,0.514997205757633,0,0.2279,0.2479,0.5242,0.0543725499698188,0.00920279424236725,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.15,0.15,0.293365608032469,0.199616488058591,0.507017903908941,0,0.2904,0.1999,0.5097,0.0523453153304094,0.00296560803246931,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.25,0.15,0.399421469113767,0.117982251059838,0.482596279826395,0,0.3938,0.1172,0.489,0.0447540660065128,0.0064037201736048,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0,0.25,0.164346207886922,0.224500510987961,0.611153281125118,0,0.1619,0.2233,0.6148,0.0411363375135824,0.00364671887488222,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.1,0.25,0.313428988080687,0.155579130510851,0.530991881408463,0,0.3076,0.1551,0.5373,0.0442524162750415,0.00630811859153713,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.15,0.25,0.388960676720766,0.124838207330293,0.486201115948943,0,0.3864,0.1254,0.4882,0.0434374480843782,0.00256067672076571,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.25,0.25,0.526931502066821,0.0737999421472172,0.399268555785962,0,0.5228,0.0733,0.4039,0.0383567082120202,0.00463144421403777,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0,0.35,0.191894913822944,0.123617380445566,0.684487705731491,0,0.1902,0.1262,0.6836,0.0301967151365378,0.00258261955443403,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.1,0.35,0.370605672078786,0.0854731370723816,0.543921190848834,0,0.3693,0.0838,0.5469,0.032911073476772,0.002978809151166,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.15,0.35,0.460361995806535,0.0686079005954067,0.471030103598059,0,0.4555,0.0688,0.4757,0.0326807190371806,0.00486199580653535,"EXPLAINED","bivariate_mc" +"S1","b",0.3,0.537,0.282,0.25,0.35,0.621046245566851,0.0406886355299654,0.338265118903185,0,0.6175,0.0404,0.3421,0.0294225979402999,0.0038348810968149,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0,0,0.0501289122000771,0.535626841080355,0.41424424671957,0,0.0476,0.5199,0.4325,0.0422250729807346,0.01825575328043,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.1,0,0.088740963003183,0.379222132741897,0.532036904254922,0,0.0892,0.3773,0.5335,0.0311553338149302,0.00192213274189662,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.15,0,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S1","c",0.6,0.62,0.337,0.25,0,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S1","c",0.6,0.62,0.337,0,0.15,0.114341166624261,0.335857841957289,0.549800991418451,0,0.1143,0.3271,0.5586,0.0613470999356248,0.00879900858154925,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.1,0.15,0.208639484411345,0.243141355771761,0.548219159816896,0,0.2086,0.2434,0.548,0.0506846917426667,0.000258644228238541,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.15,0.15,0.256896934568822,0.199919697458857,0.543183367972323,0,0.2533,0.1996,0.5471,0.0451354875871611,0.00391663202767689,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.25,0.15,0.345291654749088,0.12467229119167,0.530036054059244,0,0.3449,0.1244,0.5307,0.0333670945842223,0.00066394594075625,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0,0.25,0.14836933827612,0.21295610538885,0.638674556335032,0,0.1489,0.226,0.6251,0.0592813225722407,0.0135745563350321,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.1,0.25,0.27482415056679,0.157094718892616,0.568081130540595,0,0.2771,0.1603,0.5626,0.0520471564790335,0.00548113054059529,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.15,0.25,0.340579507959249,0.130498120760465,0.528922371280288,0,0.3421,0.1278,0.5301,0.0480265376059881,0.00269812076046513,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.25,0.25,0.463315052008772,0.0832144491831528,0.453470498808077,0,0.4637,0.0844,0.4519,0.0390971641065112,0.00157049880807669,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0,0.35,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S1","c",0.6,0.62,0.337,0.1,0.35,0.322405353434137,0.088934782673873,0.588659863891991,0,0.3236,0.0887,0.5877,0.0449198890852167,0.00119464656586271,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.15,0.35,0.402016821813274,0.0748121731449776,0.523171005041751,0,0.4079,0.0785,0.5136,0.0428395656720462,0.00957100504175123,"EXPLAINED","bivariate_mc" +"S1","c",0.6,0.62,0.337,0.25,0.35,0.551497329694997,0.0489483190741024,0.399554351230901,0,0.5549,0.0508,0.3943,0.0371495175327307,0.00525435123090129,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0,0,0.0468002018652297,0.599125302558642,0.354074492905831,2.67029682393842e-09,0.0483,0.5986,0.3531,0.0399054419798548,0.0014997981347703,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.1,0,0.0899444450514266,0.436671470045556,0.473384076967798,7.93522014942597e-09,0.091,0.428,0.481,0.0510638901303816,0.0086714700455558,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.15,0,0.113968672871742,0.360163221609204,0.525868094580056,1.09389986938718e-08,0.1184,0.3621,0.5195,0.0523446637883663,0.00636809458005627,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.25,0,0.1643200338075,0.226882436335976,0.608797514499978,1.53565478588932e-08,0.167,0.2276,0.6054,0.0485533953614157,0.00339751449997794,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0,0.15,0.136207106199327,0.353570118469923,0.510222755624702,1.97060477249905e-08,0.1321,0.3547,0.5132,0.0379602778679817,0.00410710619932733,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.1,0.15,0.242617369331213,0.243360100254782,0.514022471738916,5.86750899008581e-08,0.2359,0.2438,0.5203,0.0460964100098978,0.0067173693312127,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.15,0.15,0.296918273851136,0.195174662640247,0.50790698252515,8.09834681174817e-08,0.2943,0.1979,0.5078,0.0463012928287123,0.00272533735975297,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.25,0.15,0.400132510892367,0.116355696068915,0.483511679003392,1.14035326187919e-07,0.3983,0.1187,0.483,0.0415032281784897,0.00234430393108488,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0,0.25,0.199074800427585,0.220769219613521,0.580155946253381,3.37055137336344e-08,0.195,0.2209,0.5841,0.0319443295298937,0.00407480042758485,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.1,0.25,0.341486007954201,0.147526054359593,0.510987837142098,1.00544108112791e-07,0.3364,0.1479,0.5157,0.0372191739614004,0.00508600795420094,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.15,0.25,0.411269109460829,0.116578784909373,0.472151966702038,1.3892776120134e-07,0.4102,0.1174,0.4724,0.0367719417784872,0.00106910946082861,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.25,0.25,0.538141438110971,0.0674453988348155,0.394412966868515,1.9618569908958e-07,0.5366,0.0684,0.395,0.0319029990408652,0.00154143811097107,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0,0.35,0.255367053223891,0.122787689664848,0.621845217282377,3.98288851107841e-08,0.2536,0.1234,0.623,0.0254924601318143,0.00176705322389115,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.1,0.35,0.424218179477907,0.0800351648365777,0.495746536570533,1.19114983307653e-07,0.4174,0.0801,0.5025,0.0280715451131803,0.00681817947790653,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.15,0.35,0.504229553559441,0.0624526770612462,0.433317604534097,1.64845215860558e-07,0.5008,0.0631,0.4361,0.0270658205630022,0.00342955355944141,"EXPLAINED","bivariate_mc" +"S2","a",0,0.308,0.44,0.25,0.35,0.644589586301865,0.0351988004597092,0.320211379540238,2.33698189105908e-07,0.643,0.0353,0.3217,0.0223486166117504,0.00158958630186479,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0,0,0.0504282471916445,0.531166936746409,0.418404816061948,0,0.0496,0.5305,0.4199,0.0287690624487929,0.00149518393805242,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.1,0,0.0856774565390088,0.36745927964808,0.546863263812912,0,0.0858,0.3665,0.5477,0.0317158359331969,0.000959279648079958,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.15,0,0.103064189477181,0.295165795495507,0.601770015027312,0,0.1052,0.2961,0.5987,0.0330279870191525,0.0030700150273123,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.25,0,0.135806628932017,0.175715121257832,0.688478249810152,0,0.1401,0.1762,0.6837,0.0374277928969,0.00477824981015162,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0,0.15,0.125413593693279,0.355740761870935,0.518845644435788,0,0.1234,0.3557,0.5209,0.0359974420223061,0.00205435556421207,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.1,0.15,0.21892391086672,0.24776678408455,0.533309305048731,0,0.2226,0.2479,0.5295,0.0422093418635839,0.00380930504873123,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.15,0.15,0.26514930036357,0.20015450474046,0.534696194895972,0,0.2665,0.1999,0.5336,0.0443865896256012,0.00135069963642998,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.25,0.15,0.35066723319222,0.121100008756028,0.528232758051753,0,0.3519,0.1186,0.5295,0.0494599286133127,0.00250000875602759,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0,0.25,0.171613021949173,0.239926424796711,0.588460553254117,0,0.1729,0.2413,0.5858,0.0442050759989649,0.00266055325411674,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.1,0.25,0.300660004995922,0.168196848861959,0.531143146142121,0,0.3002,0.1683,0.5315,0.049641616760429,0.000460004995922247,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.15,0.25,0.364042521001607,0.13645463131812,0.499502847680274,0,0.3638,0.136,0.5002,0.0499068785109717,0.000697152319726002,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.25,0.25,0.479568647932632,0.0834785539721693,0.4369527980952,0,0.4779,0.0823,0.4398,0.049397280987092,0.00284720190480048,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0,0.35,0.21190142732584,0.144064163807897,0.644034408866263,0,0.2101,0.1422,0.6477,0.0513988176690367,0.00366559113373666,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.1,0.35,0.369642090657752,0.101868673014796,0.528489236327455,0,0.3736,0.1015,0.5249,0.0561621490094544,0.00395790934224832,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.15,0.35,0.446153031210951,0.0830602483821919,0.470786720406859,0,0.448,0.0829,0.4691,0.0543110143966461,0.00184696878904927,"EXPLAINED","bivariate_mc" +"S2","b",0.3,0.398,0.51,0.25,0.35,0.583145486598169,0.0514363649238822,0.365418148477951,0,0.583,0.051,0.366,0.0475473704533625,0.000581851522049426,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0,0,0.0420958601025049,0.505056587728172,0.452847552169325,0,0.0418,0.5046,0.4536,0.0311164407353448,0.000752447830674574,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.1,0,0.0727663239667374,0.36604647506692,0.561187200966344,0,0.0785,0.3666,0.5549,0.0334012545291667,0.00628720096634428,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.15,0,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S2","c",0.6,0.581,0.607,0.25,0,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S2","c",0.6,0.581,0.607,0,0.15,0.10223927509511,0.302451151369846,0.595309573535045,0,0.1021,0.3028,0.5951,0.0387283945049264,0.000348848630153942,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.1,0.15,0.177828324748223,0.231197135350228,0.590974539901551,0,0.1765,0.2341,0.5894,0.0506273386662303,0.00290286464977152,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.15,0.15,0.2153512358774,0.194584594312311,0.590064169810291,0,0.212,0.1997,0.5883,0.0546737875212516,0.00511540568768853,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.25,0.15,0.28450808423735,0.126970707892409,0.588521207870242,0,0.283,0.126,0.591,0.0564239234702211,0.00247879212975777,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0,0.25,0.136526389921357,0.185154823537792,0.678318786540853,0,0.1362,0.1838,0.68,0.0293410119124815,0.00168121345914718,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.1,0.25,0.24308175719294,0.147685371700389,0.609232871106673,0,0.246,0.1512,0.6028,0.0462140616333913,0.00643287110667268,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.15,0.25,0.295825201065266,0.126813083179192,0.577361715755544,0,0.2937,0.1301,0.5762,0.0529781937123313,0.00328691682080784,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.25,0.25,0.393049269586887,0.0860181808370236,0.52093254957609,0,0.3914,0.091,0.5176,0.0603596739737834,0.00498181916297641,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0,0.35,NA,NA,NA,NA,NA,NA,NA,NA,NA,"PASS","not evaluable in both" +"S2","c",0.6,0.581,0.607,0.1,0.35,0.293921931736906,0.0827218293211262,0.62335623894197,0,0.2899,0.0826,0.6275,0.0333388194634615,0.00414376105803027,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.15,0.35,0.36108314538825,0.0727169664395978,0.566199888172155,0,0.3591,0.0734,0.5675,0.0415161595143523,0.00198314538824973,"EXPLAINED","bivariate_mc" +"S2","c",0.6,0.581,0.607,0.25,0.35,0.484076332991409,0.0515963398709064,0.464327327137686,0,0.4812,0.0533,0.4655,0.0530481100138982,0.00287633299140849,"EXPLAINED","bivariate_mc" diff --git a/inst/validation/results/yamaguchi_continuous2.csv b/inst/validation/results/yamaguchi_continuous2.csv new file mode 100644 index 0000000..f9b669c --- /dev/null +++ b/inst/validation/results/yamaguchi_continuous2.csv @@ -0,0 +1,97 @@ +"table","panel","rho","gamma_go","gamma_nogo","theta1","theta2","Go","NoGo","Gray","Miss","pub_Go","pub_NoGo","pub_Gray","sensitivity","package_Go","package_NoGo","package_Gray","max_abs_diff","max_ratio","verdict","reason" +"4","a",0,0.296,0.244,0,0,0.0465,0.6363,0.3172,0,0.0499,0.6338,0.3163,0.0316,0.0465,0.6363,0.3172,0.0034,0.0773304751640302,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,5,0,0.0623,0.564,0.3737,0,0.0654,0.5601,0.3745,0.0364,0.0623,0.564,0.3737,0.0038999999999999,0.0614646906369472,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,10,0,0.0779,0.4854,0.4367,0,0.0802,0.4924,0.4274,0.0372,0.0779,0.4854,0.4367,0.00929999999999997,0.142562547048481,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,15,0,0.0981,0.4043,0.4976,0,0.1023,0.4093,0.4884,0.0377,0.0981,0.4043,0.4976,0.00919999999999999,0.139337656776765,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,0,1,0.1167,0.4731,0.4102,0,0.1185,0.4691,0.4124,0.038,0.1167,0.4731,0.4102,0.00399999999999995,0.0603498404506254,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,5,1,0.15,0.4112,0.4388,0,0.1526,0.408,0.4394,0.0427,0.15,0.4112,0.4388,0.00320000000000004,0.0453570320330777,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,10,1,0.189,0.347,0.464,0,0.1875,0.3473,0.4652,0.0468,0.189,0.347,0.464,0.0015,0.0217613954438505,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,15,1,0.2281,0.2845,0.4874,0,0.2343,0.2795,0.4862,0.0395,0.2281,0.2845,0.4874,0.00620000000000001,0.0976221111675781,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,0,2,0.2228,0.2858,0.4914,0,0.2302,0.2757,0.4941,0.0403,0.2228,0.2858,0.4914,0.0101,0.153896372254985,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,5,2,0.2821,0.246,0.4719,0,0.2896,0.2325,0.4779,0.0447,0.2821,0.246,0.4719,0.0135,0.196661057181138,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,10,2,0.3422,0.2026,0.4552,0,0.3433,0.1995,0.4572,0.0388,0.3422,0.2026,0.4552,0.00309999999999999,0.0504424476741027,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,15,2,0.4025,0.1602,0.4373,0,0.3991,0.1608,0.4401,0.0459,0.4025,0.1602,0.4373,0.00340000000000001,0.0461628032725358,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,0,3,0.3376,0.1321,0.5303,0,0.3424,0.1287,0.5289,0.039,0.3376,0.1321,0.5303,0.00479999999999997,0.0728459353219968,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,5,3,0.4187,0.1098,0.4715,0,0.4193,0.1074,0.4733,0.0384,0.4187,0.1098,0.4715,0.00240000000000001,0.042884085801541,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,10,3,0.4952,0.0869,0.4179,0,0.5022,0.0888,0.409,0.0359,0.4952,0.0869,0.4179,0.00890000000000002,0.139581824312977,"EXPLAINED","bivariate_cont_mc" +"4","a",0,0.296,0.244,15,3,0.5696,0.0687,0.3617,0,0.568,0.0715,0.3605,0.0372,0.5696,0.0687,0.3617,0.0028,0.0540276138447236,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,0,0,0.053,0.5727,0.3743,0,0.0495,0.5712,0.3793,0.0301,0.053,0.5727,0.3743,0.005,0.0868088941778989,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,5,0,0.0647,0.5031,0.4322,0,0.0647,0.4977,0.4376,0.03,0.0647,0.5031,0.4322,0.00540000000000002,0.092922180303386,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,10,0,0.0754,0.428,0.4966,0,0.0773,0.4233,0.4994,0.0279,0.0754,0.428,0.4966,0.00469999999999998,0.0840794571053762,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,15,0,0.086,0.3532,0.5608,0,0.0867,0.3608,0.5525,0.0266,0.086,0.3532,0.5608,0.00829999999999997,0.15152089628022,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,0,1,0.1207,0.432,0.4473,0,0.1224,0.4301,0.4475,0.033,0.1207,0.432,0.4473,0.00190000000000001,0.0329520052827452,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,5,1,0.1453,0.3797,0.475,0,0.1532,0.3794,0.4674,0.0329,0.1453,0.3797,0.475,0.00789999999999999,0.148148513050474,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,10,1,0.1734,0.3233,0.5033,0,0.1784,0.3157,0.5059,0.0366,0.1734,0.3233,0.5033,0.00760000000000005,0.120744696663289,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,15,1,0.2013,0.2683,0.5304,0,0.2023,0.2688,0.5289,0.035,0.2013,0.2683,0.5304,0.00149999999999995,0.0237015552839842,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,0,2,0.2069,0.2632,0.5299,0,0.2075,0.2556,0.5369,0.0353,0.2069,0.2632,0.5299,0.0076,0.126613736807701,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,5,2,0.2551,0.2324,0.5125,0,0.2507,0.2307,0.5186,0.0322,0.2551,0.2324,0.5125,0.00609999999999999,0.10080196220212,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,10,2,0.3056,0.1997,0.4947,0,0.3074,0.1994,0.4932,0.035,0.3056,0.1997,0.4947,0.00180000000000002,0.0294350129941164,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,15,2,0.3574,0.1635,0.4791,0,0.3586,0.1661,0.4753,0.0342,0.3574,0.1635,0.4791,0.00379999999999997,0.0608002536447717,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,0,3,0.2831,0.1241,0.5928,0,0.2905,0.1186,0.5909,0.0286,0.2831,0.1241,0.5928,0.00739999999999996,0.13620033839794,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,5,3,0.3546,0.1098,0.5356,0,0.3596,0.1085,0.5319,0.0299,0.3546,0.1098,0.5356,0.00499999999999995,0.0875713617907288,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,10,3,0.4295,0.0953,0.4752,0,0.4273,0.0933,0.4794,0.0289,0.4295,0.0953,0.4752,0.00419999999999998,0.0734134095485267,"EXPLAINED","bivariate_cont_mc" +"4","b",0.4,0.428,0.357,15,3,0.4979,0.0824,0.4197,0,0.501,0.0764,0.4226,0.0298,0.4979,0.0824,0.4197,0.00600000000000001,0.133699665953154,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,0,0,0.0479,0.5344,0.4177,0,0.0496,0.5332,0.4172,0.0267,0.0479,0.5344,0.4177,0.00169999999999999,0.0435540074881372,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,5,0,0.0531,0.4607,0.4862,0,0.0547,0.4665,0.4788,0.0273,0.0531,0.4607,0.4862,0.00739999999999996,0.133072375659769,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,10,0,0.0557,0.385,0.5593,0,0.055,0.381,0.564,0.0238,0.0557,0.385,0.5593,0.00469999999999993,0.0905559566942889,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,15,0,0.0583,0.3057,0.636,0,0.058,0.3129,0.6291,0.0257,0.0583,0.3057,0.636,0.00719999999999998,0.138516507970666,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,0,1,0.112,0.4112,0.4768,0,0.1088,0.4181,0.4731,0.0248,0.112,0.4112,0.4768,0.00690000000000002,0.130800101443328,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,5,1,0.1289,0.3689,0.5022,0,0.1335,0.3634,0.5031,0.0313,0.1289,0.3689,0.5022,0.0055,0.0939235543093893,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,10,1,0.1465,0.3168,0.5367,0,0.1501,0.318,0.5319,0.032,0.1465,0.3168,0.5367,0.00479999999999992,0.0796328278491543,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,15,1,0.1601,0.26,0.5799,0,0.1614,0.261,0.5776,0.029,0.1601,0.26,0.5799,0.00229999999999997,0.040356857291381,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,0,2,0.1751,0.2415,0.5834,0,0.1789,0.2381,0.583,0.0287,0.1751,0.2415,0.5834,0.0038,0.0753505612123937,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,5,2,0.2196,0.2218,0.5586,0,0.2236,0.2249,0.5515,0.0299,0.2196,0.2218,0.5586,0.0071,0.122237100895183,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,10,2,0.2625,0.1989,0.5386,0,0.2699,0.1993,0.5308,0.0308,0.2625,0.1989,0.5386,0.00779999999999992,0.132234455441166,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,15,2,0.301,0.1711,0.5279,0,0.2983,0.175,0.5267,0.0298,0.301,0.1711,0.5279,0.00389999999999999,0.0759579668910394,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,0,3,0.2146,0.1018,0.6836,0,0.2217,0.0974,0.6809,0.0228,0.2146,0.1018,0.6836,0.0071,0.153188834572708,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,5,3,0.2797,0.0977,0.6226,0,0.2818,0.0948,0.6234,0.0245,0.2797,0.0977,0.6226,0.00290000000000001,0.0705233975005244,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,10,3,0.3502,0.0915,0.5583,0,0.3532,0.0903,0.5565,0.0273,0.3502,0.0915,0.5583,0.003,0.0551594918303522,"EXPLAINED","bivariate_cont_mc" +"4","c",0.8,0.6,0.485,15,3,0.4198,0.0834,0.4968,0,0.4159,0.0857,0.4984,0.025,0.4198,0.0834,0.4968,0.00390000000000001,0.0736804078115195,"EXPLAINED","bivariate_cont_mc" +"S3","a",0,0.239,0.559,0,0,0.048,0.6488,0.3032,0,0.0498,0.6427,0.3075,0.0139,0.064,0.5244,0.4116,0.00609999999999988,0.148570724821027,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,1.5,0,0.1104,0.4381,0.4515,0,0.112,0.435,0.453,0.0169,0.1455,0.3197,0.5348,0.00309999999999999,0.0688976898067496,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,3,0,0.1834,0.2197,0.5969,0,0.1848,0.2131,0.6021,0.0156,0.2423,0.1408,0.6169,0.00659999999999999,0.170038711742027,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,4.5,0,0.2326,0.0742,0.6932,0,0.2363,0.0714,0.6923,0.0145,0.3238,0.0418,0.6344,0.00370000000000001,0.0961672598651036,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,0,1,0.1158,0.4063,0.4779,0,0.1236,0.4066,0.4698,0.0187,0.1526,0.2949,0.5525,0.0081,0.208734170070872,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,1.5,1,0.2644,0.2703,0.4653,0,0.2704,0.2737,0.4559,0.0196,0.3231,0.1688,0.5081,0.00939999999999996,0.196553857246112,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,3,1,0.4167,0.1324,0.4509,0,0.4168,0.1362,0.447,0.0192,0.4968,0.0705,0.4327,0.00389999999999996,0.0983104641637709,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,4.5,1,0.5171,0.0449,0.438,0,0.5171,0.0418,0.4411,0.0161,0.6171,0.0177,0.3652,0.00310000000000001,0.112845582370841,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,0,2,0.1979,0.1742,0.6279,0,0.202,0.1793,0.6187,0.0166,0.265,0.1083,0.6267,0.00919999999999999,0.208495365725013,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,1.5,2,0.4203,0.1135,0.4662,0,0.4201,0.1136,0.4663,0.0193,0.5049,0.0572,0.4379,0.000200000000000033,0.00423094148065966,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,3,2,0.6409,0.0535,0.3056,0,0.6486,0.0565,0.2949,0.0163,0.7209,0.0215,0.2576,0.0107,0.25388460226745,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,4.5,2,0.7759,0.0171,0.207,0,0.7805,0.0156,0.2039,0.0133,0.8447,0.0056,0.1497,0.00460000000000005,0.125121831767356,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,0,3,0.2477,0.0429,0.7094,0,0.2384,0.0436,0.718,0.0142,0.3451,0.0225,0.6324,0.0093,0.242477097593656,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,1.5,3,0.5059,0.0273,0.4668,0,0.5067,0.0292,0.4641,0.0136,0.615,0.0103,0.3747,0.00269999999999998,0.0819875075652932,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,3,3,0.758,0.0113,0.2307,0,0.7605,0.0137,0.2258,0.0117,0.832,0.004,0.164,0.00490000000000002,0.138411177120682,"EXPLAINED","c1_predictive_scale" +"S3","a",0,0.239,0.559,4.5,3,0.9032,0.0038,0.093,0,0.9028,0.0044,0.0928,0.0078,0.9451,9e-04,0.054,6e-04,0.0517505959789051,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,0,0,0.0521,0.6091,0.3388,0,0.0498,0.6105,0.3397,0.0134,0.036,0.4251,0.5389,0.0023,0.0893015162587075,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,1.5,0,0.0982,0.4131,0.4887,0,0.1013,0.405,0.4937,0.0172,0.0744,0.2519,0.6737,0.0081,0.179923838171432,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,3,0,0.139,0.2037,0.6573,0,0.1444,0.1985,0.6571,0.0144,0.1176,0.1059,0.7765,0.00539999999999999,0.157280546202146,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,4.5,0,0.1625,0.0652,0.7723,0,0.1623,0.0602,0.7775,0.0102,0.1502,0.0263,0.8235,0.00519999999999998,0.210923956647419,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,0,1,0.1051,0.3842,0.5107,0,0.1014,0.3755,0.5231,0.0173,0.08,0.2279,0.6921,0.0124,0.27190555232206,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,1.5,1,0.2278,0.277,0.4952,0,0.2222,0.272,0.5058,0.0181,0.1809,0.1405,0.6786,0.0106000000000001,0.228289018600534,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,3,1,0.3469,0.1438,0.5093,0,0.3496,0.1403,0.5101,0.0162,0.299,0.0619,0.6391,0.0035,0.0975035105865296,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,4.5,1,0.4175,0.0501,0.5324,0,0.4139,0.0482,0.5379,0.0116,0.3874,0.0153,0.5973,0.00550000000000006,0.138007524138291,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,0,2,0.1521,0.1598,0.6881,0,0.1501,0.1524,0.6975,0.0127,0.1309,0.077,0.7921,0.00940000000000007,0.242679426746401,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,1.5,2,0.3445,0.1221,0.5334,0,0.3398,0.1203,0.5399,0.0163,0.3052,0.0513,0.6435,0.00650000000000006,0.1459229004741,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,3,2,0.5524,0.07,0.3776,0,0.5557,0.0659,0.3784,0.0149,0.5025,0.0236,0.4739,0.00410000000000001,0.141452160550602,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,4.5,2,0.6897,0.0255,0.2848,0,0.6825,0.0274,0.2901,0.0108,0.6462,0.0073,0.3465,0.00719999999999998,0.193637553055784,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,0,3,0.171,0.0373,0.7917,0,0.1645,0.0392,0.7963,0.0082,0.1649,0.0138,0.8213,0.00650000000000001,0.222438335170278,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,1.5,3,0.4006,0.0309,0.5685,0,0.3936,0.0298,0.5766,0.0112,0.3781,0.0095,0.6124,0.0081,0.20663063852804,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,3,3,0.6629,0.0179,0.3192,0,0.6633,0.0214,0.3153,0.011,0.6294,0.0054,0.3652,0.00389999999999996,0.181948228368142,"EXPLAINED","c1_predictive_scale" +"S3","b",0.4,0.483,0.701,4.5,3,0.8431,0.0079,0.149,0,0.8399,0.0079,0.1522,0.0057,0.8158,0.0018,0.1824,0.00320000000000001,0.122745275646243,"EXPLAINED","c1_predictive_scale" +"S3","c",0.8,0.559,0.867,0,0,0.0833,0.5643,0.3524,0,0.0498,0.5705,0.3797,0.0232,0.0579,0.285,0.6571,0.0335,0.942190515801469,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,1.5,0,0.1262,0.363,0.5108,0,0.0917,0.3493,0.559,0.0207,0.0952,0.1483,0.7565,0.0482,0.986963342992094,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,3,0,0.1412,0.1507,0.7081,0,0.1017,0.1464,0.7519,0.0171,0.1184,0.046,0.8356,0.0438000000000001,1.15335085632272,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,4.5,0,0.1433,0.0371,0.8196,0,0.0969,0.0427,0.8604,0.0095,0.1258,0.0089,0.8653,0.0464,1.76531942651315,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,0,1,0.1386,0.3342,0.5272,0,0.0881,0.3376,0.5743,0.0238,0.1047,0.1346,0.7607,0.0505,1.26617811155964,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,1.5,1,0.2877,0.2633,0.449,0,0.1979,0.2584,0.5437,0.0239,0.2243,0.0863,0.6894,0.0947,1.93168821791775,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,3,1,0.388,0.1334,0.4786,0,0.2941,0.1302,0.5757,0.0218,0.3241,0.0337,0.6422,0.0971,1.97166475901393,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,4.5,1,0.4169,0.036,0.5471,0,0.3159,0.037,0.6471,0.0135,0.3711,0.008,0.6209,0.101,2.53468208465256,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,0,2,0.1528,0.1147,0.7325,0,0.0998,0.1107,0.7895,0.0154,0.1293,0.032,0.8387,0.0570000000000001,1.63552643271626,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,1.5,2,0.3645,0.1076,0.5279,0,0.2787,0.1031,0.6182,0.0165,0.3162,0.0264,0.6574,0.0902999999999999,2.05075433568275,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,3,2,0.5881,0.075,0.3369,0,0.4879,0.0722,0.4399,0.0153,0.5173,0.0134,0.4693,0.103,2.37167605208224,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,4.5,2,0.6982,0.028,0.2738,0,0.6066,0.0275,0.3659,0.0122,0.6389,0.0048,0.3563,0.0921,2.33176194530039,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,0,3,0.1538,0.0205,0.8257,0,0.1068,0.0236,0.8696,0.0087,0.1334,0.0043,0.8623,0.047,1.79240903527266,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,1.5,3,0.3789,0.02,0.6011,0,0.2976,0.0203,0.6821,0.0109,0.3441,0.004,0.6519,0.0813,2.2084417448102,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,3,3,0.6555,0.0183,0.3262,0,0.5664,0.0189,0.4147,0.0118,0.607,0.0026,0.3904,0.0891,2.2339922960567,"INFO","s3_rho08" +"S3","c",0.8,0.559,0.867,4.5,3,0.8457,0.0103,0.144,0,0.7813,0.0119,0.2068,0.0093,0.7984,0.0011,0.2005,0.0644,1.96740732318876,"INFO","s3_rho08" diff --git a/inst/validation/run_validation.R b/inst/validation/run_validation.R new file mode 100644 index 0000000..7f22b3b --- /dev/null +++ b/inst/validation/run_validation.R @@ -0,0 +1,281 @@ +# Runs the validation scripts of BayesianQDM and writes the results and a +# summary to inst/validation/results/. The summary is generated from the +# results; do not edit it by hand. +# +# Usage: from the package root, after devtools::load_all() (or with the +# package attached), +# source("inst/validation/run_validation.R") + +local({ + val_dir <- file.path("inst", "validation") + if (!dir.exists(val_dir)) { + stop("Run this script from the root of the BayesianQDM package.", + call. = FALSE) + } + out_dir <- file.path(val_dir, "results") + dir.create(out_dir, showWarnings = FALSE) + env <- environment() + for (f in c("validate_kang2026_binary.R", "validation_helpers.R", + "validate_yamaguchi_glaucoma.R", "validate_huang_table3.R", + "validate_kang2026_table4.R", "validate_yamaguchi_binary2.R", + "validate_yamaguchi_continuous2.R")) { + sys.source(file.path(val_dir, f), envir = env) + } + count <- function(x, v) sum(x == v) + + # One binary endpoint: operating characteristics + res <- validate_kang2026_binary(file.path(val_dir, + "kang2026_supplement.csv")) + utils::write.csv(res, file.path(out_dir, "kang2026_binary.csv"), + row.names = FALSE) + self <- kang2026_self_check(res) + tab <- do.call(rbind, lapply(split(res, list(res$table, res$criterion), + drop = TRUE), function(d) { + data.frame(table = d$table[1], criterion = d$criterion[1], + checks = nrow(d), PASS = count(d$verdict, "PASS"), + EXPLAINED = count(d$verdict, "EXPLAINED"), + FAIL = count(d$verdict, "FAIL"), + max_abs_diff = max(d$max_abs_diff)) + })) + tab <- tab[order(tab$table, tab$criterion), ] + + # Two binary endpoints: operating characteristics + res2 <- validate_yamaguchi_binary2(file.path(val_dir, + "bivariate_binary2_tables.csv")) + utils::write.csv(res2, file.path(out_dir, "yamaguchi_binary2.csv"), + row.names = FALSE) + self2 <- yamaguchi_binary2_self_check(res2) + tab2 <- do.call(rbind, lapply(split(res2, factor(res2$table, + unique(res2$table))), + function(d) { + ne <- is.na(d$pub_Go) + data.frame(table = d$table[1], checks = nrow(d), + PASS = count(d$verdict, "PASS"), + EXPLAINED = count(d$verdict, "EXPLAINED"), + FAIL = count(d$verdict, "FAIL"), NE = sum(ne), + max_abs_diff = max(d$max_abs_diff[!ne], -Inf), + max_sensitivity = max(d$sensitivity[!ne], -Inf)) + })) + tab2$label <- ifelse(tab2$table == "3", "Table 3", + paste("Supplemental Table", tab2$table)) + + # Two continuous endpoints: operating characteristics + nsim2 <- 10000L + res3 <- validate_yamaguchi_continuous2( + file.path(val_dir, "bivariate_continuous2_tables.csv"), nsim = nsim2 + ) + utils::write.csv(res3, file.path(out_dir, "yamaguchi_continuous2.csv"), + row.names = FALSE) + self3 <- yamaguchi_continuous2_self_check(res3, nsim2) + tab3 <- do.call(rbind, lapply(split(res3, factor(res3$table, + unique(res3$table))), + function(d) { + ok <- d$verdict != "INFO" + data.frame(table = d$table[1], checks = nrow(d), + PASS = count(d$verdict, "PASS"), + EXPLAINED = count(d$verdict, "EXPLAINED"), + FAIL = count(d$verdict, "FAIL"), + INFO = count(d$verdict, "INFO"), + max_abs_diff = max(d$max_abs_diff[ok], -Inf), + max_ratio = max(d$max_ratio[ok], -Inf)) + })) + tab3$label <- ifelse(tab3$table == "4", "Table 4", + paste("Supplemental Table", tab3$table)) + info3 <- res3[res3$verdict == "INFO", ] + + # One continuous endpoint: published numbers + raw <- rbind(validate_yamaguchi_glaucoma(), validate_huang_table3(), + validate_kang2026_table4()) + num <- number_verdict(raw) + utils::write.csv(num, file.path(out_dir, "continuous.csv"), + row.names = FALSE) + self_num <- number_self_check(raw) + tab_num <- do.call(rbind, lapply(split(num, factor(num$study, + unique(num$study))), + function(d) { + data.frame(study = d$study[1], checks = nrow(d), + PASS = count(d$verdict, "PASS"), + EXPLAINED = count(d$verdict, "EXPLAINED"), + FAIL = count(d$verdict, "FAIL"), + INFO = count(d$verdict, "INFO"), + max_abs_diff = max(d$abs_diff[d$verdict != "INFO"], + -Inf)) + })) + info <- num[num$verdict == "INFO", ] + not_pass <- num[num$verdict %in% c("EXPLAINED", "FAIL"), ] + + verdicts <- c(res$verdict, res2$verdict, res3$verdict, num$verdict) + fmt_diff <- function(x) ifelse(is.finite(x), sprintf("%.4f", x), "-") + lines <- c( + "# Validation of BayesianQDM against published results", + "", + sprintf("Generated by `inst/validation/run_validation.R` with BayesianQDM %s.", + as.character(utils::packageVersion("BayesianQDM"))), + "", + "## Kang, Yamaguchi and Han (2026), Supplemental Tables 2 to 5 (one binary endpoint)", + "", + "| Table | Criterion | Checks | PASS | EXPLAINED | FAIL | Largest difference |", + "|---|---|---|---|---|---|---|", + sprintf("| %d | %s | %d | %d | %d | %d | %.4f |", tab$table, tab$criterion, + tab$checks, tab$PASS, tab$EXPLAINED, tab$FAIL, tab$max_abs_diff), + "", + sprintf("Largest probability of a Miss decision: %.3g.", max(res$Miss)), + "", + paste("## Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted),", + "Table 3 and Supplemental Tables S1 and S2 (two binary endpoints)"), + "", + paste("| Table | Checks | PASS | EXPLAINED | FAIL | Not evaluable (NE) |", + "Largest difference | Largest sensitivity |"), + "|---|---|---|---|---|---|---|---|", + sprintf("| %s | %d | %d | %d | %d | %d | %.4f | %.4f |", tab2$label, + tab2$checks, tab2$PASS, tab2$EXPLAINED, tab2$FAIL, tab2$NE, + tab2$max_abs_diff, tab2$max_sensitivity), + "", + paste("One check per scenario (largest difference of Go, Gray and NoGo).", + "The scenarios that the article reports as not evaluable (NE)", + "are PASS when the probabilities of BayesianQDM are NA", + "(correlation outside the feasible range)."), + sprintf("Largest probability of a Miss decision: %.3g.", + max(res2$Miss, na.rm = TRUE)), + "", + paste("## Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted),", + "Table 4 and Supplemental Table S3 (two continuous endpoints)"), + "", + paste("| Table | Checks | PASS | EXPLAINED | FAIL | INFO |", + "Largest difference (except INFO) | Largest difference / tolerance |"), + "|---|---|---|---|---|---|---|---|", + sprintf("| %s | %d | %d | %d | %d | %d | %.4f | %.2f |", tab3$label, + tab3$checks, tab3$PASS, tab3$EXPLAINED, tab3$FAIL, tab3$INFO, + tab3$max_abs_diff, tab3$max_ratio), + "", + sprintf(paste("One check per scenario (Go, NoGo and Gray), with %d", + "simulated studies and the moment-matching approximation.", + "For Supplemental Table S3 the verdict uses the predictive", + "scale of the article; the probabilities of BayesianQDM", + "(corrected scale) are in the columns package_Go,", + "package_NoGo and package_Gray of the details."), nsim2), + "", + if (nrow(info3) > 0L) { + c("INFO rows (published; computed with the scale of the article;", + "BayesianQDM), Go / NoGo / Gray:", + "", + "| Table | Panel | theta1 | theta2 | Published | Article scale | BayesianQDM |", + "|---|---|---|---|---|---|---|", + sprintf("| %s | %s | %s | %s | %.4f / %.4f / %.4f | %.4f / %.4f / %.4f | %.4f / %.4f / %.4f |", + info3$table, info3$panel, format(info3$theta1), + format(info3$theta2), info3$pub_Go, info3$pub_NoGo, + info3$pub_Gray, info3$Go, info3$NoGo, info3$Gray, + info3$package_Go, info3$package_NoGo, info3$package_Gray), + "") + }, + "## Published numbers for one continuous endpoint", + "", + "| Source | Checks | PASS | EXPLAINED | FAIL | INFO | Largest difference (except INFO) |", + "|---|---|---|---|---|---|---|", + sprintf("| %s | %d | %d | %d | %d | %d | %s |", tab_num$study, + tab_num$checks, tab_num$PASS, tab_num$EXPLAINED, tab_num$FAIL, + tab_num$INFO, fmt_diff(tab_num$max_abs_diff)), + "", + if (nrow(not_pass) > 0L) { + c("Numbers that are not PASS (except INFO):", + "", + "| Source | Quantity | Setting | Method | Published | Computed | Verdict |", + "|---|---|---|---|---|---|---|", + sprintf("| %s | %s | %s | %s | %s | %.4f | %s |", not_pass$study, + not_pass$quantity, not_pass$setting, not_pass$method, + format(not_pass$published), not_pass$computed, + not_pass$verdict), + "") + }, + if (nrow(info) > 0L) { + c("INFO rows (published and computed values):", + "", + "| Source | Quantity | Setting | Published | Computed |", + "|---|---|---|---|---|", + sprintf("| %s | %s | %s | %s | %.4f |", info$study, info$quantity, + info$setting, format(info$published), info$computed), + "") + }, + sprintf(paste("Total: %d checks, %d PASS, %d EXPLAINED, %d FAIL,", + "%d INFO."), length(verdicts), count(verdicts, "PASS"), + count(verdicts, "EXPLAINED"), count(verdicts, "FAIL"), + count(verdicts, "INFO")), + "", + "Registered reasons:", + paste("- `kang2026_mc`: the article computes the posterior predictive", + "probability by Monte Carlo simulation. The difference is at most", + "the probability of the outcomes whose exact predictive probability", + "is within 0.01 of a threshold (plus 0.0005 for rounding), whose", + "decisions Monte Carlo error can change."), + paste("- `bivariate_mc`: the article and BayesianQDM estimate the", + "posterior probabilities of the regions by Monte Carlo", + "simulation. The difference is at most the probability of the", + "outcomes whose posterior probability of the Go or NoGo region is", + "within 0.01 of its threshold (plus 0.00005 for rounding), whose", + "decisions Monte Carlo error can change."), + paste("- `bivariate_cont_mc`: the article estimates the decision", + "probabilities of two continuous endpoints by simulating studies", + "(10000 assumed; the number is not stated) and the region", + "probabilities by Monte Carlo simulation. The difference is at", + "most 4 standard errors of both simulations plus the probability", + "of the studies whose probability of the Go or NoGo region is", + "within 0.01 of its threshold (plus 0.00005 for rounding)."), + paste("- `c1_predictive_scale`: the article computes the posterior", + "predictive probabilities of two continuous endpoints with the", + "scale ((1 + kappa) / kappa) Lambda / ((nu - 1) m) for the mean of", + "m future subjects, which BayesianQDM corrects to", + "(1 / kappa + 1 / m) Lambda / (nu - 1). With the scale of the", + "article the published values are reproduced within the", + "tolerance of `bivariate_cont_mc`."), + paste("- `s3_rho08`: Supplemental Table S3, panel (c) (rho = 0.8), is", + "not reproduced from the stated thresholds with either scale", + "(for example, the probability of Go under the null scenario is", + "0.08 to 0.09 with the scale of the article and about 0.06 with", + "the corrected scale, instead of 0.0498). Monte Carlo draws", + "shared across the simulated studies, as in version 0.1.0, do", + "not explain the difference. Reported for information."), + paste("- `huang_mc`: the article summarizes Monte Carlo samples of the", + "posterior distributions (its Section 6.3); the difference from", + "the exact value is at most 0.01 beyond rounding."), + paste("- `kang2026_table4`: the case study of Kang et al. (2026,", + "Section 6) is not reproduced from the inputs stated in the", + "article (vague priors, standard deviations 25, 30 and 20); the", + "article used Markov chain Monte Carlo sampling. Reported for", + "information until the inputs are clarified."), + "", + sprintf(paste("Self-check: shifting the published Go probabilities by 0.02", + "gives FAIL in %d of %d posterior rows (%s)."), + self$n_fail, self$n_posterior, + if (self$ok) "PASS" else "FAIL"), + sprintf(paste("Self-check: shifting the published Go probabilities of", + "two binary endpoints by 0.15 gives FAIL in %d of %d", + "evaluable scenarios (%s)."), + self2$n_fail, self2$n_evaluable, + if (self2$ok) "PASS" else "FAIL"), + sprintf(paste("Self-check: shifting the published Go probabilities of", + "two continuous endpoints by 0.2 gives FAIL in %d of %d", + "scenarios other than INFO (%s)."), + self3$n_fail, self3$n_checked, + if (self3$ok) "PASS" else "FAIL"), + sprintf(paste("Self-check: shifting the published continuous numbers by", + "0.05 gives FAIL in %d of %d rows other than INFO (%s)."), + self_num$n_fail, self_num$n_checked, + if (self_num$ok) "PASS" else "FAIL"), + "", + paste("Details: `inst/validation/results/kang2026_binary.csv`,", + "`inst/validation/results/yamaguchi_binary2.csv`,", + "`inst/validation/results/yamaguchi_continuous2.csv` and", + "`inst/validation/results/continuous.csv`.") + ) + writeLines(lines, file.path(out_dir, "summary.md")) + message(sprintf(paste("Validation: %d checks, %d PASS, %d EXPLAINED,", + "%d FAIL, %d INFO; self-checks %s"), + length(verdicts), count(verdicts, "PASS"), + count(verdicts, "EXPLAINED"), count(verdicts, "FAIL"), + count(verdicts, "INFO"), + if (self$ok && self2$ok && self3$ok && self_num$ok) { + "PASS" + } else { + "FAIL" + })) +}) diff --git a/inst/validation/validate_huang_table3.R b/inst/validation/validate_huang_table3.R new file mode 100644 index 0000000..09cac22 --- /dev/null +++ b/inst/validation/validate_huang_table3.R @@ -0,0 +1,72 @@ +# Validation against Huang, Yamaguchi, Homma, Takeda and Maruo (submitted), +# "Conjugate representation of power priors for efficient Bayesian analysis +# of normal data", Table 3 (pediatric extrapolation example). Vague initial +# priors; adult (external) data of 60 subjects per group (treatment mean +# -0.7, SD 3.8; control mean 2.5, SD 4.0) with power prior weight a0 for +# both groups; pediatric (current) data of 30 subjects per group (treatment +# mean -0.5, SD 3.9; control mean 2.8, SD 4.3); a0 = 0.25, 0.5, 0.75. +# +# The posterior distributions of the group means are t distributions, whose +# parameters are returned by qdm_decide(). The article summarizes the +# posterior distribution of the treatment effect from Monte Carlo samples +# (Section 6.3), so the numbers may differ from the exact values by Monte +# Carlo error: differences up to 0.01 beyond rounding are EXPLAINED (reason +# "huang_mc"). The credible interval is computed here from ptdiff() with +# uniroot(). + +validate_huang_table3 <- function() { + study <- "Huang et al. (submitted), Table 3" + pub <- list( + mean_c = c(2.70, 2.65, 2.62), sd_c = c(0.640, 0.543, 0.480), + mean_t = c(-0.57, -0.60, -0.62), sd_t = c(0.589, 0.504, 0.448), + mean_d = c(-3.27, -3.25, -3.24), sd_d = c(0.870, 0.741, 0.656), + prob = c(0.928, 0.954, 0.970), lower = c(-4.98, -4.71, -4.53), + upper = c(-1.56, -1.80, -1.95) + ) + a0 <- c(0.25, 0.5, 0.75) + rows <- list() + for (i in seq_along(a0)) { + des <- design_continuous( + 30, 30, prior_vague(), prior_vague(), + criterion_posterior(theta_tv = 0, theta_mav = -2, gamma_go = 0.5, + gamma_nogo = 0.95), + external_t = borrow(data_continuous(60, -0.7, 3.8), a0[i]), + external_c = borrow(data_continuous(60, 2.5, 4.0), a0[i]) + ) + res <- qdm_decide(des, data_continuous(30, -0.5, 3.9), + data_continuous(30, 2.8, 4.3)) + pt <- res$posterior_t + pc <- res$posterior_c + scale_t <- pt[["sigma"]] / sqrt(pt[["kappa"]]) + scale_c <- pc[["sigma"]] / sqrt(pc[["kappa"]]) + var_t <- scale_t ^ 2 * pt[["nu"]] / (pt[["nu"]] - 2) + var_c <- scale_c ^ 2 * pc[["nu"]] / (pc[["nu"]] - 2) + cdf <- function(q) { + ptdiff(q, pt[["mu"]], scale_t, pt[["nu"]], pc[["mu"]], scale_c, + pc[["nu"]]) + } + quant <- function(p) { + stats::uniroot(function(q) cdf(q) - p, c(-20, 20), + tol = 1e-10)$root + } + setting <- sprintf("a0 = %s", format(a0[i])) + row <- function(quantity, published, computed, decimals) { + number_row(study, quantity, setting, "NI", published, computed, + decimals, explain_tol = 0.01, + reason_explained = "huang_mc") + } + rows <- c(rows, list( + row("Control posterior mean", pub$mean_c[i], pc[["mu"]], 2), + row("Control posterior SD", pub$sd_c[i], sqrt(var_c), 3), + row("Treatment posterior mean", pub$mean_t[i], pt[["mu"]], 2), + row("Treatment posterior SD", pub$sd_t[i], sqrt(var_t), 3), + row("Effect posterior mean", pub$mean_d[i], pt[["mu"]] - pc[["mu"]], + 2), + row("Effect posterior SD", pub$sd_d[i], sqrt(var_t + var_c), 3), + row("P(delta < -2 | data)", pub$prob[i], res$prob_nogo, 3), + row("95% credible interval, lower", pub$lower[i], quant(0.025), 2), + row("95% credible interval, upper", pub$upper[i], quant(0.975), 2) + )) + } + do.call(rbind, rows) +} diff --git a/inst/validation/validate_kang2026_binary.R b/inst/validation/validate_kang2026_binary.R new file mode 100644 index 0000000..43a9ca0 --- /dev/null +++ b/inst/validation/validate_kang2026_binary.R @@ -0,0 +1,94 @@ +# Validation against Kang, Yamaguchi and Han (2026), Supplemental Tables 2 to 5: +# operating characteristics of a single binary endpoint with posterior and +# posterior predictive criteria, several priors, sample sizes and power prior +# weights. The published values (three decimals) are in +# kang2026_supplement.csv, extracted from the supplementary Word file by +# Python_reference/extract_kang2026_supplement.py in the work folder. +# +# Verdicts: +# PASS all of Go, NoGo and Gray agree within 0.0005 (rounding). +# EXPLAINED (predictive criterion only) the difference is at most the total +# probability of the outcomes whose exact predictive probability +# is within 0.01 of a threshold, plus 0.0005. The article +# computes the predictive probability by Monte Carlo +# simulation, whose error can change the decisions for these +# outcomes (reason "kang2026_mc"). +# FAIL otherwise. +# +# This file defines validate_kang2026_binary(); run_validation.R calls it. + +kang2026_design <- function(r) { + criterion <- if (r$criterion == "posterior") { + criterion_posterior(theta_tv = r$theta_tv, theta_mav = r$theta_mav, + gamma_go = r$gamma_go, gamma_nogo = r$gamma_nogo) + } else { + criterion_predictive(theta_null = r$theta_null, m_t = r$m_t, + m_c = r$m_c, gamma_go = r$gamma_go, + gamma_nogo = r$gamma_nogo) + } + external_t <- NULL + external_c <- NULL + if (r$n_e > 0) { + external_t <- borrow(data_binary(r$n_e, r$y_et), r$a0_t) + external_c <- borrow(data_binary(r$n_e, r$y_ec), r$a0_c) + } + design_binary(n_t = r$n_t, n_c = r$n_c, + prior_t = prior_beta(r$a_t, r$b_t), + prior_c = prior_beta(r$a_c, r$b_c), + criterion = criterion, external_t = external_t, + external_c = external_c) +} + +kang2026_verdict <- function(res, rounding = 0.0005 + 1e-9) { + diff <- pmax(abs(res$Go - res$pub_Go), abs(res$NoGo - res$pub_NoGo), + abs(res$Gray - res$pub_Gray)) + verdict <- ifelse(diff <= rounding, "PASS", + ifelse(res$criterion == "predictive" & + diff <= res$sensitivity + rounding, + "EXPLAINED", "FAIL")) + data.frame(max_abs_diff = diff, verdict = verdict, + reason = ifelse(verdict == "EXPLAINED", "kang2026_mc", "")) +} + +validate_kang2026_binary <- function(ref_file, delta = 0.01) { + ref <- utils::read.csv(ref_file, stringsAsFactors = FALSE) + key <- c("criterion", "a_t", "b_t", "a_c", "b_c", "n_t", "n_c", "m_t", "m_c", + "n_e", "y_et", "y_ec", "a0_t", "a0_c") + groups <- split(seq_len(nrow(ref)), do.call(paste, c(ref[key], sep = "|"))) + res <- vector("list", length(groups)) + for (g in seq_along(groups)) { + idx <- groups[[g]] + des <- kang2026_design(ref[idx[1], ]) + scen <- data.frame(pi_t = ref$pi_t[idx], pi_c = ref$pi_c[idx]) + oc <- qdm_oc(des, scen) + # Probability of the outcomes whose region probability is close to a + # threshold (sensitivity of the decisions to Monte Carlo error) + s <- BayesianQDM:::oc_sample(des, scen, 1L) + near <- abs(s$p_go - des$criterion$gamma_go) < delta | + abs(s$p_nogo - des$criterion$gamma_nogo) < delta + res[[g]] <- data.frame( + table = ref$table[idx], row = ref$row[idx], + criterion = ref$criterion[idx], setting = ref$setting[idx], + a0_t = ref$a0_t[idx], a0_c = ref$a0_c[idx], effect = ref$effect[idx], + Go = oc$Go, NoGo = oc$NoGo, Gray = oc$Gray, Miss = oc$Miss, + pub_Go = ref$Go[idx], pub_NoGo = ref$NoGo[idx], + pub_Gray = ref$Gray[idx], + sensitivity = colSums(s$weights * near) + ) + } + res <- do.call(rbind, res) + res <- res[order(res$table, res$row, res$criterion), ] + rownames(res) <- NULL + cbind(res, kang2026_verdict(res)) +} + +# Self-check: shifting every published Go probability by 0.02 must give FAIL +# for all rows of the posterior criterion, so the comparison is not vacuous. +kang2026_self_check <- function(res) { + shifted <- res + shifted$pub_Go <- shifted$pub_Go + 0.02 + v <- kang2026_verdict(shifted)$verdict + post <- res$criterion == "posterior" + list(n_posterior = sum(post), n_fail = sum(v[post] == "FAIL"), + ok = all(v[post] == "FAIL")) +} diff --git a/inst/validation/validate_kang2026_table4.R b/inst/validation/validate_kang2026_table4.R new file mode 100644 index 0000000..193de80 --- /dev/null +++ b/inst/validation/validate_kang2026_table4.R @@ -0,0 +1,52 @@ +# Comparison with Kang, Yamaguchi and Han (2026), Table 4 (case study in +# Duchenne muscular dystrophy, Section 6). Inputs stated in Section 6: +# TV = 30 and MAV = 15; 12 subjects per group in the PoC expansion cohort +# with means 18 (treatment) and -12 (control) and standard deviation 25; +# external treatment data of 6 subjects (mean 20, SD 30, a0t = 0.5); +# external control data of 30 subjects (mean -12, SD 20, a0c = 0.2 to 0.8); +# vague priors. +# +# With these inputs, P(theta > TV) is 0.5 without external data (the +# observed difference equals TV), close to the published 0.499, but the +# other published values (P(theta > TV) of 0.598 to 0.640 and +# P(theta > MAV) of 0.999 to 1.000) are not reproduced; the article used +# Markov chain Monte Carlo sampling (Section 4.2.3). All rows are therefore +# reported as INFO (reason "kang2026_table4") until the inputs are +# clarified. + +validate_kang2026_table4 <- function() { + study <- "Kang et al. (2026), Table 4" + analyses <- data.frame( + setting = c("PoC data only", "External treatment data", + sprintf("External treatment and control data, a0c = %s", + c(0.2, 0.4, 0.6, 0.8))), + a0t = c(NA, 0.5, 0.5, 0.5, 0.5, 0.5), + a0c = c(NA, NA, 0.2, 0.4, 0.6, 0.8), + pub_tv = c(0.499, 0.598, 0.620, 0.628, 0.636, 0.640), + pub_mav = c(0.999, 0.999, 1.000, 1.000, 1.000, 1.000), + stringsAsFactors = FALSE + ) + rows <- list() + for (i in seq_len(nrow(analyses))) { + a <- analyses[i, ] + ext_t <- if (is.na(a$a0t)) NULL else + borrow(data_continuous(6, 20, 30), a$a0t) + ext_c <- if (is.na(a$a0c)) NULL else + borrow(data_continuous(30, -12, 20), a$a0c) + des <- design_continuous(12, 12, prior_vague(), prior_vague(), + criterion_posterior(theta_tv = 30, + theta_mav = 15, + gamma_go = 0.6, + gamma_nogo = 0.7), + external_t = ext_t, external_c = ext_c) + res <- qdm_decide(des, data_continuous(12, 18, 25), + data_continuous(12, -12, 25)) + rows <- c(rows, list( + number_row(study, "P(theta > TV | data)", a$setting, "NI", a$pub_tv, + res$prob_go, 3, info = "kang2026_table4"), + number_row(study, "P(theta > MAV | data)", a$setting, "NI", + a$pub_mav, 1 - res$prob_nogo, 3, info = "kang2026_table4") + )) + } + do.call(rbind, rows) +} diff --git a/inst/validation/validate_yamaguchi_binary2.R b/inst/validation/validate_yamaguchi_binary2.R new file mode 100644 index 0000000..4bc358a --- /dev/null +++ b/inst/validation/validate_yamaguchi_binary2.R @@ -0,0 +1,142 @@ +# Validation against Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted), +# Table 3 (case study 1) and Supplemental Tables S1 and S2 (case study 3, +# with and without external data): operating characteristics of two binary +# endpoints +# with a posterior criterion on the joint regions, for three correlations +# (rho_t = rho_c) and sixteen pairs of treatment effects. The published +# values (four decimals; NE for scenarios that are not evaluable) are in +# bivariate_binary2_tables.csv, extracted from the article and its +# supplement by Python_reference/extract_bivariate_tables.py in the work +# folder. +# +# Settings (article Section 3.1 and Supplemental Section S1.1): Dirichlet +# priors Dir(0.25, 0.25, 0.25, 0.25) in both groups; +# Table 3 n_t = n_c = 10, control rates (0.15, 0.20), TV (0.15, 0.15), +# MAV (0.10, 0.10), Go region 1, NoGo region 9; +# S1, S2 n_t = n_c = 8, control rates (0.20, 0.15), TV (0.15, 0.25), +# MAV (0.10, 0.15), Go regions 1 and 2, NoGo region 9; S1 adds +# the external data (2, 1, 1, 2) with a0 = 0.7 (treatment) and +# (14, 2, 3, 1) with a0 = 0.5 (control). +# The supplement states "15 patients per arm (nt = nc = 8)"; the tables are +# reproduced with 8 patients per group. +# +# Verdicts (one per scenario): +# PASS Go, Gray and NoGo agree within 0.00005 (rounding), or the +# article reports the scenario as not evaluable (NE) and the +# probabilities of BayesianQDM are NA. +# EXPLAINED the difference is at most the total probability of the +# outcomes whose posterior probability of the Go or NoGo region +# is within 0.01 of its threshold, plus 0.00005. The article and +# BayesianQDM both estimate these posterior probabilities by +# Monte Carlo simulation, so the decisions for these outcomes can +# differ (reason "bivariate_mc"). +# FAIL otherwise. +# +# This file defines validate_yamaguchi_binary2(); run_validation.R calls it. + +yamaguchi_binary2_design <- function(table, gamma_go, gamma_nogo, nMC) { + prior <- prior_dirichlet(rep(0.25, 4)) + if (table == "3") { + criterion <- criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = gamma_go, + gamma_nogo = gamma_nogo, + go_regions = 1L, nogo_regions = 9L) + return(design_binary2(n_t = 10, n_c = 10, prior_t = prior, + prior_c = prior, criterion = criterion, nMC = nMC)) + } + criterion <- criterion_posterior(theta_tv = c(0.15, 0.25), + theta_mav = c(0.10, 0.15), + gamma_go = gamma_go, + gamma_nogo = gamma_nogo, + go_regions = 1:2, nogo_regions = 9L) + external_t <- NULL + external_c <- NULL + if (table == "S1") { + external_t <- borrow(data_binary2(c(2, 1, 1, 2)), 0.7) + external_c <- borrow(data_binary2(c(14, 2, 3, 1)), 0.5) + } + design_binary2(n_t = 8, n_c = 8, prior_t = prior, prior_c = prior, + criterion = criterion, external_t = external_t, + external_c = external_c, nMC = nMC) +} + +yamaguchi_binary2_verdict <- function(res, rounding = 0.00005 + 1e-9) { + diff <- pmax(abs(res$Go - res$pub_Go), abs(res$NoGo - res$pub_NoGo), + abs(res$Gray - res$pub_Gray)) + ne <- is.na(res$pub_Go) + verdict <- ifelse(diff <= rounding, "PASS", + ifelse(diff <= res$sensitivity + rounding, "EXPLAINED", + "FAIL")) + verdict[ne] <- ifelse(is.na(res$Go[ne]), "PASS", "FAIL") + verdict[!ne & is.na(diff)] <- "FAIL" + data.frame(max_abs_diff = diff, verdict = verdict, + reason = ifelse(verdict == "EXPLAINED", "bivariate_mc", + ifelse(ne & verdict == "PASS", + "not evaluable in both", ""))) +} + +validate_yamaguchi_binary2 <- function(ref_file, nMC = 50000L, delta = 0.01, + seed = 1L) { + ref <- utils::read.csv(ref_file, stringsAsFactors = FALSE, + colClasses = c(table = "character")) + control <- list("3" = c(0.15, 0.20), S1 = c(0.20, 0.15), + S2 = c(0.20, 0.15)) + res <- vector("list", length(control)) + for (g in seq_along(control)) { + tab <- names(control)[g] + d <- ref[ref$table == tab, ] + pi_c <- control[[tab]] + scen <- data.frame(pi_t1 = pi_c[1] + d$theta1, + pi_t2 = pi_c[2] + d$theta2, rho_t = d$rho, + pi_c1 = pi_c[1], pi_c2 = pi_c[2], rho_c = d$rho) + # The posterior probabilities of the regions do not depend on the + # thresholds or the scenario, so the outcomes are enumerated once per + # table (with the thresholds of the first panel) and the operating + # characteristics of each panel are computed from the same sample. + des <- yamaguchi_binary2_design(tab, d$gamma_go[1], d$gamma_nogo[1], + nMC) + scen <- BayesianQDM:::check_scenarios(des, scen) + s <- withCallingHandlers( + BayesianQDM:::with_seed(seed, BayesianQDM:::oc_sample(des, scen, 1L)), + warning = function(w) { + if (grepl("not evaluable", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + }) + oc <- matrix(NA_real_, nrow(d), 4L) + sens <- rep(NA_real_, nrow(d)) + for (k in unique(paste(d$gamma_go, d$gamma_nogo))) { + rows <- which(paste(d$gamma_go, d$gamma_nogo) == k) + gg <- d$gamma_go[rows[1]] + gn <- d$gamma_nogo[rows[1]] + oc[rows, ] <- BayesianQDM:::oc_from_sample(s, gg, gn)[rows, ] + near <- abs(s$p_go - gg) < delta | abs(s$p_nogo - gn) < delta + sens[rows] <- BayesianQDM:::outcome_prob(near, s)[rows] + } + res[[g]] <- data.frame( + table = d$table, panel = d$panel, rho = d$rho, + gamma_go = d$gamma_go, gamma_nogo = d$gamma_nogo, + theta1 = d$theta1, theta2 = d$theta2, + Go = oc[, 1L], NoGo = oc[, 2L], Gray = oc[, 3L], Miss = oc[, 4L], + pub_Go = d$Go, pub_NoGo = d$NoGo, pub_Gray = d$Gray, + sensitivity = sens, stringsAsFactors = FALSE + ) + } + res <- do.call(rbind, res) + rownames(res) <- NULL + cbind(res, yamaguchi_binary2_verdict(res)) +} + +# Self-check: shifting every published Go probability by 0.15 (about twice +# the largest sensitivity) must give FAIL for all evaluable scenarios, so the +# comparison is not vacuous. +yamaguchi_binary2_self_check <- function(res) { + shifted <- res + shifted$pub_Go <- shifted$pub_Go + 0.15 + v <- yamaguchi_binary2_verdict(shifted)$verdict + ok_rows <- !is.na(res$pub_Go) + list(n_evaluable = sum(ok_rows), n_fail = sum(v[ok_rows] == "FAIL"), + ok = all(v[ok_rows] == "FAIL"), + max_sensitivity = max(res$sensitivity[ok_rows])) +} diff --git a/inst/validation/validate_yamaguchi_continuous2.R b/inst/validation/validate_yamaguchi_continuous2.R new file mode 100644 index 0000000..da442f8 --- /dev/null +++ b/inst/validation/validate_yamaguchi_continuous2.R @@ -0,0 +1,202 @@ +# Validation against Yamaguchi, Hu, Huang, Han, Homma and Wang (submitted), +# Table 4 (case study 2, posterior criterion) and Supplemental Table S3 (case +# study 4, predictive criterion): operating characteristics of two continuous +# endpoints for three correlations (rho_t = rho_c) and sixteen pairs of +# treatment effects. The published values (four decimals) are in +# bivariate_continuous2_tables.csv, extracted from the article and its +# supplement by Python_reference/extract_bivariate_tables.py in the work +# folder. +# +# Settings (article Section 3.2 and Supplemental Section S1.2): +# Table 4 n_t = n_c = 30, NIW priors with mu0 = (0, 1) (treatment) and +# (-10, -1) (control), kappa0 = 0.1, nu0 = 4, +# Lambda0 = (80^2, 15; 15, 6^2); control means (-10, -1), +# standard deviations (80, 6); TV (10, 2), MAV (5, 1); Go region +# 1, NoGo region 9. +# S3 n_t = n_c = 12, NIW priors with mu0 = (1.984, 1.191) and +# (-0.5, -1.5), kappa0 = 0.1, nu0 = 4, Lambda0 = (25, 1; 1, 9); +# control means (-0.5, -1.5), standard deviations (5, 3); +# m_t = m_c = 50 future subjects, null values (1.984, 1.191); +# Go region 1, NoGo region 4. +# The article computes the decision probabilities by simulating studies +# (their number is not stated; 10000, the default of getgamma2cont() in +# version 0.1.0, is assumed) and the region probabilities by Monte Carlo +# simulation. BayesianQDM simulates nsim studies and uses the +# moment-matching approximation. +# +# Verdicts (one per scenario): +# PASS Go, NoGo and Gray agree within 0.00005 (rounding). +# EXPLAINED each of Go, NoGo and Gray differs by at most +# 4 sqrt(p (1 - p) (1 / 10000 + 1 / nsim)) + s + 0.00005, where +# p is the published probability and s the probability of the +# simulated studies whose probability of the Go or NoGo region +# is within 0.01 of its threshold (decisions that Monte Carlo +# error can change). +# Table 4: reason "bivariate_cont_mc" (simulation error). +# Table S3: reason "c1_predictive_scale": the article used the +# predictive scale ((1 + kappa) / kappa) Lambda / ((nu - 1) m), +# which BayesianQDM corrects to (1 / kappa + 1 / m) Lambda / +# (nu - 1) (inspection item C1). The verdict compares the +# published values with the computation using the scale of the +# article; the values of BayesianQDM are reported alongside. +# INFO Table S3, panel (c) (rho = 0.8): not reproduced with the +# stated thresholds by either scale (reason "s3_rho08"); the +# values are reported for information. +# FAIL otherwise. +# +# This file defines validate_yamaguchi_continuous2(); run_validation.R calls +# it. + +yamaguchi_continuous2_design <- function(table, gamma_go, gamma_nogo) { + if (table == "4") { + lam <- matrix(c(80 ^ 2, 15, 15, 6 ^ 2), 2L, 2L) + return(design_continuous2( + n_t = 30, n_c = 30, prior_t = prior_niw(c(0, 1), 0.1, 4, lam), + prior_c = prior_niw(c(-10, -1), 0.1, 4, lam), + criterion = criterion_posterior(theta_tv = c(10, 2), + theta_mav = c(5, 1), + gamma_go = gamma_go, + gamma_nogo = gamma_nogo, + go_regions = 1L, nogo_regions = 9L) + )) + } + lam <- matrix(c(25, 1, 1, 9), 2L, 2L) + design_continuous2( + n_t = 12, n_c = 12, prior_t = prior_niw(c(1.984, 1.191), 0.1, 4, lam), + prior_c = prior_niw(c(-0.5, -1.5), 0.1, 4, lam), + criterion = criterion_predictive(theta_null = c(1.984, 1.191), m_t = 50, + m_c = 50, gamma_go = gamma_go, + gamma_nogo = gamma_nogo, + go_regions = 1L, nogo_regions = 4L) + ) +} + +# Same computation as oc_sample() (with the same random numbers), but with +# the predictive scale of the article for both groups. +yamaguchi_continuous2_article_sample <- function(des, scen, nsim, seed) { + crit <- des$criterion + sets <- BayesianQDM:::region_sets(crit) + BayesianQDM:::with_seed(seed, { + draws_t <- BayesianQDM:::draws_continuous2(nsim, des$n_t) + draws_c <- BayesianQDM:::draws_continuous2(nsim, des$n_c) + }) + dist <- function(post, m) { + list(loc = post$mu, + scale = (1 + post$kappa) / post$kappa * post$Lambda / + (post$nu - 1) / m, + df = post$nu - 1) + } + p <- matrix(0, nsim * nrow(scen), 2L) + for (j in seq_len(nrow(scen))) { + sc <- scen[j, ] + st <- BayesianQDM:::stats_continuous2(draws_t, des$n_t, + c(sc$mu_t1, sc$mu_t2), + c(sc$sd_t1, sc$sd_t2), sc$rho_t) + sc_c <- BayesianQDM:::stats_continuous2(draws_c, des$n_c, + c(sc$mu_c1, sc$mu_c2), + c(sc$sd_c1, sc$sd_c2), sc$rho_c) + post_t <- BayesianQDM:::posterior_continuous2(des$prior_t, des$n_t, + st$mean, st$cov) + post_c <- BayesianQDM:::posterior_continuous2(des$prior_c, des$n_c, + sc_c$mean, sc_c$cov) + p[(j - 1L) * nsim + seq_len(nsim), ] <- + BayesianQDM:::region_prob_continuous2(crit, dist(post_t, crit$m_t), + dist(post_c, crit$m_c), + c(sets$go, sets$nogo), "MM") + } + list(p_go = matrix(p[, 1L], nsim), p_nogo = matrix(p[, 2L], nsim), + per_scenario = TRUE, + weights = matrix(1 / nsim, nsim, nrow(scen))) +} + +yamaguchi_continuous2_verdict <- function(res, nsim, b_article = 10000, + rounding = 0.00005 + 1e-9) { + dec <- c("Go", "NoGo", "Gray") + diff <- sapply(dec, function(d) abs(res[[d]] - res[[paste0("pub_", d)]])) + tol <- sapply(dec, function(d) { + p <- pmin(pmax(res[[paste0("pub_", d)]], 0), 1) + 4 * sqrt(p * (1 - p) * (1 / b_article + 1 / nsim)) + res$sensitivity + + rounding + }) + diff <- matrix(diff, ncol = 3L) + tol <- matrix(tol, ncol = 3L) + max_diff <- apply(diff, 1L, max) + verdict <- ifelse(max_diff <= rounding, "PASS", + ifelse(rowSums(diff > tol) == 0, "EXPLAINED", "FAIL")) + reason <- ifelse(verdict == "EXPLAINED", + ifelse(res$table == "4", "bivariate_cont_mc", + "c1_predictive_scale"), "") + info <- res$table == "S3" & abs(res$rho - 0.8) < 1e-9 + verdict[info] <- "INFO" + reason[info] <- "s3_rho08" + data.frame(max_abs_diff = max_diff, + max_ratio = apply(diff / tol, 1L, max), verdict = verdict, + reason = reason) +} + +validate_yamaguchi_continuous2 <- function(ref_file, nsim = 10000L, + delta = 0.01, seed = 1L) { + ref <- utils::read.csv(ref_file, stringsAsFactors = FALSE, + colClasses = c(table = "character")) + control <- list("4" = list(mu = c(-10, -1), sd = c(80, 6)), + S3 = list(mu = c(-0.5, -1.5), sd = c(5, 3))) + res <- vector("list", length(control)) + for (g in seq_along(control)) { + tab <- names(control)[g] + d <- ref[ref$table == tab, ] + cc <- control[[tab]] + scen <- data.frame(mu_t1 = cc$mu[1] + d$theta1, + mu_t2 = cc$mu[2] + d$theta2, sd_t1 = cc$sd[1], + sd_t2 = cc$sd[2], rho_t = d$rho, mu_c1 = cc$mu[1], + mu_c2 = cc$mu[2], sd_c1 = cc$sd[1], sd_c2 = cc$sd[2], + rho_c = d$rho) + # The probabilities of the regions do not depend on the thresholds, so + # the studies are simulated once per table (with the thresholds of the + # first panel) and the decisions of each panel are computed from them. + des <- yamaguchi_continuous2_design(tab, d$gamma_go[1], d$gamma_nogo[1]) + scen <- BayesianQDM:::check_scenarios(des, scen) + s <- BayesianQDM:::with_seed(seed, + BayesianQDM:::oc_sample(des, scen, nsim)) + if (tab == "S3") { + s_article <- yamaguchi_continuous2_article_sample(des, scen, nsim, seed) + } + oc <- matrix(NA_real_, nrow(d), 4L) + oc_pkg <- matrix(NA_real_, nrow(d), 4L) + sens <- rep(NA_real_, nrow(d)) + for (k in unique(paste(d$gamma_go, d$gamma_nogo))) { + rows <- which(paste(d$gamma_go, d$gamma_nogo) == k) + gg <- d$gamma_go[rows[1]] + gn <- d$gamma_nogo[rows[1]] + oc_pkg[rows, ] <- BayesianQDM:::oc_from_sample(s, gg, gn)[rows, ] + s_v <- if (tab == "S3") s_article else s + oc[rows, ] <- BayesianQDM:::oc_from_sample(s_v, gg, gn)[rows, ] + near <- abs(s_v$p_go - gg) < delta | abs(s_v$p_nogo - gn) < delta + sens[rows] <- BayesianQDM:::outcome_prob(near, s_v)[rows] + } + res[[g]] <- data.frame( + table = d$table, panel = d$panel, rho = d$rho, + gamma_go = d$gamma_go, gamma_nogo = d$gamma_nogo, + theta1 = d$theta1, theta2 = d$theta2, + Go = oc[, 1L], NoGo = oc[, 2L], Gray = oc[, 3L], Miss = oc[, 4L], + pub_Go = d$Go, pub_NoGo = d$NoGo, pub_Gray = d$Gray, + sensitivity = sens, + package_Go = oc_pkg[, 1L], package_NoGo = oc_pkg[, 2L], + package_Gray = oc_pkg[, 3L], stringsAsFactors = FALSE + ) + } + res <- do.call(rbind, res) + rownames(res) <- NULL + cbind(res, yamaguchi_continuous2_verdict(res, nsim)) +} + +# Self-check: shifting every published Go probability by 0.2 (more than the +# largest tolerance) must give FAIL for all rows other than INFO, so the +# comparison is not vacuous. +yamaguchi_continuous2_self_check <- function(res, nsim) { + shifted <- res + shifted$pub_Go <- shifted$pub_Go + 0.2 + v <- yamaguchi_continuous2_verdict(shifted, nsim)$verdict + checked <- res$verdict != "INFO" + list(n_checked = sum(checked), n_fail = sum(v[checked] == "FAIL"), + ok = isTRUE(all(v[checked] == "FAIL"))) +} diff --git a/inst/validation/validate_yamaguchi_glaucoma.R b/inst/validation/validate_yamaguchi_glaucoma.R new file mode 100644 index 0000000..edaed23 --- /dev/null +++ b/inst/validation/validate_yamaguchi_glaucoma.R @@ -0,0 +1,29 @@ +# Validation against the glaucoma example of Yamaguchi, Homma, Takeda and +# Maruo (submitted), "Moment-matching approximation for t-differences in +# clinical trials with continuous endpoints", Section 5.2: treatment +# n = 36, mean -5.2, variance 15.62; control n = 31, mean -2.7, variance +# 13.28; vague priors. Published: P(Delta < 0 | data) = 0.9949 and +# P(Delta <= -2 | data) = 0.7011 (moment-matching approximation, four +# decimals). Both are checked with method = "NI" and method = "MM". + +validate_yamaguchi_glaucoma <- function() { + rows <- list() + for (method in c("NI", "MM")) { + des <- design_continuous(36, 31, prior_vague(), prior_vague(), + criterion_posterior(theta_tv = 0, + theta_mav = -2, + gamma_go = 0.8, + gamma_nogo = 0.6), + method = method) + res <- qdm_decide(des, data_continuous(36, -5.2, sqrt(15.62)), + data_continuous(31, -2.7, sqrt(13.28))) + study <- "Yamaguchi, Homma, Takeda and Maruo (submitted), Section 5.2" + rows <- c(rows, list( + number_row(study, "P(Delta < 0 | data)", "glaucoma example", method, + 0.9949, 1 - res$prob_go, 4), + number_row(study, "P(Delta <= -2 | data)", "glaucoma example", method, + 0.7011, res$prob_nogo, 4) + )) + } + do.call(rbind, rows) +} diff --git a/inst/validation/validation_helpers.R b/inst/validation/validation_helpers.R new file mode 100644 index 0000000..84e2646 --- /dev/null +++ b/inst/validation/validation_helpers.R @@ -0,0 +1,57 @@ +# Helpers for the validation of single published numbers (continuous +# endpoint). Each validate_*() function returns a data frame with one row per +# published number and the columns +# study, quantity, setting, method, published, computed, decimals, +# explain_tol, reason_explained, info +# and number_verdict() adds abs_diff, verdict and reason. +# +# Verdicts: +# PASS |computed - published| is at most half a unit of the last +# published decimal (rounding). +# EXPLAINED the difference is at most rounding + explain_tol, where +# explain_tol is set only for numbers that the article computed +# by Monte Carlo simulation; the reason is registered in +# run_validation.R. +# FAIL otherwise. +# INFO the published number could not be reproduced from the inputs +# stated in the article; the row records both values (the +# reason is registered in run_validation.R). + +number_row <- function(study, quantity, setting, method, published, computed, + decimals, explain_tol = NA_real_, + reason_explained = "", info = "") { + data.frame(study = study, quantity = quantity, setting = setting, + method = method, published = published, computed = computed, + decimals = decimals, explain_tol = explain_tol, + reason_explained = reason_explained, info = info, + stringsAsFactors = FALSE) +} + +number_verdict <- function(res) { + rounding <- 0.5 * 10 ^ (-res$decimals) + 1e-9 + diff <- abs(res$computed - res$published) + explained <- !is.na(res$explain_tol) & diff <= rounding + res$explain_tol + verdict <- ifelse(diff <= rounding, "PASS", + ifelse(explained, "EXPLAINED", "FAIL")) + reason <- ifelse(verdict == "EXPLAINED", res$reason_explained, "") + info <- nzchar(res$info) + verdict[info] <- "INFO" + reason[info] <- res$info[info] + out <- res[, c("study", "quantity", "setting", "method", "published", + "computed")] + out$abs_diff <- diff + out$verdict <- verdict + out$reason <- reason + out +} + +# Self-check: shifting every published number (except INFO rows) by 0.05 +# must give FAIL, so that the comparison is not vacuous. +number_self_check <- function(raw) { + checked <- !nzchar(raw$info) + shifted <- raw + shifted$published <- shifted$published + 0.05 + v <- number_verdict(shifted)$verdict[checked] + list(n_checked = sum(checked), n_fail = sum(v == "FAIL"), + ok = all(v == "FAIL")) +} diff --git a/man/BayesianQDM-package.Rd b/man/BayesianQDM-package.Rd new file mode 100644 index 0000000..f4fa3de --- /dev/null +++ b/man/BayesianQDM-package.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/BayesianQDM-package.R +\docType{package} +\name{BayesianQDM-package} +\alias{BayesianQDM} +\alias{BayesianQDM-package} +\title{BayesianQDM: Bayesian Quantitative Decision-Making for Clinical Trials} +\description{ +Tools for Go/NoGo/Gray decision-making in proof-of-concept clinical trials +under a Bayesian framework. A trial is described by small specification +objects (priors, data, external data with power priors, hypothetical +controls and decision criteria), and the decision rule is evaluated for +observed data or for its operating characteristics. +\code{vignette("overview", package = "BayesianQDM")} introduces the +package, and \code{vignette("migration", package = "BayesianQDM")} shows +how to translate code written for version 0.1.0. +} +\seealso{ +Useful links: +\itemize{ + \item \url{https://gosukehommaEX.github.io/BayesianQDM/} + \item \url{https://github.com/gosukehommaEX/BayesianQDM} + \item Report bugs at \url{https://github.com/gosukehommaEX/BayesianQDM/issues} +} + +} +\author{ +\strong{Maintainer}: Gosuke Homma \email{my.name.is.gosuke@gmail.com} + +Authors: +\itemize{ + \item Gosuke Homma \email{my.name.is.gosuke@gmail.com} + \item Yusuke Yamaguchi +} + +} +\keyword{internal} diff --git a/man/allmultinom.Rd b/man/allmultinom.Rd deleted file mode 100644 index a58fcc6..0000000 --- a/man/allmultinom.Rd +++ /dev/null @@ -1,64 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/allmultinom.R -\name{allmultinom} -\alias{allmultinom} -\title{Enumerate All Multinomial Count Vectors for a Bivariate Binary Outcome} -\usage{ -allmultinom(n) -} -\arguments{ -\item{n}{A single non-negative integer giving the sample size of the group -(\eqn{n_j}).} -} -\value{ -An integer matrix with \eqn{\binom{n_j + 3}{3}} rows and 4 columns -named \code{x00}, \code{x01}, \code{x10}, \code{x11}. -Each row is a distinct non-negative integer solution to -\eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j}. -Rows are ordered by \code{x00} (ascending), then \code{x10} -(ascending), then \code{x01} (ascending). -} -\description{ -Generates the complete set of non-negative integer vectors -\eqn{(x_{00}, x_{01}, x_{10}, x_{11})} satisfying -\eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j}, where \eqn{n_j} is the -sample size of group \eqn{j \in \{t, c\}}. Each row of the returned matrix -corresponds to one possible realisation of the aggregated bivariate binary -counts. This enumeration is a prerequisite for exact operating -characteristic assessment in \code{\link{pbayesdecisionprob2bin}}. -} -\details{ -The number of non-negative integer solutions to -\eqn{x_{00} + x_{01} + x_{10} + x_{11} = n_j} is the stars-and-bars count -\deqn{\binom{n_j + 3}{3} = \frac{(n_j + 1)(n_j + 2)(n_j + 3)}{6}.} -For example, \eqn{n_j = 10} yields 286 rows and \eqn{n_j = 20} yields -1771 rows. The matrix is pre-allocated to avoid repeated memory -reallocation, making the function efficient for the sample sizes typical -in rare-disease proof-of-concept studies. - -This function is an internal computational building block used by -\code{\link{pbayesdecisionprob2bin}} to enumerate the sample space over -which multinomial probabilities and decision indicators are summed when -computing exact operating characteristics. -} -\examples{ -# Example 1: n = 2 (smallest non-trivial case) -allmultinom(2) - -# Example 2: n = 10 (typical rare-disease PoC group size) -mat <- allmultinom(10) -nrow(mat) # Should be choose(13, 3) = 286 -all(rowSums(mat) == 10) # Every row must sum to n - -# Example 3: n = 0 (edge case - only the all-zero row) -allmultinom(0) - -# Example 4: Verify column names -colnames(allmultinom(5)) - -# Example 5: Row counts match the stars-and-bars formula -n <- 15L -mat <- allmultinom(n) -nrow(mat) == choose(n + 3L, 3L) # Should be TRUE - -} diff --git a/man/borrow.Rd b/man/borrow.Rd new file mode 100644 index 0000000..314fdce --- /dev/null +++ b/man/borrow.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/borrow.R +\name{borrow} +\alias{borrow} +\title{External data borrowed through a power prior} +\usage{ +borrow(data, a0) +} +\arguments{ +\item{data}{External data created by \code{\link{data_binary}}, +\code{\link{data_continuous}}, \code{\link{data_binary2}}, +\code{\link{data_continuous2}} or \code{\link{data_tte}}.} + +\item{a0}{Power prior weight, a number from 0 to 1.} +} +\value{ +An object of class \code{"qdm_borrow"} with elements \code{data} and +\code{a0}. +} +\description{ +Specifies external (historical) data for one group together with the +power prior weight \eqn{a_0}. The likelihood of the external data is raised +to the power \eqn{a_0}, so that \eqn{a_0 = 0} ignores the external data and +\eqn{a_0 = 1} pools it with the current data. For the conjugate models used +in this package the resulting posterior distribution has a closed form, so +no Markov chain Monte Carlo sampling is needed. +} +\examples{ +borrow(data_binary(n = 20, y = 8), a0 = 0.5) +} diff --git a/man/cellprob_binary2.Rd b/man/cellprob_binary2.Rd new file mode 100644 index 0000000..989685a --- /dev/null +++ b/man/cellprob_binary2.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/cellprob_binary2.R +\name{cellprob_binary2} +\alias{cellprob_binary2} +\title{Joint cell probabilities of two binary endpoints} +\usage{ +cellprob_binary2(pi1, pi2, rho, tol = 1e-10) +} +\arguments{ +\item{pi1}{Response rate of endpoint 1, strictly between 0 and 1.} + +\item{pi2}{Response rate of endpoint 2, strictly between 0 and 1.} + +\item{rho}{Correlation between the two endpoints.} + +\item{tol}{Tolerance for the feasibility check.} +} +\value{ +A named numeric vector of the probabilities of the cells +\code{"00"}, \code{"01"}, \code{"10"} and \code{"11"} (first digit: +endpoint 1; second digit: endpoint 2), summing to 1. +} +\description{ +Converts the marginal response rates of two binary endpoints and their +correlation into the probabilities of the four joint response patterns. +} +\details{ +For two Bernoulli variables with response rates \eqn{\pi_1} and +\eqn{\pi_2}, the Pearson correlation \eqn{\rho} determines +\deqn{p_{11} = \pi_1 \pi_2 + \rho \sqrt{\pi_1 (1 - \pi_1) \pi_2 (1 - \pi_2)},} +and \eqn{p_{10} = \pi_1 - p_{11}}, \eqn{p_{01} = \pi_2 - p_{11}}, +\eqn{p_{00} = 1 - p_{10} - p_{01} - p_{11}}. All four probabilities are +non-negative only if +\eqn{\max(0, \pi_1 + \pi_2 - 1) \le p_{11} \le \min(\pi_1, \pi_2)}, which +bounds the feasible range of \eqn{\rho}. An error is raised if \code{rho} +is outside this range by more than \code{tol}. +} +\examples{ +cellprob_binary2(pi1 = 0.3, pi2 = 0.4, rho = 0.3) +} +\seealso{ +Other distributions: +\code{\link[=pbetabinomdiff]{pbetabinomdiff()}}, +\code{\link[=pbetadiff]{pbetadiff()}}, +\code{\link[=psurvdiff]{psurvdiff()}}, +\code{\link[=ptdiff]{ptdiff()}}, +\code{\link[=rdirichlet]{rdirichlet()}} +} +\concept{distributions} diff --git a/man/conduct_tte.Rd b/man/conduct_tte.Rd new file mode 100644 index 0000000..68e70c0 --- /dev/null +++ b/man/conduct_tte.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/conduct_tte.R +\name{conduct_tte} +\alias{conduct_tte} +\title{Conduct of a study with a time-to-event endpoint} +\usage{ +conduct_tte( + accrual_time, + accrual_rate = rep(1, length(accrual_time) - 1L), + dropout_time = 0, + dropout_hazard = 0, + cut_time = NULL, + cut_events = NULL +) +} +\arguments{ +\item{accrual_time}{Boundaries of the enrollment intervals: an increasing +numeric vector that starts at 0, of length at least 2.} + +\item{accrual_rate}{Non-negative relative enrollment rates of the +intervals, one fewer than \code{accrual_time}, with a positive sum. The +default is a constant rate (uniform enrollment).} + +\item{dropout_time}{Start times of the pieces of the dropout hazard: an +increasing numeric vector that starts at 0.} + +\item{dropout_hazard}{Non-negative dropout hazards of the pieces, of the +same length as \code{dropout_time}. The default \code{0} means no +dropout.} + +\item{cut_time}{Calendar time of the analysis after the start of +enrollment (positive), or \code{NULL}.} + +\item{cut_events}{Number of events that triggers the analysis (a whole +number of at least 1), or \code{NULL}. Exactly one of \code{cut_time} and +\code{cut_events} must be given.} +} +\value{ +An object of class \code{"qdm_conduct"} with the arguments and the +element \code{accrual_cum}, the cumulative probabilities of enrollment +at the ends of the intervals. +} +\description{ +Specifies how subjects are enrolled, how they drop out and when the +analysis takes place. The operating characteristics of a design with a +time-to-event endpoint (\code{\link{design_tte}}) are computed by +simulating studies conducted in this way, and the posterior predictive +probabilities by simulating future studies. +} +\details{ +The subjects of all groups are enrolled at independent times with a +piecewise uniform distribution: the enrollment period is divided by +\code{accrual_time}, and the probability of an interval is proportional +to its rate in \code{accrual_rate} times its length (only the relative +rates matter). The dropout time of a subject, measured from enrollment, +has a piecewise exponential distribution with hazard +\code{dropout_hazard[j]} from time \code{dropout_time[j]} (the last hazard +applies until infinity), independently of the event time. The analysis +takes place at the calendar time \code{cut_time} after the start of +enrollment, or at the calendar time of the \code{cut_events}-th event +among all subjects of the study (if fewer events occur, all subjects are +followed until their event or dropout). A subject enrolled at time +\eqn{e} with event time \eqn{T} and dropout time \eqn{C} contributes the +observed time \eqn{\min(T, C, \textrm{cut} - e)} (0 if enrolled after the +analysis) and an event if \eqn{T \le C} and \eqn{e + T \le \textrm{cut}}. +} +\examples{ +# Enrollment over 15 months with increasing rates, dropout hazard 0.00226 +# per month, analysis 15.44 months after the start of enrollment +conduct_tte(accrual_time = c(0, 5, 10, 15), accrual_rate = c(0.4, 2, 4.5), + dropout_hazard = 0.00226, cut_time = 15.44) + +# Uniform enrollment over 12 months, analysis at the 20th event +conduct_tte(accrual_time = c(0, 12), cut_events = 20) +} +\seealso{ +\code{\link{design_tte}} +} diff --git a/man/criterion_posterior.Rd b/man/criterion_posterior.Rd new file mode 100644 index 0000000..1094e4b --- /dev/null +++ b/man/criterion_posterior.Rd @@ -0,0 +1,110 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/criterion_posterior.R +\name{criterion_posterior} +\alias{criterion_posterior} +\title{Decision criterion based on posterior probability} +\usage{ +criterion_posterior( + theta_tv, + theta_mav, + gamma_go, + gamma_nogo, + go_regions = 1L, + nogo_regions = 9L, + rule = c("joint", "and", "or") +) +} +\arguments{ +\item{theta_tv}{Target value (TV) of the treatment effect: a number for one +endpoint or a numeric vector of length 2 for two endpoints.} + +\item{theta_mav}{Minimum acceptable value (MAV) of the treatment effect, of +the same length as \code{theta_tv}. Each element must be smaller than the +corresponding element of \code{theta_tv}.} + +\item{gamma_go}{Probability threshold for the Go criterion, strictly +between 0 and 1. With \code{rule = "and"} or \code{"or"}, one threshold +per endpoint (a single number is used for both).} + +\item{gamma_nogo}{Probability threshold for the NoGo criterion, strictly +between 0 and 1, given in the same way as \code{gamma_go}.} + +\item{go_regions}{Region numbers (from 1 to 9) forming the Go region for two +endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +default, region 1, requires both effects to exceed their target values.} + +\item{nogo_regions}{Region numbers (from 1 to 9) forming the NoGo region for +two endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +default, region 9, requires both effects to be at most their minimum +acceptable values.} + +\item{rule}{For two endpoints, \code{"joint"} (the default; probabilities +of unions of regions), \code{"and"} or \code{"or"} (marginal +probabilities of each endpoint, combined with AND or OR). Ignored for one +endpoint.} +} +\value{ +An object of class +\code{c("qdm_criterion_posterior", "qdm_criterion")}. +} +\description{ +Specifies a Go/NoGo decision criterion based on the posterior probability +of the treatment effect \eqn{\theta} (the difference between the treatment +and control groups) given the proof-of-concept data \eqn{D}. +} +\details{ +For one endpoint, the Go region is \eqn{\theta > \theta_{TV}} and the NoGo +region is \eqn{\theta \le \theta_{MAV}}. The Go criterion is +\eqn{\Pr(\theta > \theta_{TV} \mid D) \ge \gamma_{go}} and the NoGo +criterion is \eqn{\Pr(\theta \le \theta_{MAV} \mid D) \ge \gamma_{nogo}}. +In the notation of Kang et al. (2026), where the NoGo criterion is +\eqn{\Pr(\theta > \theta_{MAV} \mid D) \le \gamma_2}, this corresponds to +\eqn{\gamma_{nogo} = 1 - \gamma_2}. + +For two endpoints, the target values and minimum acceptable values divide +the plane of \eqn{(\theta_1, \theta_2)} into nine regions (see +\code{\link{qdm_regions}}). The Go criterion is that the posterior +probability of the union of \code{go_regions} is at least +\eqn{\gamma_{go}}, and the NoGo criterion is that the posterior probability +of the union of \code{nogo_regions} is at least \eqn{\gamma_{nogo}} +(Yamaguchi et al., submitted, equations 2 and 3). With \code{rule = "and"} +or \code{"or"}, the criteria are instead based on the marginal posterior +probabilities of each endpoint (equations 4 and 5): the Go criterion is +\eqn{\Pr(\theta_1 > \theta_{TV1} \mid D) \ge \gamma_{go1}} and (or) +\eqn{\Pr(\theta_2 > \theta_{TV2} \mid D) \ge \gamma_{go2}}, and the NoGo +criterion is \eqn{\Pr(\theta_1 \le \theta_{MAV1} \mid D) \ge +\gamma_{nogo1}} and (or) +\eqn{\Pr(\theta_2 \le \theta_{MAV2} \mid D) \ge \gamma_{nogo2}}. + +The decision is Go if only the Go criterion is met, NoGo if only the NoGo +criterion is met, Gray if neither is met, and Miss if both are met. For one +endpoint, Miss can occur only when \eqn{\gamma_{go} + \gamma_{nogo} \le 1}. +} +\examples{ +# One endpoint +criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) + +# Two endpoints +criterion_posterior(theta_tv = c(0.2, 0.15), theta_mav = c(0.1, 0.05), + gamma_go = 0.3, gamma_nogo = 0.4) + +# Two endpoints, marginal criteria combined with AND +criterion_posterior(theta_tv = c(0.2, 0.15), theta_mav = c(0.1, 0.05), + gamma_go = c(0.6, 0.5), gamma_nogo = 0.7, rule = "and") +} +\references{ +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. \emph{Journal of Biopharmaceutical Statistics}. +\doi{10.1080/10543406.2026.2655410} + +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. +} +\seealso{ +Other criteria: +\code{\link[=criterion_predictive]{criterion_predictive()}} +} +\concept{criteria} diff --git a/man/criterion_predictive.Rd b/man/criterion_predictive.Rd new file mode 100644 index 0000000..33a785f --- /dev/null +++ b/man/criterion_predictive.Rd @@ -0,0 +1,93 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/criterion_predictive.R +\name{criterion_predictive} +\alias{criterion_predictive} +\title{Decision criterion based on posterior predictive probability} +\usage{ +criterion_predictive( + theta_null, + m_t, + m_c = m_t, + gamma_go, + gamma_nogo, + go_regions = 1L, + nogo_regions = 4L, + rule = c("joint", "and", "or") +) +} +\arguments{ +\item{theta_null}{Null value of the treatment effect in the future study: a +number for one endpoint or a numeric vector of length 2 for two +endpoints.} + +\item{m_t, m_c}{Numbers of subjects in the treatment and control groups of +the future study (whole numbers of at least 1).} + +\item{gamma_go}{Probability threshold for the Go criterion, strictly +between 0 and 1. With \code{rule = "and"} or \code{"or"}, one threshold +per endpoint (a single number is used for both).} + +\item{gamma_nogo}{Probability threshold for the NoGo criterion, strictly +between 0 and 1, given in the same way as \code{gamma_go}.} + +\item{go_regions}{Region numbers (from 1 to 4) forming the Go region for two +endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +default, region 1, requires both future effects to exceed their null +values.} + +\item{nogo_regions}{Region numbers (from 1 to 4) forming the NoGo region for +two endpoints with \code{rule = "joint"}. Ignored for one endpoint. The +default, region 4, requires both future effects to be at most their null +values.} + +\item{rule}{For two endpoints, \code{"joint"} (the default; probabilities +of unions of regions), \code{"and"} or \code{"or"} (marginal +probabilities of each endpoint, combined with AND or OR). Ignored for one +endpoint.} +} +\value{ +An object of class +\code{c("qdm_criterion_predictive", "qdm_criterion")}. +} +\description{ +Specifies a Go/NoGo decision criterion based on the posterior predictive +probability of the treatment effect \eqn{\tilde\theta} that will be +observed in a future study with \code{m_t} and \code{m_c} subjects in the +treatment and control groups, given the proof-of-concept data \eqn{D}. +The future effect is the difference between the future sample proportions +(binary endpoints) or sample means (continuous endpoints). +} +\details{ +For one endpoint, the Go region is \eqn{\tilde\theta > \theta_{NULL}} and +the NoGo region is \eqn{\tilde\theta \le \theta_{NULL}}. The Go criterion +is \eqn{\Pr(\tilde\theta > \theta_{NULL} \mid D) \ge \gamma_{go}} and the +NoGo criterion is +\eqn{\Pr(\tilde\theta \le \theta_{NULL} \mid D) \ge \gamma_{nogo}}. Because +the two probabilities add up to 1, a Gray decision is possible only when +\eqn{\gamma_{go} + \gamma_{nogo} > 1}, and Miss decisions can occur only when +\eqn{\gamma_{go} + \gamma_{nogo} \le 1}. + +For two endpoints, the null values divide the plane of +\eqn{(\tilde\theta_1, \tilde\theta_2)} into four regions (see +\code{\link{qdm_regions}}), and the criteria are based on the predictive +probabilities of the unions of \code{go_regions} and \code{nogo_regions} +(Yamaguchi et al., submitted, equations 7 and 8). With \code{rule = "and"} +or \code{"or"}, they are based on the marginal predictive probabilities of +each endpoint, \eqn{\Pr(\tilde\theta_k > \theta_{NULLk} \mid D)} for Go +and \eqn{\Pr(\tilde\theta_k \le \theta_{NULLk} \mid D)} for NoGo, +combined with AND or OR (equations 9 and 10). +} +\examples{ +criterion_predictive(theta_null = 0, m_t = 50, gamma_go = 0.9, + gamma_nogo = 0.7) +} +\references{ +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. +} +\seealso{ +Other criteria: +\code{\link[=criterion_posterior]{criterion_posterior()}} +} +\concept{criteria} diff --git a/man/data_binary.Rd b/man/data_binary.Rd new file mode 100644 index 0000000..5717cb2 --- /dev/null +++ b/man/data_binary.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_binary.R +\name{data_binary} +\alias{data_binary} +\title{Binary endpoint data} +\usage{ +data_binary(n, y) +} +\arguments{ +\item{n}{Number of subjects (a whole number of at least 1).} + +\item{y}{Number of responders (a whole number from 0 to \code{n}).} +} +\value{ +An object of class \code{c("qdm_data_binary", "qdm_data")} with +integer elements \code{n} and \code{y}. +} +\description{ +Summarizes the data of one group for a single binary endpoint as the number +of subjects and the number of responders. Used for observed proof-of-concept +data, external data and hypothetical control data. +} +\examples{ +data_binary(n = 12, y = 7) +} +\seealso{ +Other data: +\code{\link[=data_binary2]{data_binary2()}}, +\code{\link[=data_continuous]{data_continuous()}}, +\code{\link[=data_continuous2]{data_continuous2()}}, +\code{\link[=data_tte]{data_tte()}} +} +\concept{data} diff --git a/man/data_binary2.Rd b/man/data_binary2.Rd new file mode 100644 index 0000000..0922b11 --- /dev/null +++ b/man/data_binary2.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_binary2.R +\name{data_binary2} +\alias{data_binary2} +\title{Data for two binary endpoints} +\usage{ +data_binary2(counts) +} +\arguments{ +\item{counts}{A numeric vector of four non-negative whole numbers in the +cell order \code{"00"}, \code{"01"}, \code{"10"}, \code{"11"}, with a +total of at least 1.} +} +\value{ +An object of class \code{c("qdm_data_binary2", "qdm_data")} with +elements \code{n} (the total count) and \code{counts} (a named integer +vector of length 4). +} +\description{ +Summarizes the data of one group for two binary endpoints by the counts of +the four joint response patterns. +} +\details{ +The cells are ordered as \code{"00"}, \code{"01"}, \code{"10"} and +\code{"11"}, where the first digit is the response on endpoint 1 and the +second digit is the response on endpoint 2 (1 = response, 0 = no +response). +} +\examples{ +data_binary2(c(4, 2, 3, 6)) +} +\seealso{ +Other data: +\code{\link[=data_binary]{data_binary()}}, +\code{\link[=data_continuous]{data_continuous()}}, +\code{\link[=data_continuous2]{data_continuous2()}}, +\code{\link[=data_tte]{data_tte()}} +} +\concept{data} diff --git a/man/data_continuous.Rd b/man/data_continuous.Rd new file mode 100644 index 0000000..7f8cfbf --- /dev/null +++ b/man/data_continuous.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_continuous.R +\name{data_continuous} +\alias{data_continuous} +\title{Continuous endpoint data} +\usage{ +data_continuous(n, mean, sd) +} +\arguments{ +\item{n}{Number of subjects (a whole number of at least 2).} + +\item{mean}{Sample mean.} + +\item{sd}{Sample standard deviation (positive).} +} +\value{ +An object of class \code{c("qdm_data_continuous", "qdm_data")} with +elements \code{n}, \code{mean} and \code{sd}. +} +\description{ +Summarizes the data of one group for a single continuous endpoint by its +sufficient statistics: the number of subjects, the sample mean and the +sample standard deviation (with divisor \code{n - 1}). +} +\examples{ +data_continuous(n = 12, mean = 3.2, sd = 2.0) +} +\seealso{ +Other data: +\code{\link[=data_binary]{data_binary()}}, +\code{\link[=data_binary2]{data_binary2()}}, +\code{\link[=data_continuous2]{data_continuous2()}}, +\code{\link[=data_tte]{data_tte()}} +} +\concept{data} diff --git a/man/data_continuous2.Rd b/man/data_continuous2.Rd new file mode 100644 index 0000000..96be6cb --- /dev/null +++ b/man/data_continuous2.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_continuous2.R +\name{data_continuous2} +\alias{data_continuous2} +\title{Data for two continuous endpoints} +\usage{ +data_continuous2(n, mean, cov) +} +\arguments{ +\item{n}{Number of subjects (a whole number of at least 3).} + +\item{mean}{Numeric vector of length 2, the sample means of endpoints 1 and +2.} + +\item{cov}{A 2 x 2 symmetric positive definite sample covariance matrix.} +} +\value{ +An object of class \code{c("qdm_data_continuous2", "qdm_data")} +with elements \code{n}, \code{mean} and \code{cov}. +} +\description{ +Summarizes the data of one group for two continuous endpoints by their +sufficient statistics: the number of subjects, the vector of sample means +and the sample covariance matrix (with divisor \code{n - 1}). +} +\examples{ +data_continuous2(n = 12, mean = c(3.2, 1.5), + cov = matrix(c(4, 1.2, 1.2, 2), nrow = 2)) +} +\seealso{ +Other data: +\code{\link[=data_binary]{data_binary()}}, +\code{\link[=data_binary2]{data_binary2()}}, +\code{\link[=data_continuous]{data_continuous()}}, +\code{\link[=data_tte]{data_tte()}} +} +\concept{data} diff --git a/man/data_tte.Rd b/man/data_tte.Rd new file mode 100644 index 0000000..4a05aa8 --- /dev/null +++ b/man/data_tte.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data_tte.R +\name{data_tte} +\alias{data_tte} +\title{Time-to-event endpoint data} +\usage{ +data_tte(events, exposure) +} +\arguments{ +\item{events}{Number of events (a whole number of at least 0).} + +\item{exposure}{Total observed time (positive), in the same unit as the +milestone time of the design.} +} +\value{ +An object of class \code{c("qdm_data_tte", "qdm_data")} with +elements \code{events} and \code{exposure}. +} +\description{ +Summarizes the data of one group for a time-to-event endpoint by the +sufficient statistics of the exponential model: the number of events and +the total observed time (the sum over subjects of the time from entry to +the event or censoring). Used for observed proof-of-concept data, external +data and hypothetical control data. +} +\details{ +With exponential event times and independent censoring, the likelihood of +the hazard \eqn{\lambda} is proportional to +\eqn{\lambda^d \exp(-\lambda E)} for \eqn{d} events and total observed +time \eqn{E}, so these two numbers are all that the analysis needs. +} +\examples{ +data_tte(events = 5, exposure = 40) +} +\seealso{ +Other data: +\code{\link[=data_binary]{data_binary()}}, +\code{\link[=data_binary2]{data_binary2()}}, +\code{\link[=data_continuous]{data_continuous()}}, +\code{\link[=data_continuous2]{data_continuous2()}} +} +\concept{data} diff --git a/man/design_binary.Rd b/man/design_binary.Rd new file mode 100644 index 0000000..14a12f9 --- /dev/null +++ b/man/design_binary.Rd @@ -0,0 +1,132 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design_binary.R +\name{design_binary} +\alias{design_binary} +\title{Design with one binary endpoint} +\usage{ +design_binary( + n_t, + n_c, + prior_t, + prior_c = NULL, + criterion, + external_t = NULL, + external_c = NULL, + hypothetical_c = NULL, + fixed_c = NULL +) +} +\arguments{ +\item{n_t}{Number of subjects in the treatment group (a whole number of at +least 1).} + +\item{n_c}{Number of subjects in the concurrent control group (a whole +number of at least 0).} + +\item{prior_t, prior_c}{Beta prior distributions of the response rates of +the treatment and control groups, created by \code{\link{prior_beta}}. +\code{prior_c} must be \code{NULL} (the default) for a fixed control and +is required otherwise.} + +\item{criterion}{Decision criterion for one endpoint, created by +\code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}.} + +\item{external_t, external_c}{External data of the treatment and control +groups, created by \code{\link{borrow}} with \code{\link{data_binary}}, +or \code{NULL} (no external data).} + +\item{hypothetical_c}{Hypothetical control, created by +\code{\link{hypothetical}} with \code{\link{data_binary}}, or +\code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{fixed_c}{Fixed control response rate, a number from 0 to 1, or +\code{NULL}. It can be used only when \code{n_c = 0}.} +} +\value{ +An object of class \code{c("qdm_design_binary", "qdm_design")}, a +list with the arguments and the element \code{control} +(\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +\code{"fixed"}). +} +\description{ +Specifies a proof-of-concept study with one binary endpoint: the sample +sizes, the prior distributions, the external data, the form of the control +group and the decision criterion. The design is used by +\code{\link{qdm_decide}}, \code{\link{qdm_oc}} and +\code{\link{qdm_calibrate}}. +} +\details{ +The response rates \eqn{\pi_t} and \eqn{\pi_c} of the treatment and control +groups have Beta prior distributions, and the treatment effect is +\eqn{\theta = \pi_t - \pi_c}. The control group takes one of four forms. +\describe{ +\item{Concurrent control}{\code{n_c} is at least 1. External control data +can be added through \code{external_c}.} +\item{External control only}{\code{n_c = 0} and \code{external_c} is +given. The distribution of \eqn{\pi_c} is the posterior distribution +given the external control data.} +\item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +given. The distribution of \eqn{\pi_c} is the posterior distribution +given the hypothetical control data. The hypothetical control +\eqn{\pi_c \sim \textrm{Beta}(\alpha_t + z, \beta_t + n_t - z)} of +Kang et al. (2026, Section 4.1.4) is obtained with \code{prior_c} equal +to \code{prior_t} and \code{hypothetical(data_binary(n_t, z))}.} +\item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +control response rate is a known value \eqn{\pi_c}, as in a single-arm +study compared with a benchmark. The posterior probabilities are +\eqn{\Pr(\pi_t > \theta_{TV} + \pi_c \mid D)} and +\eqn{\Pr(\pi_t \le \theta_{MAV} + \pi_c \mid D)}, computed from the +Beta posterior distribution of \eqn{\pi_t}. For the posterior +predictive criterion the future effect is \eqn{Y_t / m_t - \pi_c}, +where \eqn{Y_t} follows the Beta-binomial posterior predictive +distribution (a future effect that differs from the null value by less +than \eqn{10^{-10}} is treated as equal to it); \code{m_c} is not used. +\code{prior_c} is not used and must be \code{NULL}.} +} +External treatment data (\code{external_t}) can be used with any form of +the control group. External data enter through a power prior: with +external data of \eqn{n_e} subjects and \eqn{y_e} responders and weight +\eqn{a_0}, the posterior distribution of the response rate is +\eqn{\textrm{Beta}(\alpha + a_0 y_e + y, \beta + a_0 (n_e - y_e) + n - y)}. +} +\examples{ +# Concurrent control with external control data +design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8), + external_c = borrow(data_binary(n = 20, y = 8), a0 = 0.5) +) + +# Uncontrolled study with a hypothetical control +design_binary( + n_t = 12, n_c = 0, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_predictive(theta_null = 0, m_t = 50, + gamma_go = 0.9, gamma_nogo = 0.7), + hypothetical_c = hypothetical(data = data_binary(n = 12, y = 4)) +) + +# Single-arm study compared with a fixed control response rate of 0.2 +design_binary( + n_t = 20, n_c = 0, prior_t = prior_beta(1, 1), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.05, + gamma_go = 0.8, gamma_nogo = 0.8), + fixed_c = 0.2 +) +} +\references{ +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. \emph{Journal of Biopharmaceutical Statistics}. +\doi{10.1080/10543406.2026.2655410} +} +\seealso{ +Other designs: +\code{\link[=design_binary2]{design_binary2()}}, +\code{\link[=design_continuous]{design_continuous()}}, +\code{\link[=design_continuous2]{design_continuous2()}}, +\code{\link[=design_tte]{design_tte()}} +} +\concept{designs} diff --git a/man/design_binary2.Rd b/man/design_binary2.Rd new file mode 100644 index 0000000..9cb2a62 --- /dev/null +++ b/man/design_binary2.Rd @@ -0,0 +1,138 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design_binary2.R +\name{design_binary2} +\alias{design_binary2} +\title{Design with two binary endpoints} +\usage{ +design_binary2( + n_t, + n_c, + prior_t, + prior_c = NULL, + criterion, + external_t = NULL, + external_c = NULL, + hypothetical_c = NULL, + fixed_c = NULL, + nMC = 10000L, + enumerate = TRUE +) +} +\arguments{ +\item{n_t}{Number of subjects in the treatment group (a whole number of at +least 1).} + +\item{n_c}{Number of subjects in the concurrent control group (a whole +number of at least 0).} + +\item{prior_t, prior_c}{Dirichlet prior distributions of the four cell +probabilities of the treatment and control groups, created by +\code{\link{prior_dirichlet}}. \code{prior_c} must be \code{NULL} (the +default) for a fixed control and is required otherwise.} + +\item{criterion}{Decision criterion for two endpoints, created by +\code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}.} + +\item{external_t, external_c}{External data of the treatment and control +groups, created by \code{\link{borrow}} with +\code{\link{data_binary2}}, or \code{NULL} (no external data).} + +\item{hypothetical_c}{Hypothetical control, created by +\code{\link{hypothetical}} with \code{\link{data_binary2}}, or +\code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{fixed_c}{Fixed control response rates of endpoints 1 and 2, a numeric +vector of length 2 with values from 0 to 1, or \code{NULL}. It can be +used only when \code{n_c = 0}.} + +\item{nMC}{Number of Monte Carlo draws for posterior probabilities.} + +\item{enumerate}{Logical; if \code{TRUE} (the default), the operating +characteristics are computed by enumerating all outcomes, otherwise by +simulation.} +} +\value{ +An object of class \code{c("qdm_design_binary2", "qdm_design")}, +a list with the arguments and the element \code{control} +(\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +\code{"fixed"}). +} +\description{ +Specifies a proof-of-concept study with two binary endpoints: the sample +sizes, the Dirichlet prior distributions, the external data, the form of +the control group, the decision criterion for two endpoints and the +computation settings. The design is used by \code{\link{qdm_decide}}, +\code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +} +\details{ +The responses of a subject on the two endpoints fall into one of the four +cells \code{"00"}, \code{"01"}, \code{"10"} and \code{"11"} (first digit: +endpoint 1), whose probabilities have Dirichlet prior distributions in each +group (Yamaguchi et al., submitted, Appendix A.1). The treatment effects +are the differences of the marginal response rates, +\eqn{\theta_k = \pi_{tk} - \pi_{ck}} with \eqn{\pi_1 = p_{10} + p_{11}} and +\eqn{\pi_2 = p_{01} + p_{11}}. External data with counts \eqn{x_e} enter +through a power prior with weight \eqn{a_0}, which adds \eqn{a_0 x_e} to the +Dirichlet parameters. The control group takes one of four forms, as in +\code{\link{design_binary}}: a concurrent control group (\code{n_c} of at +least 1), external control data only (\code{n_c = 0} and +\code{external_c}), a hypothetical control (\code{n_c = 0} and +\code{hypothetical_c} created from \code{\link{data_binary2}}, whose counts +are added to \code{prior_c}; the hypothetical control distribution +Dir(beta) of Yamaguchi et al., Appendix A.1.6, is obtained with +\code{prior_c = prior_dirichlet(beta - counts)}), or a fixed control +(\code{n_c = 0} and \code{fixed_c}, the known response rates of the two +endpoints in the control group; \code{prior_c} must then be \code{NULL}). +With a fixed control, the posterior probabilities are estimated from draws +of the treatment distribution only, and the future effects of the +predictive criterion are \eqn{S_{tk} / m_t - \pi_{ck}} (a future effect +that differs from the null value by less than \eqn{10^{-10}} is treated as +equal to it; \code{m_c} is not used). + +The posterior probabilities of the regions (posterior criteria) are +estimated by Monte Carlo simulation with \code{nMC} draws from the +Dirichlet posterior distributions. The posterior predictive probabilities +(predictive criteria) are computed exactly: the future effects depend only +on the numbers of responders on each endpoint, whose joint distribution in +each group is obtained from the Dirichlet-multinomial distribution, and a +future effect equal to a null value is not counted as larger. + +For \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}, with +\code{enumerate = TRUE} all outcomes of the study are enumerated: there are +\code{choose(n + 3, 3)} outcomes in a group of \code{n} subjects (286 for +\code{n = 10}), and the probabilities of the regions are computed for +every pair of treatment and control outcomes, with the same Monte Carlo +draws for all pairs. For a posterior criterion the computing time is +proportional to the number of pairs times \code{nMC}, and enumeration is +limited to 1e7 pairs (for example, 24 subjects in each group). With +\code{enumerate = FALSE}, \code{nsim} studies are simulated under each +scenario, which is faster for large sample sizes. +} +\examples{ +# Case study 1 of Yamaguchi et al. (submitted), with a small nMC for speed +des <- design_binary2( + n_t = 10, n_c = 10, + prior_t = prior_dirichlet(rep(0.25, 4)), + prior_c = prior_dirichlet(rep(0.25, 4)), + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.263, gamma_nogo = 0.347), + nMC = 2000 +) +des +qdm_decide(des, data_t = data_binary2(c(3, 2, 2, 3)), + data_c = data_binary2(c(6, 2, 1, 1)), seed = 1) +} +\references{ +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. +} +\seealso{ +Other designs: +\code{\link[=design_binary]{design_binary()}}, +\code{\link[=design_continuous]{design_continuous()}}, +\code{\link[=design_continuous2]{design_continuous2()}}, +\code{\link[=design_tte]{design_tte()}} +} +\concept{designs} diff --git a/man/design_continuous.Rd b/man/design_continuous.Rd new file mode 100644 index 0000000..0fe1ace --- /dev/null +++ b/man/design_continuous.Rd @@ -0,0 +1,179 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design_continuous.R +\name{design_continuous} +\alias{design_continuous} +\title{Design with one continuous endpoint} +\usage{ +design_continuous( + n_t, + n_c, + prior_t, + prior_c = NULL, + criterion, + external_t = NULL, + external_c = NULL, + hypothetical_c = NULL, + fixed_c = NULL, + method = c("NI", "MM", "MC"), + nMC = 10000L +) +} +\arguments{ +\item{n_t}{Number of subjects in the treatment group (a whole number of at +least 2).} + +\item{n_c}{Number of subjects in the concurrent control group: 0 (no +concurrent control group) or a whole number of at least 2.} + +\item{prior_t, prior_c}{Prior distributions of the mean and variance of the +treatment and control groups, created by \code{\link{prior_nix}} or +\code{\link{prior_vague}}. \code{prior_c} must be \code{NULL} (the +default) for a hypothetical or fixed control and is required otherwise.} + +\item{criterion}{Decision criterion for one endpoint, created by +\code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}.} + +\item{external_t, external_c}{External data of the treatment and control +groups, created by \code{\link{borrow}} with +\code{\link{data_continuous}}, or \code{NULL} (no external data).} + +\item{hypothetical_c}{Hypothetical control, created by +\code{\link{hypothetical}} with \code{mean} (of length 1) and \code{r}, +or \code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{fixed_c}{Fixed control mean, a number, or \code{NULL}. It can be used +only when \code{n_c = 0}.} + +\item{method}{Method used to compute the probabilities: \code{"NI"} +(numerical integration, the default), \code{"MM"} (moment-matching +approximation, which requires the distributions of both group means to +have more than 4 degrees of freedom) or \code{"MC"} (Monte Carlo +simulation). See \code{\link{ptdiff}}. Numerical integration is exact +up to a small numerical error but is the slowest of the deterministic +methods: for operating characteristics, which need the probabilities for +many simulated studies, \code{"MM"} is faster by about two orders of +magnitude and is suited to exploring designs, and \code{"NI"} can be +used to confirm the chosen design. The computing time of \code{"MC"} is +proportional to \code{nMC}.} + +\item{nMC}{Number of Monte Carlo draws for \code{method = "MC"}.} +} +\value{ +An object of class \code{c("qdm_design_continuous", "qdm_design")}, +a list with the arguments and the element \code{control} +(\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +\code{"fixed"}). +} +\description{ +Specifies a proof-of-concept study with one normally distributed endpoint: +the sample sizes, the prior distributions, the external data, the form of +the control group, the decision criterion and the method used to compute +the probabilities. The design is used by \code{\link{qdm_decide}}, +\code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +} +\details{ +The outcomes of group \eqn{k} (\eqn{k = t, c}) follow +\eqn{N(\mu_k, \sigma_k^2)}, and the treatment effect is +\eqn{\theta = \mu_t - \mu_c}. With the Normal-Inverse-chi-squared prior +(\code{\link{prior_nix}}), the posterior distribution of +\eqn{(\mu_k, \sigma_k^2)} is Normal-Inverse-chi-squared with parameters +\eqn{(\mu_{nk}, \kappa_{nk}, \nu_{nk}, \sigma_{nk}^2)}, and the posterior +distribution of the mean is +\eqn{t_{\nu_{nk}}(\mu_{nk}, \sigma_{nk}^2 / \kappa_{nk})}. With the vague +prior (\code{\link{prior_vague}}) and \eqn{n_k} subjects with sample mean +\eqn{\bar y_k} and standard deviation \eqn{s_k}, it is +\eqn{t_{n_k - 1}(\bar y_k, s_k^2 / n_k)}. + +External data enter through a power prior with weight \eqn{a_0}: data with +\eqn{n_e} subjects, mean \eqn{\bar y_e} and standard deviation \eqn{s_e} +are combined with the prior as if they were \eqn{a_0 n_e} subjects with the +same mean and the sum of squares \eqn{a_0 (n_e - 1) s_e^2}. The posterior +distribution then has a closed form (Huang et al., submitted). With the +vague prior and external data, the posterior distribution of the mean has +\eqn{a_0 n_e + n_k - 1} degrees of freedom. + +The control group takes one of four forms. +\describe{ +\item{Concurrent control}{\code{n_c} is at least 2. External control +data can be added through \code{external_c}.} +\item{External control only}{\code{n_c = 0} and \code{external_c} is +given. The distribution of \eqn{\mu_c} is the posterior distribution +given the external control data. With the vague prior, \eqn{a_0 n_e} +must be greater than 1.} +\item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +given by \code{hypothetical(mean = mu0c, r = r)}. Following Kang et al. +(2026, Section 4.2.4), the control mean has the same t distribution as +the posterior distribution of the treatment mean, with location +\eqn{\mu_{0c}} and squared scale multiplied by \eqn{r}: +\eqn{\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 / \kappa_{nt})}. +\code{prior_c} is not used and must be \code{NULL}.} +\item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +control mean is a known value \eqn{\mu_c}, as in a single-arm study +compared with a benchmark. The probabilities of the Go and NoGo regions +are computed exactly from the t distribution of the treatment mean +(posterior) or of the mean of \eqn{m_t} future subjects (posterior +predictive), shifted by \eqn{\mu_c}; \code{method}, \code{nMC} and +\code{m_c} are not used. \code{prior_c} is not used and must be +\code{NULL}.} +} + +For the posterior predictive criterion (\code{\link{criterion_predictive}}), +the future effect is the difference between the sample means of \eqn{m_t} +and \eqn{m_c} future subjects. The posterior predictive distribution of the +mean of \eqn{m} future subjects of a group is +\eqn{t_{\nu_{n}}(\mu_{n}, \sigma_{n}^2 (1 / \kappa_{n} + 1 / m))}; for a +hypothetical control it is +\eqn{t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 (1 / \kappa_{nt} + 1 / m_c))}. + +The probabilities of the Go and NoGo regions are probabilities of the +difference of two t variables, computed by \code{\link{ptdiff}} with the +chosen \code{method}. With \code{method = "MC"}, the probabilities of the +two regions are estimated from the same \code{nMC} draws. +} +\examples{ +# Concurrent control with external treatment and control data +design_continuous( + n_t = 12, n_c = 12, + prior_t = prior_vague(), prior_c = prior_vague(), + criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, + gamma_go = 0.6, gamma_nogo = 0.7), + external_t = borrow(data_continuous(n = 6, mean = 20, sd = 30), a0 = 0.5), + external_c = borrow(data_continuous(n = 30, mean = -12, sd = 20), + a0 = 0.4) +) + +# Uncontrolled study with a hypothetical control +design_continuous( + n_t = 12, n_c = 0, prior_t = prior_vague(), + criterion = criterion_predictive(theta_null = 0, m_t = 50, + gamma_go = 0.9, gamma_nogo = 0.7), + hypothetical_c = hypothetical(mean = -10, r = 1), + method = "MM" +) + +# Single-arm study compared with a fixed control mean of -10 +design_continuous( + n_t = 12, n_c = 0, prior_t = prior_vague(), + criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, + gamma_go = 0.6, gamma_nogo = 0.7), + fixed_c = -10 +) +} +\references{ +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. \emph{Journal of Biopharmaceutical Statistics}. +\doi{10.1080/10543406.2026.2655410} + +Huang, Y., Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Conjugate representation of power priors for efficient Bayesian analysis +of normal data. +} +\seealso{ +Other designs: +\code{\link[=design_binary]{design_binary()}}, +\code{\link[=design_binary2]{design_binary2()}}, +\code{\link[=design_continuous2]{design_continuous2()}}, +\code{\link[=design_tte]{design_tte()}} +} +\concept{designs} diff --git a/man/design_continuous2.Rd b/man/design_continuous2.Rd new file mode 100644 index 0000000..2a24c4c --- /dev/null +++ b/man/design_continuous2.Rd @@ -0,0 +1,163 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design_continuous2.R +\name{design_continuous2} +\alias{design_continuous2} +\title{Design with two continuous endpoints} +\usage{ +design_continuous2( + n_t, + n_c, + prior_t, + prior_c = NULL, + criterion, + external_t = NULL, + external_c = NULL, + hypothetical_c = NULL, + fixed_c = NULL, + method = c("MM", "MC"), + nMC = 10000L +) +} +\arguments{ +\item{n_t}{Number of subjects in the treatment group (a whole number of at +least 3).} + +\item{n_c}{Number of subjects in the concurrent control group: 0 or a +whole number of at least 3.} + +\item{prior_t, prior_c}{Prior distributions of the treatment and control +groups, created by \code{\link{prior_niw}} or \code{\link{prior_vague}}. +For a hypothetical or fixed control, \code{prior_c} must be \code{NULL} +(the default).} + +\item{criterion}{Decision criterion for two endpoints, created by +\code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}.} + +\item{external_t, external_c}{External data of the treatment and control +groups, created by \code{\link{borrow}} with +\code{\link{data_continuous2}}, or \code{NULL} (no external data).} + +\item{hypothetical_c}{Hypothetical control, created by +\code{\link{hypothetical}} with \code{mean} of length 2 and \code{r}, +or \code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{fixed_c}{Fixed control means of endpoints 1 and 2, a numeric vector +of length 2, or \code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{method}{Method used to compute the probabilities: \code{"MM"} +(default) or \code{"MC"}.} + +\item{nMC}{Number of Monte Carlo draws for \code{method = "MC"}.} +} +\value{ +An object of class \code{c("qdm_design_continuous2", + "qdm_design")}, a list with the arguments and the element +\code{control} (\code{"concurrent"}, \code{"external"}, +\code{"hypothetical"} or \code{"fixed"}). +} +\description{ +Specifies a proof-of-concept study with two continuous endpoints: the +sample sizes, the prior distributions, the external data, the form of the +control group, the decision criterion for two endpoints and the method +used to compute the probabilities. The design is used by +\code{\link{qdm_decide}}, \code{\link{qdm_oc}} and +\code{\link{qdm_calibrate}}. +} +\details{ +The responses of a subject on the two endpoints have a bivariate normal +distribution with mean vector \eqn{\mu_k} and covariance matrix +\eqn{\Sigma_k} in group \eqn{k} (Yamaguchi et al., submitted, Appendix +A.2). The prior distribution of \eqn{(\mu_k, \Sigma_k)} is +Normal-Inverse-Wishart (\code{\link{prior_niw}}) or vague +(\code{\link{prior_vague}}, the density \eqn{|\Sigma_k|^{-3/2}}). External +data enter through a power prior with weight \eqn{a_0}, which has the +conjugate form, and the posterior parameters are updated with the external +data and then with the current data. The vague prior corresponds to +\eqn{\kappa_0 = 0}, \eqn{\nu_0 = -1} and \eqn{\Lambda_0 = 0}, so the +posterior distribution of the mean is +\eqn{t_{n - 2}(\bar y, S / (n (n - 2)))} without external data, where +\eqn{S} is the matrix of sums of squares and cross-products, \eqn{n - 1} +times the sample covariance matrix (Yamaguchi et al., submitted, +equation A.9). + +The treatment effects are the differences of the means, +\eqn{\theta_k = \mu_{tk} - \mu_{ck}}. The mean of each group has a +bivariate t distribution with \eqn{\nu_n - 1} degrees of freedom, +location \eqn{\mu_n} and scale matrix +\eqn{\Lambda_n / (\kappa_n (\nu_n - 1))}. For a predictive criterion, +the mean of \eqn{m} future subjects has the same distribution with the +scale matrix \eqn{(1 / \kappa_n + 1 / m) \Lambda_n / (\nu_n - 1)}, +because the future subjects share the same mean and covariance matrix +(version 0.1.0 and Yamaguchi et al. used the scale matrix +\eqn{(1 + \kappa_n) \Lambda_n / (\kappa_n (\nu_n - 1) m)}, which treats +them as independent draws from the predictive distribution of one +subject). A hypothetical control (\code{hypothetical(mean = c(m1, m2), +r = r)}) gives the control mean the distribution of the treatment mean +with location \code{mean} and the scale matrix multiplied by \code{r} +(Yamaguchi et al., Section A.2.6, with the hyperparameters of the +treatment group). With external control data only (\code{n_c = 0} and +\code{external_c}) and the vague prior, \eqn{a_0 n_e} must be greater +than 2. A fixed control (\code{n_c = 0} and \code{fixed_c}, the known +control means of the two endpoints) shifts the distribution of the +treatment mean, so the effect has a bivariate t distribution and the +probabilities of the regions are computed exactly from its distribution +function; \code{method}, \code{nMC} and \code{m_c} are then not used, +and \code{prior_c} must be \code{NULL}. + +The probabilities of the regions are computed by one of two methods: +\describe{ +\item{\code{"MM"}}{moment-matching approximation: the effect is +approximated by a bivariate t distribution with the same mean, +covariance matrix and radial fourth moment (Yamaguchi, Homma, Takeda +and Maruo, submitted, Theorem 3), whose rectangle +probabilities are computed by numerical integration for real degrees +of freedom. It requires more than 4 degrees of freedom for both +groups and is the fastest method.} +\item{\code{"MC"}}{Monte Carlo simulation with \code{nMC} draws from +each distribution; the probabilities of all regions are estimated +from the same draws. The computing time is proportional to +\code{nMC}, so \code{"MM"} is much faster for operating +characteristics, which need the probabilities for many simulated +studies.} +} + +The operating characteristics are computed by simulating the sample means +and the sums of squares and cross-products of \code{nsim} studies (see +\code{\link{qdm_oc}}). +} +\examples{ +# Case study 2 of Yamaguchi et al. (submitted) +L0 <- matrix(c(80^2, 15, 15, 6^2), 2, 2) +des <- design_continuous2( + n_t = 30, n_c = 30, + prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), + prior_c = prior_niw(mu0 = c(-10, -1), kappa0 = 0.1, nu0 = 4, + Lambda0 = L0), + criterion = criterion_posterior(theta_tv = c(10, 2), + theta_mav = c(5, 1), + gamma_go = 0.296, gamma_nogo = 0.244) +) +des +qdm_decide(des, + data_t = data_continuous2(30, c(5, 2), + matrix(c(6400, 190, 190, 36), 2, 2)), + data_c = data_continuous2(30, c(-10, -1), + matrix(c(5600, 150, 150, 42), 2, 2))) +} +\references{ +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. + +Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Moment-matching approximation for t-differences in clinical trials with +continuous endpoints. +} +\seealso{ +Other designs: +\code{\link[=design_binary]{design_binary()}}, +\code{\link[=design_binary2]{design_binary2()}}, +\code{\link[=design_continuous]{design_continuous()}}, +\code{\link[=design_tte]{design_tte()}} +} +\concept{designs} diff --git a/man/design_tte.Rd b/man/design_tte.Rd new file mode 100644 index 0000000..ed4b1cc --- /dev/null +++ b/man/design_tte.Rd @@ -0,0 +1,174 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/design_tte.R +\name{design_tte} +\alias{design_tte} +\title{Design with one time-to-event endpoint} +\usage{ +design_tte( + n_t, + n_c, + prior_t, + prior_c = NULL, + criterion, + milestone, + conduct = NULL, + external_t = NULL, + external_c = NULL, + hypothetical_c = NULL, + fixed_c = NULL, + conduct_future = conduct, + nMC = 10000L +) +} +\arguments{ +\item{n_t}{Number of subjects in the treatment group (a whole number of at +least 1).} + +\item{n_c}{Number of subjects in the concurrent control group (a whole +number of at least 0).} + +\item{prior_t, prior_c}{Gamma prior distributions of the hazards of the +treatment and control groups, created by \code{\link{prior_gamma}}. +\code{prior_c} must be \code{NULL} (the default) for a fixed control and +is required otherwise.} + +\item{criterion}{Decision criterion for one endpoint, created by +\code{\link{criterion_posterior}} or \code{\link{criterion_predictive}}, +with thresholds on the scale of the milestone survival difference (or +of the milestone survival itself with \code{fixed_c = 0}).} + +\item{milestone}{Milestone time \eqn{t_0} (positive), in the same unit as +the total observed time of the data.} + +\item{conduct}{Conduct of the study, created by \code{\link{conduct_tte}}, +used to simulate studies for the operating characteristics; \code{NULL} +(the default) if they are not needed. With an analysis at an event +(\code{cut_events}), the number of events must not exceed the number of +subjects (\code{n_t} plus \code{n_c}).} + +\item{external_t, external_c}{External data of the treatment and control +groups, created by \code{\link{borrow}} with \code{\link{data_tte}}, or +\code{NULL} (no external data).} + +\item{hypothetical_c}{Hypothetical control, created by +\code{\link{hypothetical}} with \code{\link{data_tte}}, or \code{NULL}. +It can be used only when \code{n_c = 0}.} + +\item{fixed_c}{Fixed control milestone survival probability, a number from +0 to 1, or \code{NULL}. It can be used only when \code{n_c = 0}.} + +\item{conduct_future}{Conduct of the future study for a predictive +criterion, created by \code{\link{conduct_tte}}; by default the same as +\code{conduct}. Required for a predictive criterion. With an analysis +at an event, the number of events must not exceed the number of future +subjects.} + +\item{nMC}{Number of simulated future studies for posterior predictive +probabilities.} +} +\value{ +An object of class \code{c("qdm_design_tte", "qdm_design")}, a +list with the arguments and the element \code{control} +(\code{"concurrent"}, \code{"external"}, \code{"hypothetical"} or +\code{"fixed"}). +} +\description{ +Specifies a proof-of-concept study with one time-to-event endpoint +evaluated by the milestone survival probability: the sample sizes, the +prior distributions, the external data, the form of the control group, +the decision criterion, the milestone time and the conduct of the study. +The design is used by \code{\link{qdm_decide}}, \code{\link{qdm_oc}}, +\code{\link{qdm_calibrate}} and \code{\link{qdm_boundary}}. +} +\details{ +The event times of group \eqn{k} (\eqn{k = t, c}) are exponential with +hazard \eqn{\lambda_k}, which has a Gamma prior distribution +(\code{\link{prior_gamma}}). The data of a group are summarized by the +number of events \eqn{d} and the total observed time \eqn{E} +(\code{\link{data_tte}}), and the posterior distribution of the hazard is +Gamma with shape \eqn{a + d} and rate \eqn{b + E}. External data enter +through a power prior with weight \eqn{a_0}, which adds \eqn{a_0 d_e} to the +shape and \eqn{a_0 E_e} to the rate. The treatment effect is the +difference of the milestone survival probabilities at time +\eqn{t_0 = } \code{milestone}, +\eqn{\theta = S_t(t_0) - S_c(t_0)} with \eqn{S_k(t_0) = \exp(-\lambda_k t_0)}. + +The control group takes one of four forms. +\describe{ +\item{Concurrent control}{\code{n_c} is at least 1. External control +data can be added through \code{external_c}.} +\item{External control only}{\code{n_c = 0} and \code{external_c} is +given. The distribution of \eqn{\lambda_c} is the posterior +distribution given the external control data.} +\item{Hypothetical control}{\code{n_c = 0} and \code{hypothetical_c} is +given by \code{hypothetical(data_tte(events, exposure))}, whose events +and total observed time are added to \code{prior_c}.} +\item{Fixed control}{\code{n_c = 0} and \code{fixed_c} is given: the +control milestone survival probability is a known value, as in a +single-arm study compared with a benchmark (\code{fixed_c = 0} makes +the effect the treatment milestone survival itself). \code{prior_c} +is not used and must be \code{NULL}.} +} + +Posterior probabilities of the Go and NoGo regions are computed exactly +for a fixed control (from the Gamma distribution of \eqn{\lambda_t}) and by +numerical integration otherwise (see \code{\link{psurvdiff}}). + +For the posterior predictive criterion (\code{\link{criterion_predictive}}), +a future study with \code{m_t} treatment and \code{m_c} control subjects +(no control group for a fixed control) is conducted as specified by +\code{conduct_future}. The milestone survival of each group in the future +study is estimated by \eqn{\exp(-t_0 (a + d) / (b + E))}, the value at the +posterior mean of the hazard given the future data alone with the prior +\eqn{(a, b)} of the group (\code{prior_t} or \code{prior_c}); with a weak +prior this is close to the maximum likelihood estimate and remains +defined when the future study has no events. The future effect is the +difference of the two estimates (or the treatment estimate minus the +fixed value). The predictive probabilities are estimated by simulating +\code{nMC} future studies, each with hazards drawn from the posterior +distributions given the proof-of-concept data (see +\code{\link{conduct_tte}} for the simulation of a study). They are +therefore Monte Carlo estimates, and their computing time is proportional +to \code{nMC} times the number of future subjects. + +The operating characteristics (\code{\link{qdm_oc}}, +\code{\link{qdm_calibrate}}) are computed by simulating \code{nsim} +studies conducted as specified by \code{conduct}, with exponential event +times whose hazards are given by the median survival times of the +scenarios. With a predictive criterion, every simulated study requires +\code{nMC} simulated future studies, so small values of \code{nsim} and +\code{nMC} are advisable for exploration. +} +\examples{ +# Single-arm study compared with a fixed control 3-month survival of 0.72 +des <- design_tte( + n_t = 30, n_c = 0, prior_t = prior_gamma(0.1, 1), + criterion = criterion_posterior(theta_tv = 0.15, theta_mav = 0, + gamma_go = 0.6, gamma_nogo = 0.8), + milestone = 3, + conduct = conduct_tte(accrual_time = c(0, 5, 10, 15), + accrual_rate = c(0.4, 2, 4.5), + dropout_hazard = 0.00226, cut_time = 15.44), + fixed_c = 0.72 +) +des +qdm_decide(des, data_t = data_tte(events = 6, exposure = 150)) + +# Concurrent control +design_tte( + n_t = 30, n_c = 30, prior_t = prior_gamma(0.1, 1), + prior_c = prior_gamma(0.1, 1), + criterion = criterion_posterior(theta_tv = 0.15, theta_mav = 0, + gamma_go = 0.6, gamma_nogo = 0.8), + milestone = 3, + conduct = conduct_tte(accrual_time = c(0, 12), cut_events = 25) +) +} +\seealso{ +Other designs: +\code{\link[=design_binary]{design_binary()}}, +\code{\link[=design_binary2]{design_binary2()}}, +\code{\link[=design_continuous]{design_continuous()}}, +\code{\link[=design_continuous2]{design_continuous2()}} +} +\concept{designs} diff --git a/man/format.qdm_borrow.Rd b/man/format.qdm_borrow.Rd new file mode 100644 index 0000000..9ae96c6 --- /dev/null +++ b/man/format.qdm_borrow.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_borrow.R +\name{format.qdm_borrow} +\alias{format.qdm_borrow} +\title{Format an external data specification} +\usage{ +\method{format}{qdm_borrow}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_borrow"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character string describing the external data and the power prior +weight. +} +\description{ +Format an external data specification +} +\examples{ +format(borrow(data_binary(n = 20, y = 8), a0 = 0.5)) +} diff --git a/man/format.qdm_calibration.Rd b/man/format.qdm_calibration.Rd new file mode 100644 index 0000000..84b7f06 --- /dev/null +++ b/man/format.qdm_calibration.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_calibration.R +\name{format.qdm_calibration} +\alias{format.qdm_calibration} +\title{Format a calibration} +\usage{ +\method{format}{qdm_calibration}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_calibration"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character vector with one element per line of the description +(without the table of decision probabilities). +} +\description{ +Format a calibration +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +format(qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), + data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.05, target_nogo = 0.2)) +} diff --git a/man/format.qdm_conduct.Rd b/man/format.qdm_conduct.Rd new file mode 100644 index 0000000..191b7e9 --- /dev/null +++ b/man/format.qdm_conduct.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_conduct.R +\name{format.qdm_conduct} +\alias{format.qdm_conduct} +\title{Format the conduct of a study} +\usage{ +\method{format}{qdm_conduct}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_conduct"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character vector with one element per line of the description. +} +\description{ +Format the conduct of a study +} +\examples{ +format(conduct_tte(accrual_time = c(0, 12), cut_events = 20)) +} diff --git a/man/format.qdm_criterion.Rd b/man/format.qdm_criterion.Rd new file mode 100644 index 0000000..9a1739f --- /dev/null +++ b/man/format.qdm_criterion.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_criterion.R +\name{format.qdm_criterion} +\alias{format.qdm_criterion} +\title{Format a decision criterion} +\usage{ +\method{format}{qdm_criterion}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_criterion"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character vector with one element per line of the description. +} +\description{ +Format a decision criterion +} +\examples{ +format(criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8)) +} diff --git a/man/format.qdm_data.Rd b/man/format.qdm_data.Rd new file mode 100644 index 0000000..fbdd9d7 --- /dev/null +++ b/man/format.qdm_data.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_data.R +\name{format.qdm_data} +\alias{format.qdm_data} +\title{Format a data specification} +\usage{ +\method{format}{qdm_data}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_data"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character string describing the data. +} +\description{ +Format a data specification +} +\examples{ +format(data_binary(n = 12, y = 7)) +} diff --git a/man/format.qdm_decision.Rd b/man/format.qdm_decision.Rd new file mode 100644 index 0000000..f179ad4 --- /dev/null +++ b/man/format.qdm_decision.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_decision.R +\name{format.qdm_decision} +\alias{format.qdm_decision} +\title{Format a decision} +\usage{ +\method{format}{qdm_decision}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_decision"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character vector with one element per line of the description. +} +\description{ +Format a decision +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +format(qdm_decide(des, data_binary(12, 9), data_binary(12, 4))) +} diff --git a/man/format.qdm_design.Rd b/man/format.qdm_design.Rd new file mode 100644 index 0000000..d8bf223 --- /dev/null +++ b/man/format.qdm_design.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_design.R +\name{format.qdm_design} +\alias{format.qdm_design} +\title{Format a design} +\usage{ +\method{format}{qdm_design}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_design"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character vector with one element per line of the description. +} +\description{ +Format a design +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +format(des) +} diff --git a/man/format.qdm_hypothetical.Rd b/man/format.qdm_hypothetical.Rd new file mode 100644 index 0000000..87bfc8f --- /dev/null +++ b/man/format.qdm_hypothetical.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_hypothetical.R +\name{format.qdm_hypothetical} +\alias{format.qdm_hypothetical} +\title{Format a hypothetical control specification} +\usage{ +\method{format}{qdm_hypothetical}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_hypothetical"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character string describing the hypothetical control. +} +\description{ +Format a hypothetical control specification +} +\examples{ +format(hypothetical(mean = 1, r = 1)) +} diff --git a/man/format.qdm_prior.Rd b/man/format.qdm_prior.Rd new file mode 100644 index 0000000..dbd6f7b --- /dev/null +++ b/man/format.qdm_prior.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/format.qdm_prior.R +\name{format.qdm_prior} +\alias{format.qdm_prior} +\title{Format a prior specification} +\usage{ +\method{format}{qdm_prior}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_prior"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +A character string describing the prior distribution. +} +\description{ +Format a prior specification +} +\examples{ +format(prior_beta(0.5, 0.5)) +} diff --git a/man/getgamma1bin.Rd b/man/getgamma1bin.Rd deleted file mode 100644 index d98d8c8..0000000 --- a/man/getgamma1bin.Rd +++ /dev/null @@ -1,304 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/getgamma1bin.R -\name{getgamma1bin} -\alias{getgamma1bin} -\title{Find Optimal Go/NoGo Thresholds for a Single Binary Endpoint} -\usage{ -getgamma1bin( - prob = "posterior", - design = "controlled", - theta_TV = NULL, - theta_MAV = NULL, - theta_NULL = NULL, - pi_t_go, - pi_c_go = NULL, - pi_t_nogo, - pi_c_nogo = NULL, - target_go, - target_nogo, - n_t, - n_c, - a_t, - a_c, - b_t, - b_c, - z = NULL, - m_t = NULL, - m_c = NULL, - ne_t = NULL, - ne_c = NULL, - ye_t = NULL, - ye_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01) -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{theta_TV}{A numeric scalar in \code{(-1, 1)} giving the Target Value -(TV) threshold for the treatment effect. Required when -\code{prob = 'posterior'}; set to \code{NULL} otherwise.} - -\item{theta_MAV}{A numeric scalar in \code{(-1, 1)} giving the Minimum -Acceptable Value (MAV) threshold. Must satisfy -\code{theta_TV > theta_MAV}. Required when -\code{prob = 'posterior'}; set to \code{NULL} otherwise.} - -\item{theta_NULL}{A numeric scalar in \code{(-1, 1)} giving the null -hypothesis threshold used for the predictive probability. Required -when \code{prob = 'predictive'}; set to \code{NULL} otherwise.} - -\item{pi_t_go}{A numeric scalar in \code{(0, 1)} giving the true treatment -response rate under the Go-calibration scenario (typically Null).} - -\item{pi_c_go}{A numeric scalar in \code{(0, 1)} giving the true control -response rate under the Go-calibration scenario. Set to \code{NULL} -for \code{design = 'uncontrolled'}.} - -\item{pi_t_nogo}{A numeric scalar in \code{(0, 1)} giving the true -treatment response rate under the NoGo-calibration scenario -(typically Alternative).} - -\item{pi_c_nogo}{A numeric scalar in \code{(0, 1)} giving the true control -response rate under the NoGo-calibration scenario. Set to -\code{NULL} for \code{design = 'uncontrolled'}.} - -\item{target_go}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the marginal Go probability under the Go-calibration scenario. -The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -satisfying \eqn{\Pr(\mathrm{Go}) < \code{target\_go}}.} - -\item{target_nogo}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the marginal NoGo probability under the NoGo-calibration scenario. -The optimal \eqn{\gamma_{\mathrm{nogo}}} is the largest grid value -satisfying \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the PoC trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial.} - -\item{a_t}{A positive numeric scalar giving the first shape parameter of -the Beta prior for the treatment group.} - -\item{a_c}{A positive numeric scalar giving the first shape parameter of -the Beta prior for the control group.} - -\item{b_t}{A positive numeric scalar giving the second shape parameter of -the Beta prior for the treatment group.} - -\item{b_c}{A positive numeric scalar giving the second shape parameter of -the Beta prior for the control group.} - -\item{z}{A non-negative integer giving the hypothetical number of -responders in the control group. Required when -\code{design = 'uncontrolled'}; set to \code{NULL} otherwise.} - -\item{m_t}{A positive integer giving the future sample size for the -treatment group. Required when \code{prob = 'predictive'}; set to -\code{NULL} otherwise.} - -\item{m_c}{A positive integer giving the future sample size for the -control group. Required when \code{prob = 'predictive'}; set to -\code{NULL} otherwise.} - -\item{ne_t}{A positive integer giving the number of patients in the -treatment group of the external data set. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{ne_c}{A positive integer giving the number of patients in the -control group of the external data set. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{ye_t}{A non-negative integer giving the number of responders in the -treatment group of the external data set. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{ye_c}{A non-negative integer giving the number of responders in the -control group of the external data set. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the treatment group. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the control group. Required when -\code{design = 'external'}; set to \code{NULL} otherwise.} - -\item{gamma_grid}{A numeric vector of candidate threshold values in -\code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} -} -\value{ -A list of class \code{getgamma1bin} with the following elements: -\describe{ -\item{gamma_go}{Optimal Go threshold: the smallest value in -\code{gamma_grid} for which \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} -under the Go-calibration scenario. -\code{NA} if no such value exists.} -\item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -\code{gamma_grid} for which \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} -under the NoGo-calibration scenario. -\code{NA} if no such value exists.} -\item{PrGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} -at the optimal \eqn{\gamma_{\mathrm{go}}} under the Go-calibration -scenario. \code{NA} if \code{gamma_go} is \code{NA}.} -\item{PrNoGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} -at the optimal \eqn{\gamma_{\mathrm{nogo}}} under the NoGo-calibration -scenario. \code{NA} if \code{gamma_nogo} is \code{NA}.} -\item{target_go}{The value of \code{target_go} supplied by the user.} -\item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -\item{grid_results}{A data frame with columns \code{gamma_grid}, -\code{PrGo_grid} (marginal Go probability under the Go-calibration -scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -the NoGo-calibration scenario).} -} -} -\description{ -Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -threshold \eqn{\gamma_{\mathrm{nogo}}} for a single binary endpoint by -searching over a grid of candidate values. The two thresholds are -calibrated independently under separate scenarios: -\itemize{ -\item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -\code{gamma_grid} such that the marginal Go probability -\eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} is strictly -less than \code{target_go} under the Go-calibration scenario -(\code{pi_t_go}, \code{pi_c_go}); typically the Null scenario. -\item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -\code{gamma_grid} such that the marginal NoGo probability -\eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} is strictly -less than \code{target_nogo} under the NoGo-calibration -scenario (\code{pi_t_nogo}, \code{pi_c_nogo}); typically the -Alternative scenario. -} -Here \eqn{g_{\mathrm{Go}} = P(\theta > \theta_{\mathrm{TV}} \mid y_t, y_c)} -and \eqn{g_{\mathrm{NoGo}} = P(\theta \le \theta_{\mathrm{MAV}} \mid y_t, y_c)} -for \code{prob = 'posterior'}, consistent with the decision rule in -\code{\link{pbayesdecisionprob1bin}}. -} -\details{ -The function uses a two-stage precompute-then-sweep strategy: -\enumerate{ -\item \strong{Precomputation}: All possible outcome pairs -\eqn{(y_t, y_c)} are enumerated. For each pair, -\code{\link{pbayespostpred1bin}} computes -\eqn{g_{\mathrm{Go}}} (\code{lower.tail = FALSE} at -\code{theta_TV}) and \eqn{g_{\mathrm{NoGo}}} (\code{lower.tail - = TRUE} at \code{theta_MAV}). This step is independent of -\eqn{\gamma}. -\item \strong{Gamma sweep}: Marginal probabilities are computed as -weighted sums of binary indicators over the grid: -\eqn{\Pr(\mathrm{Go})} uses \code{w_go} (weights under -\code{pi_t_go}, \code{pi_c_go}) and the indicator -\eqn{g_{\mathrm{Go}} \ge \gamma}; \eqn{\Pr(\mathrm{NoGo})} -uses \code{w_nogo} (weights under \code{pi_t_nogo}, -\code{pi_c_nogo}) and the indicator -\eqn{g_{\mathrm{NoGo}} \ge \gamma}. -} -Both \eqn{\Pr(\mathrm{Go})} and \eqn{\Pr(\mathrm{NoGo})} are -monotone non-increasing functions of \eqn{\gamma}. The optimal -\eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value -crossing below \code{target_go}. The optimal -\eqn{\gamma_{\mathrm{nogo}}} is also the \emph{smallest} grid value -crossing below \code{target_nogo}: a smaller \eqn{\gamma_{\mathrm{nogo}}} -makes NoGo harder to trigger (more permissive), so this is the least -restrictive threshold that still controls the false NoGo rate. -} -\examples{ -# Example 1: Controlled design, posterior probability -# gamma_go : smallest gamma s.t. Pr(Go) < 0.05 under Null (pi_t = pi_c = 0.15) -# gamma_nogo: largest gamma s.t. Pr(NoGo) < 0.20 under Alt (pi_t = 0.35, pi_c = 0.15) -getgamma1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.35, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 2: Uncontrolled design, posterior probability -getgamma1bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = NULL, - pi_t_nogo = 0.35, pi_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = 3L, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 3: External design, posterior probability -getgamma1bin( - prob = 'posterior', design = 'external', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.35, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = 15L, ne_c = 15L, ye_t = 6L, ye_c = 4L, - alpha0e_t = 0.5, alpha0e_c = 0.5 -) - -# Example 4: Controlled design, predictive probability -getgamma1bin( - prob = 'predictive', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.35, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = 30L, m_c = 30L, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 5: Uncontrolled design, predictive probability -getgamma1bin( - prob = 'predictive', design = 'uncontrolled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, - pi_t_go = 0.15, pi_c_go = NULL, - pi_t_nogo = 0.35, pi_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = 3L, m_t = 30L, m_c = 30L, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 6: External design, predictive probability -getgamma1bin( - prob = 'predictive', design = 'external', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.35, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = 30L, m_c = 30L, - ne_t = 15L, ne_c = 15L, ye_t = 6L, ye_c = 4L, - alpha0e_t = 0.5, alpha0e_c = 0.5 -) - -} diff --git a/man/getgamma1cont.Rd b/man/getgamma1cont.Rd deleted file mode 100644 index c7e550e..0000000 --- a/man/getgamma1cont.Rd +++ /dev/null @@ -1,395 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/getgamma1cont.R -\name{getgamma1cont} -\alias{getgamma1cont} -\title{Find Optimal Go/NoGo Thresholds for a Single Continuous Endpoint} -\usage{ -getgamma1cont( - nsim, - prob = "posterior", - design = "controlled", - prior = "vague", - CalcMethod = "NI", - theta_TV = NULL, - theta_MAV = NULL, - theta_NULL = NULL, - nMC = NULL, - mu_t_go, - mu_c_go = NULL, - sigma_t_go, - sigma_c_go = NULL, - mu_t_nogo, - mu_c_nogo = NULL, - sigma_t_nogo, - sigma_c_nogo = NULL, - target_go, - target_nogo, - n_t, - n_c = NULL, - m_t = NULL, - m_c = NULL, - kappa0_t = NULL, - kappa0_c = NULL, - nu0_t = NULL, - nu0_c = NULL, - mu0_t = NULL, - mu0_c = NULL, - sigma0_t = NULL, - sigma0_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), - seed -) -} -\arguments{ -\item{nsim}{A positive integer giving the number of Monte Carlo simulation -replicates used to approximate the operating characteristics.} - -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{prior}{A character string specifying the prior distribution. -Must be \code{'vague'} or \code{'N-Inv-Chisq'}.} - -\item{CalcMethod}{A character string specifying the computation method -for \code{\link{pbayespostpred1cont}}. -Must be \code{'NI'}, \code{'MC'}, or \code{'MM'}.} - -\item{theta_TV}{A numeric scalar giving the Target Value (TV) threshold -for the treatment effect. Required when \code{prob = 'posterior'}; -set to \code{NULL} otherwise.} - -\item{theta_MAV}{A numeric scalar giving the Minimum Acceptable Value (MAV) -threshold. Must satisfy \code{theta_TV > theta_MAV}. Required when -\code{prob = 'posterior'}; set to \code{NULL} otherwise.} - -\item{theta_NULL}{A numeric scalar giving the null hypothesis threshold -for the predictive probability. Required when -\code{prob = 'predictive'}; set to \code{NULL} otherwise.} - -\item{nMC}{A positive integer giving the number of inner Monte Carlo draws -passed to \code{\link{pbayespostpred1cont}}. Required when -\code{CalcMethod = 'MC'}; set to \code{NULL} otherwise.} - -\item{mu_t_go}{A numeric scalar giving the true mean for the treatment group -under the Go-calibration scenario (typically Null).} - -\item{mu_c_go}{A numeric scalar giving the true mean for the control group -under the Go-calibration scenario. Set to \code{NULL} for -\code{design = 'uncontrolled'}.} - -\item{sigma_t_go}{A positive numeric scalar giving the true standard -deviation for the treatment group under the Go-calibration scenario.} - -\item{sigma_c_go}{A positive numeric scalar giving the true standard -deviation for the control group under the Go-calibration scenario. -Set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{mu_t_nogo}{A numeric scalar giving the true mean for the treatment -group under the NoGo-calibration scenario (typically Alternative).} - -\item{mu_c_nogo}{A numeric scalar giving the true mean for the control -group under the NoGo-calibration scenario. Set to \code{NULL} for -\code{design = 'uncontrolled'}.} - -\item{sigma_t_nogo}{A positive numeric scalar giving the true standard -deviation for the treatment group under the NoGo-calibration scenario.} - -\item{sigma_c_nogo}{A positive numeric scalar giving the true standard -deviation for the control group under the NoGo-calibration scenario. -Set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{target_go}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the marginal Go probability under the Go-calibration scenario. -The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -satisfying \eqn{\Pr(\mathrm{Go}) < \code{target\_go}}.} - -\item{target_nogo}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the marginal NoGo probability under the NoGo-calibration scenario. -The optimal \eqn{\gamma_{\mathrm{nogo}}} is the smallest grid value -satisfying \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the PoC trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. Required for -\code{design = 'controlled'} or \code{'external'}; set to -\code{NULL} for \code{design = 'uncontrolled'}.} - -\item{m_t}{A positive integer giving the future sample size for the -treatment group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{m_c}{A positive integer giving the future sample size for the -control group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{kappa0_t}{A positive numeric scalar giving the prior precision -parameter for the treatment group under the N-Inv-Chi-squared prior. -Required when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise.} - -\item{kappa0_c}{A positive numeric scalar giving the prior precision -parameter for the control group. Required when -\code{prior = 'N-Inv-Chisq'} and \code{design != 'uncontrolled'}; -set to \code{NULL} otherwise.} - -\item{nu0_t}{A positive numeric scalar giving the prior degrees of freedom -for the treatment group under the N-Inv-Chi-squared prior. Required -when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise.} - -\item{nu0_c}{A positive numeric scalar giving the prior degrees of freedom -for the control group. Required when \code{prior = 'N-Inv-Chisq'} -and \code{design != 'uncontrolled'}; set to \code{NULL} otherwise.} - -\item{mu0_t}{A numeric scalar giving the prior mean for the treatment group -under the N-Inv-Chi-squared prior. Required when -\code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise.} - -\item{mu0_c}{A numeric scalar giving the prior mean for the control group -(or the fixed hypothetical control mean for uncontrolled design). -Required when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} -otherwise.} - -\item{sigma0_t}{A positive numeric scalar giving the prior scale parameter -for the treatment group under the N-Inv-Chi-squared prior. Required -when \code{prior = 'N-Inv-Chisq'}; set to \code{NULL} otherwise.} - -\item{sigma0_c}{A positive numeric scalar giving the prior scale parameter -for the control group. Required when \code{prior = 'N-Inv-Chisq'} -and \code{design != 'uncontrolled'}; set to \code{NULL} otherwise.} - -\item{r}{A positive numeric scalar giving the variance ratio -\eqn{\sigma_c^2 / \sigma_t^2} used for uncontrolled design. -Required when \code{design = 'uncontrolled'}; set to \code{NULL} -otherwise.} - -\item{ne_t}{A positive integer giving the number of patients in the -treatment group of the external data set. Required when -\code{design = 'external'} and external treatment data are -available; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the number of patients in the -control group of the external data set. Required when -\code{design = 'external'} and external control data are available; -otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external treatment group data. Required when -\code{design = 'external'} and \code{ne_t} is non-NULL; set to -\code{NULL} otherwise.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external control group data. Required when -\code{design = 'external'} and \code{ne_c} is non-NULL; set to -\code{NULL} otherwise.} - -\item{bar_ye_t}{A numeric scalar giving the sample mean of the external -treatment group data. Required when \code{ne_t} is non-NULL; set to -\code{NULL} otherwise.} - -\item{bar_ye_c}{A numeric scalar giving the sample mean of the external -control group data. Required when \code{ne_c} is non-NULL; set to -\code{NULL} otherwise.} - -\item{se_t}{A positive numeric scalar giving the sample standard deviation -of the external treatment group data. Required when \code{ne_t} is -non-NULL; set to \code{NULL} otherwise.} - -\item{se_c}{A positive numeric scalar giving the sample standard deviation -of the external control group data. Required when \code{ne_c} is -non-NULL; set to \code{NULL} otherwise.} - -\item{gamma_grid}{A numeric vector of candidate threshold values in -\code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} - -\item{seed}{A numeric scalar for reproducible random number generation. -The Go-calibration simulation uses \code{seed} and the -NoGo-calibration simulation uses \code{seed + 1} to ensure -independence between the two scenarios.} -} -\value{ -A list of class \code{getgamma1cont} with the following elements: -\describe{ -\item{gamma_go}{Optimal Go threshold: the smallest value in -\code{gamma_grid} for which \eqn{\Pr(\mathrm{Go}) < \code{target\_go}} -under the Go-calibration scenario. -\code{NA} if no such value exists.} -\item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -\code{gamma_grid} for which \eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} -under the NoGo-calibration scenario. -\code{NA} if no such value exists.} -\item{PrGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} -at the optimal \eqn{\gamma_{\mathrm{go}}} under the Go-calibration -scenario. \code{NA} if \code{gamma_go} is \code{NA}.} -\item{PrNoGo_opt}{Marginal \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} -at the optimal \eqn{\gamma_{\mathrm{nogo}}} under the NoGo-calibration -scenario. \code{NA} if \code{gamma_nogo} is \code{NA}.} -\item{target_go}{The value of \code{target_go} supplied by the user.} -\item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -\item{grid_results}{A data frame with columns \code{gamma_grid}, -\code{PrGo_grid} (marginal Go probability under the Go-calibration -scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -the NoGo-calibration scenario).} -} -} -\description{ -Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -threshold \eqn{\gamma_{\mathrm{nogo}}} for a single continuous endpoint by -searching over a grid of candidate values. The two thresholds are -calibrated independently under separate scenarios: -\itemize{ -\item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -\code{gamma_grid} such that the marginal Go probability -\eqn{\Pr(g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}})} is strictly -less than \code{target_go} under the Go-calibration scenario -(\code{mu_t_go}, \code{mu_c_go}, \code{sigma_t_go}, -\code{sigma_c_go}); typically the Null scenario. -\item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -\code{gamma_grid} such that the marginal NoGo probability -\eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}})} is -strictly less than \code{target_nogo} under the NoGo-calibration -scenario (\code{mu_t_nogo}, \code{mu_c_nogo}, \code{sigma_t_nogo}, -\code{sigma_c_nogo}); typically the Alternative scenario. -} -Here \eqn{g_{\mathrm{Go}} = P(\theta > \theta_{\mathrm{TV}} \mid \bar{y}_t, s_t, \bar{y}_c, s_c)} -and \eqn{g_{\mathrm{NoGo}} = P(\theta \le \theta_{\mathrm{MAV}} \mid \bar{y}_t, s_t, \bar{y}_c, s_c)} -for \code{prob = 'posterior'}, consistent with the decision rule in -\code{\link{pbayesdecisionprob1cont}}. -} -\details{ -The function uses a two-stage simulate-then-sweep strategy: -\enumerate{ -\item \strong{Simulation}: \code{nsim} datasets are generated -independently for each calibration scenario. For the -Go-calibration scenario, standardised residuals are shifted by -\code{mu_t_go} and \code{mu_c_go}; for the NoGo-calibration -scenario, by \code{mu_t_nogo} and \code{mu_c_nogo}. -\code{\link{pbayespostpred1cont}} is called once per scenario to -obtain \eqn{g_{\mathrm{Go}}} (\code{lower.tail = FALSE} at -\code{theta_TV}) and \eqn{g_{\mathrm{NoGo}}} (\code{lower.tail - = TRUE} at \code{theta_MAV}). -\item \strong{Gamma sweep}: Marginal probabilities are estimated as the -proportion of simulated datasets satisfying the respective -indicator: \eqn{g_{\mathrm{Go}} \ge \gamma} for -\code{PrGo_grid}, and \eqn{g_{\mathrm{NoGo}} \ge \gamma} for -\code{PrNoGo_grid}. Both are monotone non-increasing in -\eqn{\gamma}. -} -The optimal \eqn{\gamma_{\mathrm{go}}} and \eqn{\gamma_{\mathrm{nogo}}} -are each the \emph{smallest} grid value crossing below the respective -target probability. -} -\examples{ -# Example 1: Controlled design, vague prior, posterior probability -# gamma_go : smallest gamma s.t. Pr(Go) < 0.05 under Null (mu_t = mu_c = 1.0) -# gamma_nogo: smallest gamma s.t. Pr(NoGo) < 0.20 under Alt (mu_t = 2.5, mu_c = 1.0) -getgamma1cont( - nsim = 1000L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.5, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 2.0, sigma_c_go = 2.0, - mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 2.0, sigma_c_nogo = 2.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 1L -) - -# Example 2: Uncontrolled design, N-Inv-Chisq prior, posterior probability -getgamma1cont( - nsim = 1000L, prob = 'posterior', design = 'uncontrolled', - prior = 'N-Inv-Chisq', CalcMethod = 'NI', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.5, mu_c_go = NULL, sigma_t_go = 1.5, sigma_c_go = NULL, - mu_t_nogo = 3.0, mu_c_nogo = NULL, sigma_t_nogo = 1.5, sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 20L, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = 2, kappa0_c = NULL, nu0_t = 5, nu0_c = NULL, - mu0_t = 3.0, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = NULL, - r = 1.0, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 2L -) - -# Example 3: External design, vague prior, posterior probability -getgamma1cont( - nsim = 1000L, prob = 'posterior', design = 'external', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = 0.0, se_t = NULL, se_c = 1.5, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 4L -) - -# Example 4: Controlled design, vague prior, predictive probability -getgamma1cont( - nsim = 1000L, prob = 'predictive', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 2.0, sigma_c_go = 2.0, - mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 2.0, sigma_c_nogo = 2.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = 15L, m_t = 50L, m_c = 50L, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 3L -) - -# Example 5: Uncontrolled design, vague prior, predictive probability -getgamma1cont( - nsim = 1000L, prob = 'predictive', design = 'uncontrolled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, - mu_t_go = 1.0, mu_c_go = NULL, sigma_t_go = 2.0, sigma_c_go = NULL, - mu_t_nogo = 2.5, mu_c_nogo = NULL, sigma_t_nogo = 2.0, sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = NULL, m_t = 50L, m_c = 50L, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 0.0, sigma0_t = NULL, sigma0_c = NULL, - r = 1.0, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 5L -) - -# Example 6: External design, vague prior, predictive probability -getgamma1cont( - nsim = 1000L, prob = 'predictive', design = 'external', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 1.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 2.5, mu_c_nogo = 1.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = 15L, m_t = 50L, m_c = 50L, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = 0.0, se_t = NULL, se_c = 1.5, - gamma_grid = seq(0.01, 0.99, by = 0.01), seed = 6L -) - -} diff --git a/man/getgamma2bin.Rd b/man/getgamma2bin.Rd deleted file mode 100644 index ffe7a44..0000000 --- a/man/getgamma2bin.Rd +++ /dev/null @@ -1,496 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/getgamma2bin.R -\name{getgamma2bin} -\alias{getgamma2bin} -\title{Find Optimal Go/NoGo Thresholds for Two Binary Endpoints} -\usage{ -getgamma2bin( - prob = "posterior", - design = "controlled", - GoRegions, - NoGoRegions, - pi_t1_go, - pi_t2_go, - rho_t_go, - pi_c1_go = NULL, - pi_c2_go = NULL, - rho_c_go = NULL, - pi_t1_nogo, - pi_t2_nogo, - rho_t_nogo, - pi_c1_nogo = NULL, - pi_c2_nogo = NULL, - rho_c_nogo = NULL, - target_go, - target_nogo, - n_t, - n_c, - a_t_00, - a_t_01, - a_t_10, - a_t_11, - a_c_00, - a_c_01, - a_c_10, - a_c_11, - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - m_t = NULL, - m_c = NULL, - z00 = NULL, - z01 = NULL, - z10 = NULL, - z11 = NULL, - xe_t_00 = NULL, - xe_t_01 = NULL, - xe_t_10 = NULL, - xe_t_11 = NULL, - xe_c_00 = NULL, - xe_c_01 = NULL, - xe_c_10 = NULL, - xe_c_11 = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - nMC = 1000L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{GoRegions}{An integer vector of region indices (subset of -\code{1:9} for \code{prob = 'posterior'} or \code{1:4} for -\code{prob = 'predictive'}) that constitute the Go region.} - -\item{NoGoRegions}{An integer vector of region indices that constitute -the NoGo region. Must be disjoint from \code{GoRegions}.} - -\item{pi_t1_go}{A numeric scalar in \code{(0, 1)} giving the true -treatment response probability for Endpoint 1 under the -Go-calibration scenario (typically Null).} - -\item{pi_t2_go}{A numeric scalar in \code{(0, 1)} giving the true -treatment response probability for Endpoint 2 under the -Go-calibration scenario.} - -\item{rho_t_go}{A numeric scalar giving the within-group correlation in -the treatment group under the Go-calibration scenario.} - -\item{pi_c1_go}{A numeric scalar in \code{(0, 1)} giving the true -control response probability for Endpoint 1 under the -Go-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{pi_c2_go}{A numeric scalar in \code{(0, 1)} giving the true -control response probability for Endpoint 2 under the -Go-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{rho_c_go}{A numeric scalar giving the within-group correlation in -the control group under the Go-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{pi_t1_nogo}{A numeric scalar in \code{(0, 1)} giving the true -treatment response probability for Endpoint 1 under the -NoGo-calibration scenario (typically Alternative).} - -\item{pi_t2_nogo}{A numeric scalar in \code{(0, 1)} giving the true -treatment response probability for Endpoint 2 under the -NoGo-calibration scenario.} - -\item{rho_t_nogo}{A numeric scalar giving the within-group correlation in -the treatment group under the NoGo-calibration scenario.} - -\item{pi_c1_nogo}{A numeric scalar in \code{(0, 1)} giving the true -control response probability for Endpoint 1 under the -NoGo-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{pi_c2_nogo}{A numeric scalar in \code{(0, 1)} giving the true -control response probability for Endpoint 2 under the -NoGo-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{rho_c_nogo}{A numeric scalar giving the within-group correlation in -the control group under the NoGo-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{target_go}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the worst-case marginal Go probability under the Go-calibration -scenario. The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest -grid value satisfying the constraint.} - -\item{target_nogo}{A numeric scalar in \code{(0, 1)} giving the upper -bound on the worst-case marginal NoGo probability under the -NoGo-calibration scenario. The optimal \eqn{\gamma_{\mathrm{nogo}}} -is the smallest grid value satisfying the constraint.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the PoC trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial.} - -\item{a_t_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the (0,0) response pattern in the treatment group.} - -\item{a_t_01}{A positive numeric scalar; see \code{a_t_00}.} - -\item{a_t_10}{A positive numeric scalar; see \code{a_t_00}.} - -\item{a_t_11}{A positive numeric scalar; see \code{a_t_00}.} - -\item{a_c_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the (0,0) response pattern in the control group.} - -\item{a_c_01}{A positive numeric scalar; see \code{a_c_00}.} - -\item{a_c_10}{A positive numeric scalar; see \code{a_c_00}.} - -\item{a_c_11}{A positive numeric scalar; see \code{a_c_00}.} - -\item{theta_TV1}{A numeric scalar giving the TV threshold for -Endpoint 1. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_MAV1}{A numeric scalar giving the MAV threshold for -Endpoint 1. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_TV2}{A numeric scalar giving the TV threshold for -Endpoint 2. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_MAV2}{A numeric scalar giving the MAV threshold for -Endpoint 2. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; -otherwise set to \code{NULL}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; -otherwise set to \code{NULL}.} - -\item{m_t}{A positive integer giving the future sample size for the -treatment group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{m_c}{A positive integer giving the future sample size for the -control group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{z00}{A non-negative integer giving the hypothetical control count -for pattern (0,0). Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z01}{A non-negative integer; see \code{z00}.} - -\item{z10}{A non-negative integer; see \code{z00}.} - -\item{z11}{A non-negative integer; see \code{z00}.} - -\item{xe_t_00}{A non-negative integer giving the external treatment group -count for pattern (0,0). Required when -\code{design = 'external'} and external treatment data are used; -otherwise \code{NULL}.} - -\item{xe_t_01}{A non-negative integer; see \code{xe_t_00}.} - -\item{xe_t_10}{A non-negative integer; see \code{xe_t_00}.} - -\item{xe_t_11}{A non-negative integer; see \code{xe_t_00}.} - -\item{xe_c_00}{A non-negative integer giving the external control group -count for pattern (0,0). Required when -\code{design = 'external'} and external control data are used; -otherwise \code{NULL}.} - -\item{xe_c_01}{A non-negative integer; see \code{xe_c_00}.} - -\item{xe_c_10}{A non-negative integer; see \code{xe_c_00}.} - -\item{xe_c_11}{A non-negative integer; see \code{xe_c_00}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external treatment group data. Required when external -treatment data are used; otherwise \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external control group data. Required when external -control data are used; otherwise \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Dirichlet draws used -to evaluate region probabilities for each count combination in -Stage 1. Default is \code{1000L}.} - -\item{gamma_go_grid}{A numeric vector of candidate Go threshold values -in \code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} - -\item{gamma_nogo_grid}{A numeric vector of candidate NoGo threshold -values in \code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} -} -\value{ -A list of class \code{getgamma2bin} with the following elements: -\describe{ -\item{gamma_go}{Optimal Go threshold: the smallest value in -\code{gamma_go_grid} for which the marginal -\eqn{\Pr(\mathrm{Go}) < \code{target\_go}} under the -Go-calibration scenario. \code{NA} if no such value exists.} -\item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -\code{gamma_nogo_grid} for which the marginal -\eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} under the -NoGo-calibration scenario. \code{NA} if no such value exists.} -\item{PrGo_opt}{Marginal \eqn{\Pr(\mathrm{Go})} at -\code{gamma_go} under the Go-calibration scenario. -\code{NA} if \code{gamma_go} is \code{NA}.} -\item{PrNoGo_opt}{Marginal \eqn{\Pr(\mathrm{NoGo})} at -\code{gamma_nogo} under the NoGo-calibration scenario. -\code{NA} if \code{gamma_nogo} is \code{NA}.} -\item{target_go}{The value of \code{target_go} supplied by the user.} -\item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -\item{grid_results}{A data frame with columns \code{gamma_grid}, -\code{PrGo_grid} (marginal Go probability under the Go-calibration -scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -the NoGo-calibration scenario).} -} -} -\description{ -Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -threshold \eqn{\gamma_{\mathrm{nogo}}} for two binary endpoints by -searching over a two-dimensional grid of candidate value pairs. The two -thresholds are calibrated independently under separate scenarios: -\itemize{ -\item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -\code{gamma_go_grid} such that the worst-case marginal Go -probability over all \eqn{\gamma_{\mathrm{nogo}}} in -\code{gamma_nogo_grid} is strictly less than \code{target_go} -under the Go-calibration scenario (\code{pi_t1_go}, -\code{pi_t2_go}, \code{rho_t_go}, \code{pi_c1_go}, -\code{pi_c2_go}, \code{rho_c_go}); typically the Null scenario. -\item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -\code{gamma_nogo_grid} such that the worst-case marginal NoGo -probability over all \eqn{\gamma_{\mathrm{go}}} in -\code{gamma_go_grid} is strictly less than \code{target_nogo} -under the NoGo-calibration scenario (\code{pi_t1_nogo}, -\code{pi_t2_nogo}, \code{rho_t_nogo}, \code{pi_c1_nogo}, -\code{pi_c2_nogo}, \code{rho_c_nogo}); typically the Alternative -scenario. -} -} -\details{ -The function uses the same two-stage precompute-then-sweep strategy as -\code{\link{pbayesdecisionprob2bin}}. - -\strong{Stage 1 (precomputation)}: \code{\link{pbayespostpred2bin}} is -called for every possible multinomial outcome combination \eqn{(x_t, x_c)} -enumerated by \code{\link{allmultinom}}. The resulting region probability -vector is summed over \code{GoRegions} and \code{NoGoRegions} to obtain -\eqn{\hat{g}_{Go,ij}} and \eqn{\hat{g}_{NoGo,ij}}. These are independent -of the calibration scenario; only the multinomial weights differ. - -\strong{Stage 2 (gamma sweep)}: For each pair -\eqn{(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})} in the -two-dimensional grid, operating characteristics are computed separately -under each calibration scenario using the respective multinomial weights: -\deqn{\Pr(\mathrm{Go}) = \sum_{i,j} w_{ij}^{(\mathrm{go})} - \mathbf{1}\!\left[\hat{g}_{Go,ij} \ge \gamma_{\mathrm{go}},\; - \hat{g}_{NoGo,ij} < \gamma_{\mathrm{nogo}}\right]} -\deqn{\Pr(\mathrm{NoGo}) = \sum_{i,j} w_{ij}^{(\mathrm{nogo})} - \mathbf{1}\!\left[\hat{g}_{NoGo,ij} \ge \gamma_{\mathrm{nogo}},\; - \hat{g}_{Go,ij} < \gamma_{\mathrm{go}}\right]} - -\strong{Stage 3 (optimal threshold selection)}: For each candidate -\eqn{\gamma_{\mathrm{go}}}, the worst-case \eqn{\Pr(\mathrm{Go})} over all -\eqn{\gamma_{\mathrm{nogo}}} in \code{gamma_nogo_grid} is computed; the -optimal \eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value for -which this worst-case probability is less than \code{target_go}. -Analogously, the optimal \eqn{\gamma_{\mathrm{nogo}}} is the -\emph{smallest} grid value for which the worst-case \eqn{\Pr(\mathrm{NoGo})} -is less than \code{target_nogo}. -} -\examples{ -# Example 1: Controlled design, posterior probability -# gamma_go : smallest gamma_go s.t. max_{gamma_nogo} Pr(Go) < 0.05 under Null -# gamma_nogo: smallest gamma_nogo s.t. max_{gamma_go} Pr(NoGo) < 0.20 under Alt -\donttest{ -getgamma2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -# Example 2: Uncontrolled design, posterior probability -\donttest{ -getgamma2bin( - prob = 'posterior', design = 'uncontrolled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = 3L, z01 = 2L, z10 = 3L, z11 = 2L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -# Example 3: External design, posterior probability -\donttest{ -getgamma2bin( - prob = 'posterior', design = 'external', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = 3L, xe_c_01 = 2L, xe_c_10 = 3L, xe_c_11 = 2L, - alpha0e_t = NULL, alpha0e_c = 0.5, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -# Example 4: Controlled design, predictive probability -\donttest{ -getgamma2bin( - prob = 'predictive', design = 'controlled', - GoRegions = 1L, NoGoRegions = 4L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - m_t = 5L, m_c = 5L, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -# Example 5: Uncontrolled design, predictive probability -\donttest{ -getgamma2bin( - prob = 'predictive', design = 'uncontrolled', - GoRegions = 1L, NoGoRegions = 4L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - m_t = 5L, m_c = 5L, - z00 = 3L, z01 = 2L, z10 = 3L, z11 = 2L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -# Example 6: External design, predictive probability -\donttest{ -getgamma2bin( - prob = 'predictive', design = 'external', - GoRegions = 1L, NoGoRegions = 4L, - pi_t1_go = 0.15, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.20, rho_c_go = 0.0, - pi_t1_nogo = 0.35, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - m_t = 5L, m_c = 5L, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = 3L, xe_t_01 = 2L, xe_t_10 = 3L, xe_t_11 = 2L, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = 0.5, alpha0e_c = NULL, - nMC = 100L, - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01) -) -} - -} diff --git a/man/getgamma2cont.Rd b/man/getgamma2cont.Rd deleted file mode 100644 index 30cea40..0000000 --- a/man/getgamma2cont.Rd +++ /dev/null @@ -1,527 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/getgamma2cont.R -\name{getgamma2cont} -\alias{getgamma2cont} -\title{Find Optimal Go/NoGo Thresholds for Two Continuous Endpoints} -\usage{ -getgamma2cont( - nsim = 10000L, - prob = "posterior", - design = "controlled", - prior = "vague", - GoRegions, - NoGoRegions, - mu_t_go, - Sigma_t_go, - mu_c_go = NULL, - Sigma_c_go = NULL, - mu_t_nogo, - Sigma_t_nogo, - mu_c_nogo = NULL, - Sigma_c_nogo = NULL, - target_go, - target_nogo, - n_t, - n_c = NULL, - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - m_t = NULL, - m_c = NULL, - kappa0_t = NULL, - nu0_t = NULL, - mu0_t = NULL, - Lambda0_t = NULL, - kappa0_c = NULL, - nu0_c = NULL, - mu0_c = NULL, - Lambda0_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - nMC = NULL, - CalcMethod = "MC", - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed -) -} -\arguments{ -\item{nsim}{A positive integer giving the number of Monte Carlo -datasets to simulate per calibration scenario. Default is -\code{10000L}.} - -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{prior}{A character string specifying the prior distribution. -Must be \code{'vague'} or \code{'N-Inv-Wishart'}.} - -\item{GoRegions}{An integer vector of region indices (subset of -\code{1:9}) that constitute the Go region. The 9 regions are -defined by the cross-classification of the two treatment effects -\eqn{(\theta_1, \theta_2)} relative to \code{(TV1, MAV1)} and -\code{(TV2, MAV2)}: region \eqn{k = (z_1 - 1) \times 3 + z_2} -where \eqn{z_i = 1} if \eqn{\theta_i > TV_i}, \eqn{z_i = 2} if -\eqn{MAV_i < \theta_i \le TV_i}, \eqn{z_i = 3} if -\eqn{\theta_i \le MAV_i}.} - -\item{NoGoRegions}{An integer vector of region indices (subset of -\code{1:9}) that constitute the NoGo region. -Must be disjoint from \code{GoRegions}.} - -\item{mu_t_go}{A length-2 numeric vector giving the true bivariate mean -for the treatment group under the Go-calibration scenario -(typically Null).} - -\item{Sigma_t_go}{A 2x2 positive-definite numeric matrix giving the -true within-group covariance in the treatment group under the -Go-calibration scenario.} - -\item{mu_c_go}{A length-2 numeric vector giving the true bivariate mean -for the control group under the Go-calibration scenario. Required -for \code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{Sigma_c_go}{A 2x2 positive-definite numeric matrix giving the -true within-group covariance in the control group under the -Go-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{mu_t_nogo}{A length-2 numeric vector giving the true bivariate mean -for the treatment group under the NoGo-calibration scenario -(typically Alternative).} - -\item{Sigma_t_nogo}{A 2x2 positive-definite numeric matrix giving the -true within-group covariance in the treatment group under the -NoGo-calibration scenario.} - -\item{mu_c_nogo}{A length-2 numeric vector giving the true bivariate mean -for the control group under the NoGo-calibration scenario. Required -for \code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{Sigma_c_nogo}{A 2x2 positive-definite numeric matrix giving the -true within-group covariance in the control group under the -NoGo-calibration scenario. Required for -\code{design = 'controlled'} or \code{'external'}; -set to \code{NULL} for \code{design = 'uncontrolled'}.} - -\item{target_go}{A numeric scalar in \code{(0, 1)} giving the upper bound -on the marginal Go probability under the Go-calibration scenario. -The optimal \eqn{\gamma_{\mathrm{go}}} is the smallest grid value -satisfying the constraint.} - -\item{target_nogo}{A numeric scalar in \code{(0, 1)} giving the upper -bound on the marginal NoGo probability under the NoGo-calibration -scenario. The optimal \eqn{\gamma_{\mathrm{nogo}}} is the smallest -grid value satisfying the constraint.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the PoC trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. Set to \code{NULL} for -\code{design = 'uncontrolled'}.} - -\item{theta_TV1}{A numeric scalar giving the TV threshold for -Endpoint 1. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_MAV1}{A numeric scalar giving the MAV threshold for -Endpoint 1. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_TV2}{A numeric scalar giving the TV threshold for -Endpoint 2. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_MAV2}{A numeric scalar giving the MAV threshold for -Endpoint 2. Required when \code{prob = 'posterior'}; -otherwise set to \code{NULL}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; -otherwise set to \code{NULL}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; -otherwise set to \code{NULL}.} - -\item{m_t}{A positive integer giving the future sample size for the -treatment group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{m_c}{A positive integer giving the future sample size for the -control group. Required when \code{prob = 'predictive'}; -set to \code{NULL} otherwise.} - -\item{kappa0_t}{Positive numeric scalar. NIW prior hyperparameter -\eqn{\kappa_{01}} for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}.} - -\item{nu0_t}{Positive numeric scalar. NIW prior degrees of freedom -\eqn{\nu_{01}} for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}.} - -\item{mu0_t}{Length-2 numeric vector. NIW prior mean \eqn{\mu_{01}} -for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}.} - -\item{Lambda0_t}{A 2x2 positive-definite numeric matrix. NIW prior -scale matrix \eqn{\Lambda_{01}} for the treatment group. Required -when \code{prior = 'N-Inv-Wishart'}; otherwise \code{NULL}.} - -\item{kappa0_c}{Positive numeric scalar; see \code{kappa0_t}. -For the control group.} - -\item{nu0_c}{Positive numeric scalar; see \code{nu0_t}. -For the control group.} - -\item{mu0_c}{Length-2 numeric vector; see \code{mu0_t}. For the control -group. May be required for the vague prior uncontrolled design; -see \code{\link{pbayesdecisionprob2cont}}.} - -\item{Lambda0_c}{A 2x2 matrix; see \code{Lambda0_t}. -For the control group.} - -\item{r}{A positive numeric scalar giving the power prior weight for -the control group when \code{design = 'uncontrolled'} and -\code{prior = 'vague'}. Otherwise \code{NULL}.} - -\item{ne_t}{A positive integer giving the external treatment sample size. -Required when \code{design = 'external'} and external treatment -data are used; otherwise \code{NULL}.} - -\item{ne_c}{A positive integer giving the external control sample size. -Required when \code{design = 'external'} and external control -data are used; otherwise \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external treatment data. Required when external -treatment data are used; otherwise \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for external control data. Required when external control -data are used; otherwise \code{NULL}.} - -\item{bar_ye_t}{A length-2 numeric vector. External treatment sample -mean. Required when external treatment data are used; -otherwise \code{NULL}.} - -\item{bar_ye_c}{A length-2 numeric vector. External control sample mean. -Required when external control data are used; otherwise \code{NULL}.} - -\item{se_t}{A 2x2 numeric matrix. External treatment sum-of-squares -matrix. Required when external treatment data are used; -otherwise \code{NULL}.} - -\item{se_c}{A 2x2 numeric matrix. External control sum-of-squares -matrix. Required when external control data are used; -otherwise \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Monte Carlo draws -passed to \code{\link{pbayespostpred2cont}}. Required when -\code{CalcMethod = 'MC'}. May be set to \code{NULL} when -\code{CalcMethod = 'MM'} and \eqn{\nu_k > 4}; if -\code{CalcMethod = 'MM'} but \eqn{\nu_k \le 4} causes a fallback -to MC, \code{nMC} must be a positive integer. -Default is \code{NULL}.} - -\item{CalcMethod}{A character string specifying the computation method -passed to \code{\link{pbayespostpred2cont}}. Must be -\code{'MC'} (default) or \code{'MM'}.} - -\item{gamma_go_grid}{A numeric vector of candidate Go threshold values -in \code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} - -\item{gamma_nogo_grid}{A numeric vector of candidate NoGo threshold -values in \code{(0, 1)} to search over. Defaults to -\code{seq(0.01, 0.99, by = 0.01)}.} - -\item{seed}{A numeric scalar for reproducible random number generation. -The Go-calibration simulation uses \code{seed} and the -NoGo-calibration simulation uses \code{seed + 1} to ensure -independence between the two scenarios.} -} -\value{ -A list of class \code{getgamma2cont} with the following elements: -\describe{ -\item{gamma_go}{Optimal Go threshold: the smallest value in -\code{gamma_go_grid} for which the marginal -\eqn{\Pr(\mathrm{Go}) < \code{target\_go}} under the -Go-calibration scenario. \code{NA} if no such value exists.} -\item{gamma_nogo}{Optimal NoGo threshold: the smallest value in -\code{gamma_nogo_grid} for which the marginal -\eqn{\Pr(\mathrm{NoGo}) < \code{target\_nogo}} under the -NoGo-calibration scenario. \code{NA} if no such value exists.} -\item{PrGo_opt}{Marginal \eqn{\Pr(\mathrm{Go})} at -\code{gamma_go} under the Go-calibration scenario. -\code{NA} if \code{gamma_go} is \code{NA}.} -\item{PrNoGo_opt}{Marginal \eqn{\Pr(\mathrm{NoGo})} at -\code{gamma_nogo} under the NoGo-calibration scenario. -\code{NA} if \code{gamma_nogo} is \code{NA}.} -\item{target_go}{The value of \code{target_go} supplied by the user.} -\item{target_nogo}{The value of \code{target_nogo} supplied by the user.} -\item{grid_results}{A data frame with columns \code{gamma_grid}, -\code{PrGo_grid} (marginal Go probability under the Go-calibration -scenario), and \code{PrNoGo_grid} (marginal NoGo probability under -the NoGo-calibration scenario).} -} -} -\description{ -Computes the optimal Go threshold \eqn{\gamma_{\mathrm{go}}} and NoGo -threshold \eqn{\gamma_{\mathrm{nogo}}} for two continuous endpoints by -searching independently over candidate threshold grids. The two -thresholds are calibrated marginally under separate scenarios: -\itemize{ -\item \eqn{\gamma_{\mathrm{go}}} is the \strong{smallest} value in -\code{gamma_go_grid} such that the marginal Go probability is -strictly less than \code{target_go} under the Go-calibration -scenario (\code{mu_t_go}, \code{Sigma_t_go}, \code{mu_c_go}, -\code{Sigma_c_go}); typically the Null scenario. -\item \eqn{\gamma_{\mathrm{nogo}}} is the \strong{smallest} value in -\code{gamma_nogo_grid} such that the marginal NoGo probability is -strictly less than \code{target_nogo} under the NoGo-calibration -scenario (\code{mu_t_nogo}, \code{Sigma_t_nogo}, \code{mu_c_nogo}, -\code{Sigma_c_nogo}); typically the Alternative scenario. -} -} -\details{ -The function uses a two-stage simulate-then-sweep strategy: - -\strong{Stage 1 (simulation and precomputation)}: \code{nsim} bivariate -datasets are generated independently for each calibration scenario. -For the Go-calibration scenario, datasets are drawn from -\eqn{N_2(\mu_{t,\mathrm{go}}, \Sigma_{t,\mathrm{go}})} (and -\eqn{N_2(\mu_{c,\mathrm{go}}, \Sigma_{c,\mathrm{go}})} for -controlled/external designs); for the NoGo-calibration scenario, -the corresponding \code{_nogo} parameters are used. -\code{\link{pbayespostpred2cont}} is called once per scenario in -vectorised mode to return an \eqn{nsim \times 9} matrix of region -probabilities. The probabilities are summed over \code{GoRegions} -(for the Go scenario) and \code{NoGoRegions} (for the NoGo scenario) -to obtain \eqn{\hat{g}_{Go,i}} and \eqn{\hat{g}_{NoGo,i}}, -independent of the decision thresholds. - -\strong{Stage 2 (gamma sweep)}: For each pair -\eqn{(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})} in the -two-dimensional grid, operating characteristics are computed separately -under each calibration scenario: -\deqn{\Pr(\mathrm{Go}) = \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} - \mathbf{1}\!\left[\hat{g}_{Go,i} \ge \gamma_{\mathrm{go}},\; - \hat{g}_{NoGo,i} < \gamma_{\mathrm{nogo}}\right]} -\deqn{\Pr(\mathrm{NoGo}) = \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} - \mathbf{1}\!\left[\hat{g}_{NoGo,i} \ge \gamma_{\mathrm{nogo}},\; - \hat{g}_{Go,i} < \gamma_{\mathrm{go}}\right]} - -\strong{Stage 3 (optimal threshold selection)}: For each candidate -\eqn{\gamma_{\mathrm{go}}}, the worst-case \eqn{\Pr(\mathrm{Go})} over -all \eqn{\gamma_{\mathrm{nogo}}} in \code{gamma_nogo_grid} is computed; -the optimal \eqn{\gamma_{\mathrm{go}}} is the \emph{smallest} grid value -for which this worst-case probability is less than \code{target_go}. -Analogously, the optimal \eqn{\gamma_{\mathrm{nogo}}} is the -\emph{smallest} grid value for which the worst-case -\eqn{\Pr(\mathrm{NoGo})} is less than \code{target_nogo}. -} -\examples{ -# Example 1: Controlled design, posterior probability, vague prior -# gamma_go : smallest gamma_go s.t. max_{gamma_nogo} Pr(Go) < 0.05 under Null -# gamma_nogo: smallest gamma_nogo s.t. max_{gamma_go} Pr(NoGo) < 0.20 under Alt -\donttest{ -Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, - mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma_null, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, - mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma_alt, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = 30L, - theta_TV1 = 10.0, theta_MAV1 = 5.0, - theta_TV2 = 2.0, theta_MAV2 = 1.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -# Example 2: Uncontrolled design, posterior probability, vague prior -\donttest{ -Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'posterior', design = 'uncontrolled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, - mu_c_go = NULL, Sigma_c_go = NULL, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, - mu_c_nogo = NULL, Sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = NULL, - theta_TV1 = 10.0, theta_MAV1 = 5.0, - theta_TV2 = 2.0, theta_MAV2 = 1.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(-10.0, -1.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = NULL, CalcMethod = 'MM', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -# Example 3: External design (control only), posterior probability, NIW prior -\donttest{ -Sigma <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Lambda <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -se_c <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'posterior', design = 'external', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma, - mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma, - mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = 30L, - theta_TV1 = 10.0, theta_MAV1 = 5.0, - theta_TV2 = 2.0, theta_MAV2 = 1.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = 0.1, nu0_t = 4.0, mu0_t = c(0.0, 1.0), Lambda0_t = Lambda, - kappa0_c = 0.1, nu0_c = 4.0, mu0_c = c(-10.0, -1.0), Lambda0_c = Lambda, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(-10.0, -1.0), se_t = NULL, se_c = se_c, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -# Example 4: Controlled design, predictive probability, vague prior -\donttest{ -Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'predictive', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 4L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, - mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma_null, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, - mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma_alt, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 5.0, theta_NULL2 = 1.0, - m_t = 100L, m_c = 100L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -# Example 5: Uncontrolled design, predictive probability, vague prior -\donttest{ -Sigma_null <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Sigma_alt <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'predictive', design = 'uncontrolled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 4L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma_null, - mu_c_go = NULL, Sigma_c_go = NULL, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma_alt, - mu_c_nogo = NULL, Sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = NULL, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 5.0, theta_NULL2 = 1.0, - m_t = 100L, m_c = 100L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(-10.0, -1.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -# Example 6: External design (control only), predictive probability, NIW prior -\donttest{ -Sigma <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -Lambda <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -se_c <- matrix(c(6400.0, 15.0, 15.0, 36.0), 2, 2) -getgamma2cont( - nsim = 1000L, prob = 'predictive', design = 'external', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 4L, - mu_t_go = c(-5.0, 0.0), Sigma_t_go = Sigma, - mu_c_go = c(-10.0, -1.0), Sigma_c_go = Sigma, - mu_t_nogo = c(5.0, 1.0), Sigma_t_nogo = Sigma, - mu_c_nogo = c(-10.0, -1.0), Sigma_c_nogo = Sigma, - target_go = 0.05, target_nogo = 0.20, - n_t = 30L, n_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 5.0, theta_NULL2 = 1.0, - m_t = 100L, m_c = 100L, - kappa0_t = 0.1, nu0_t = 4.0, mu0_t = c(0.0, 1.0), Lambda0_t = Lambda, - kappa0_c = 0.1, nu0_c = 4.0, mu0_c = c(-10.0, -1.0), Lambda0_c = Lambda, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(-10.0, -1.0), se_t = NULL, se_c = se_c, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.01, 0.99, by = 0.01), - gamma_nogo_grid = seq(0.01, 0.99, by = 0.01), - seed = 1L -) -} - -} diff --git a/man/getjointbin.Rd b/man/getjointbin.Rd deleted file mode 100644 index fe8b632..0000000 --- a/man/getjointbin.Rd +++ /dev/null @@ -1,96 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/getjointbin.R -\name{getjointbin} -\alias{getjointbin} -\title{Compute Joint Bivariate Binary Probabilities from Marginal Rates -and Correlation} -\usage{ -getjointbin(pi1, pi2, rho, tol = 1e-10) -} -\arguments{ -\item{pi1}{A single numeric value in \code{(0, 1)} giving the marginal -response probability for Endpoint 1 (\eqn{\pi_{j1}}) in group -\eqn{j}.} - -\item{pi2}{A single numeric value in \code{(0, 1)} giving the marginal -response probability for Endpoint 2 (\eqn{\pi_{j2}}) in group -\eqn{j}.} - -\item{rho}{A single numeric value giving the Pearson correlation -(\eqn{\rho_j}) between Endpoint 1 and Endpoint 2 in group \eqn{j}. -Must lie within the feasible range -\eqn{[\rho_{\min}, \rho_{\max}]} determined by \code{pi1} and -\code{pi2} (see Details). Use \code{rho = 0} for independence.} - -\item{tol}{A single positive numeric value specifying the tolerance used -when checking whether \code{rho} lies within its feasible range and -whether the resulting probabilities are non-negative. -Default is \code{1e-10}.} -} -\value{ -A named numeric vector of length 4 with elements -\code{p00}, \code{p01}, \code{p10}, \code{p11}, where -\code{p_lm = Pr(Endpoint 1 = l, Endpoint 2 = m)} for -\eqn{l, m \in \{0, 1\}}. -All elements are non-negative and sum to 1. -} -\description{ -Converts the parameterisation \eqn{(\pi_{j1}, \pi_{j2}, \rho_j)} into the -four-cell joint probability vector -\eqn{(p_{j,00}, p_{j,01}, p_{j,10}, p_{j,11})} for a bivariate binary -outcome in group \eqn{j \in \{t, c\}}. The conversion uses the standard -moment-matching identity for the Pearson correlation of two Bernoulli -variables, and checks that the requested correlation is feasible for the -supplied marginal rates. -} -\details{ -For a bivariate binary outcome \eqn{(Y_{i1}, Y_{i2})} of patient -\eqn{i} (\eqn{i = 1, \ldots, n_j}) in group \eqn{j} with marginal success -probabilities \eqn{\pi_{j1} = \Pr(Y_{i1} = 1)} and -\eqn{\pi_{j2} = \Pr(Y_{i2} = 1)}, the Pearson correlation is -\deqn{ - \rho_j = \frac{p_{j,11} - \pi_{j1} \pi_{j2}} - {\sqrt{\pi_{j1}(1 - \pi_{j1})\, \pi_{j2}(1 - \pi_{j2})}}. -} -Solving for \eqn{p_{j,11}} gives -\deqn{p_{j,11} = \rho_j \sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})} - + \pi_{j1} \pi_{j2},} -from which the remaining probabilities follow: -\deqn{p_{j,10} = \pi_{j1} - p_{j,11}, \quad - p_{j,01} = \pi_{j2} - p_{j,11}, \quad - p_{j,00} = 1 - p_{j,10} - p_{j,01} - p_{j,11}.} - -For all four cell probabilities to lie in \code{[0, 1]}, the correlation -must satisfy -\deqn{ - \rho_{\min} = - \frac{\max(0,\; \pi_{j1} + \pi_{j2} - 1) - \pi_{j1}\pi_{j2}} - {\sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})}} - \;\le\; \rho_j \;\le\; - \frac{\min(\pi_{j1}, \pi_{j2}) - \pi_{j1}\pi_{j2}} - {\sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})}} - = \rho_{\max}. -} -The function raises an error if \code{rho} falls outside this range -(subject to \code{tol}). -} -\examples{ -# Example 1: Independent endpoints (rho = 0) -getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.0) - -# Example 2: Positive correlation -getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.3) - -# Example 3: Negative correlation -getjointbin(pi1 = 0.3, pi2 = 0.4, rho = -0.2) - -# Example 4: Verify cell probabilities sum to 1 -p <- getjointbin(pi1 = 0.25, pi2 = 0.35, rho = 0.1) -sum(p) # Should be 1 - -# Example 5: Verify marginal recovery -p <- getjointbin(pi1 = 0.25, pi2 = 0.35, rho = 0.1) -p["p10"] + p["p11"] # Should equal pi1 = 0.25 -p["p01"] + p["p11"] # Should equal pi2 = 0.35 - -} diff --git a/man/hypothetical.Rd b/man/hypothetical.Rd new file mode 100644 index 0000000..83a681a --- /dev/null +++ b/man/hypothetical.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/hypothetical.R +\name{hypothetical} +\alias{hypothetical} +\title{Hypothetical control for an uncontrolled study} +\usage{ +hypothetical(data = NULL, mean = NULL, r = NULL) +} +\arguments{ +\item{data}{Hypothetical control data created by +\code{\link{data_binary}}, \code{\link{data_binary2}} (binary +endpoints) or \code{\link{data_tte}} (time-to-event endpoint).} + +\item{mean}{Location of the hypothetical control mean, a number for one +continuous endpoint or a numeric vector of length 2 for two continuous +endpoints.} + +\item{r}{Positive ratio of the squared scale of the hypothetical control to +that of the treatment group (continuous endpoints).} +} +\value{ +An object of class \code{"qdm_hypothetical"} with elements +\code{type} (\code{"data"} or \code{"location"}), \code{data}, +\code{mean} and \code{r}. +} +\description{ +Specifies the distribution of a hypothetical control group, used when the +proof-of-concept study has no concurrent control group (Kang et al., 2026). +} +\details{ +For binary and time-to-event endpoints, give \code{data}: the +hypothetical control data are combined with the prior of the control +group, for example \eqn{\pi_c \sim \textrm{Beta}(a_c + y, b_c + n - y)} +for one binary endpoint, or a Gamma distribution of the hazard with shape +\eqn{a_c + d} and rate \eqn{b_c + E} for \eqn{d} events in the total +observed time \eqn{E}. For continuous endpoints, give \code{mean} and \code{r}: the +control mean has the same t distribution as the posterior distribution of +the treatment mean, with location \code{mean} and squared scale multiplied +by \code{r}, that is +\eqn{\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, r \sigma_{nt}^2 / \kappa_{nt})}. +} +\examples{ +# Binary endpoint: 5 responders out of 15 hypothetical control subjects +hypothetical(data = data_binary(n = 15, y = 5)) + +# Continuous endpoint: control mean located at 1 with the same scale +hypothetical(mean = 1, r = 1) + +# Time-to-event endpoint: 8 events in a total observed time of 60 +hypothetical(data = data_tte(events = 8, exposure = 60)) +} +\references{ +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. \emph{Journal of Biopharmaceutical Statistics}. +\doi{10.1080/10543406.2026.2655410} +} diff --git a/man/pbayesdecisionprob1bin.Rd b/man/pbayesdecisionprob1bin.Rd deleted file mode 100644 index 6f37306..0000000 --- a/man/pbayesdecisionprob1bin.Rd +++ /dev/null @@ -1,259 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayesdecisionprob1bin.R -\name{pbayesdecisionprob1bin} -\alias{pbayesdecisionprob1bin} -\title{Go/NoGo/Gray Decision Probabilities for a Clinical Trial with a Single Binary Endpoint} -\usage{ -pbayesdecisionprob1bin( - prob = "posterior", - design = "controlled", - theta_TV = NULL, - theta_MAV = NULL, - theta_NULL = NULL, - gamma_go, - gamma_nogo, - pi_t, - pi_c = NULL, - n_t, - n_c, - a_t, - a_c, - b_t, - b_c, - z = NULL, - m_t = NULL, - m_c = NULL, - ne_t = NULL, - ne_c = NULL, - ye_t = NULL, - ye_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{theta_TV}{A numeric scalar giving the target value (TV) threshold used for -the Go decision when \code{prob = 'posterior'}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV}{A numeric scalar giving the minimum acceptable value (MAV) -threshold used for the NoGo decision when \code{prob = 'posterior'}. -Must satisfy \code{theta_TV > theta_MAV}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_NULL}{A numeric scalar giving the null hypothesis threshold used for -both Go and NoGo decisions when \code{prob = 'predictive'}. Set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{gamma_go}{A numeric scalar in \code{(0, 1)} giving the minimum posterior or -predictive probability required for a Go decision.} - -\item{gamma_nogo}{A numeric scalar in \code{(0, 1)} giving the minimum posterior or -predictive probability required for a NoGo decision. No ordering -constraint on \code{gamma_go} and \code{gamma_nogo} is imposed, though -their combination determines the frequency of Miss outcomes.} - -\item{pi_t}{A numeric value or vector giving the true response probability(s) for -the treatment group used to evaluate operating characteristics. Each element -must be in \code{(0, 1)}.} - -\item{pi_c}{A numeric value or vector giving the true response probability(s) for -the control group. For \code{design = 'uncontrolled'}, this parameter is -not used in calculations but must be supplied; it is excluded from the output. -When supplied as a vector, must have the same length as \code{pi_t}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. For \code{design = 'uncontrolled'}, -this is the hypothetical control sample size (required for -consistency with other designs).} - -\item{a_t}{A positive numeric scalar giving the first shape parameter -(alpha) of the prior Beta distribution for the treatment group.} - -\item{a_c}{A positive numeric scalar giving the first shape parameter -(alpha) of the prior Beta distribution for the control group.} - -\item{b_t}{A positive numeric scalar giving the second shape parameter -(beta) of the prior Beta distribution for the treatment group.} - -\item{b_c}{A positive numeric scalar giving the second shape parameter -(beta) of the prior Beta distribution for the control group.} - -\item{z}{A non-negative integer giving the hypothetical number of responders -in the control group. Required when \code{design = 'uncontrolled'}; -otherwise set to \code{NULL}. When used, \code{y_c} should be -\code{NULL}.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{ne_t}{A positive integer giving the number of patients in the -treatment group of the external data set. Required when -\code{design = 'external'} and external treatment data are -available; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the number of patients in the -control group of the external data set. Required when -\code{design = 'external'} and external control data are available; -otherwise set to \code{NULL}.} - -\item{ye_t}{A non-negative integer giving the number of responders in the -treatment group of the external data set. Required when -\code{design = 'external'}; otherwise set to \code{NULL}.} - -\item{ye_c}{A non-negative integer giving the number of responders in the -control group of the external data set. Required when -\code{design = 'external'}; otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior weight for -the treatment group. Required when \code{design = 'external'}; -otherwise \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior weight for -the control group. Required when \code{design = 'external'}; -otherwise \code{NULL}.} - -\item{error_if_Miss}{A logical scalar; if \code{TRUE} (default), the function stops -with an error if Miss probability > 0, prompting reconsideration of thresholds.} - -\item{Gray_inc_Miss}{A logical scalar; if \code{TRUE}, Miss probability is added -to Gray probability. If \code{FALSE} (default), Miss is reported separately. -Active only when \code{error_if_Miss = FALSE}.} -} -\value{ -A data frame with one row per \code{pi_t} scenario and columns: -\describe{ -\item{pi_t}{True treatment response probability.} -\item{pi_c}{True control response probability (omitted for uncontrolled design).} -\item{Go}{Probability of making a Go decision.} -\item{Gray}{Probability of making a Gray (inconclusive) decision.} -\item{NoGo}{Probability of making a NoGo decision.} -\item{Miss}{(Optional) Probability where Go and NoGo criteria are simultaneously -met. Included when \code{error_if_Miss = FALSE} and -\code{Gray_inc_Miss = FALSE}.} -} -The returned object has S3 class \code{pbayesdecisionprob1bin} with an associated -\code{print} method. -} -\description{ -Evaluates operating characteristics (Go, NoGo, Gray probabilities) for binary-outcome -clinical trials under the Bayesian framework by enumerating all possible trial -outcomes. The function supports controlled, uncontrolled, and external designs. -} -\details{ -Operating characteristics are computed by exact enumeration: -\enumerate{ -\item All possible outcome pairs \eqn{(y_t, y_c)} with \eqn{y_t \in \{0,\ldots,n_t\}} -and \eqn{y_c \in \{0,\ldots,n_c\}} (or fixed at \eqn{z} for uncontrolled) are -evaluated. -\item For each pair, \code{\link{pbayespostpred1bin}} computes the posterior or predictive -probability at both thresholds (TV/MAV or NULL). -\item Outcomes are classified into Go, NoGo, Miss, or Gray: -\itemize{ -\item \strong{Go}: \eqn{P(\mathrm{Go}) \ge \gamma_1} AND -\eqn{P(\mathrm{NoGo}) < \gamma_2} -\item \strong{NoGo}: \eqn{P(\mathrm{Go}) < \gamma_1} AND -\eqn{P(\mathrm{NoGo}) \ge \gamma_2} -\item \strong{Miss}: both Go and NoGo criteria met simultaneously -\item \strong{Gray}: neither Go nor NoGo criteria met -} -\item Each outcome is weighted by its binomial probability under the true rates. -} -} -\examples{ -# Example 1: Controlled design with posterior probability -pbayesdecisionprob1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.4, theta_MAV = 0.2, theta_NULL = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), - n_t = 12, n_c = 12, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -# Example 2: Uncontrolled design with hypothetical control -pbayesdecisionprob1bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV = 0.30, theta_MAV = 0.15, theta_NULL = NULL, - gamma_go = 0.75, gamma_nogo = 0.25, - pi_t = c(0.3, 0.5, 0.7), pi_c = NULL, - n_t = 15, n_c = 15, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = 5, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -# Example 3: External design with 50 percent power prior borrowing -pbayesdecisionprob1bin( - prob = 'posterior', design = 'external', - theta_TV = 0.4, theta_MAV = 0.2, theta_NULL = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), - n_t = 12, n_c = 12, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = 15, ne_c = 15, ye_t = 6, ye_c = 4, alpha0e_t = 0.5, alpha0e_c = 0.5, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -# Example 4: Posterior predictive probability for controlled design -pbayesdecisionprob1bin( - prob = 'predictive', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, - gamma_go = 0.9, gamma_nogo = 0.3, - pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), - n_t = 12, n_c = 12, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = 30, m_c = 30, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -# Example 5: Uncontrolled design with posterior predictive probability -pbayesdecisionprob1bin( - prob = 'predictive', design = 'uncontrolled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, - gamma_go = 0.75, gamma_nogo = 0.25, - pi_t = c(0.3, 0.5, 0.7), pi_c = NULL, - n_t = 15, n_c = 15, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = 5, m_t = 30, m_c = 30, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -# Example 6: External design with posterior predictive probability -pbayesdecisionprob1bin( - prob = 'predictive', design = 'external', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0, - gamma_go = 0.9, gamma_nogo = 0.3, - pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = rep(0.2, 4), - n_t = 12, n_c = 12, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = 30, m_c = 30, - ne_t = 15, ne_c = 15, ye_t = 6, ye_c = 4, alpha0e_t = 0.5, alpha0e_c = 0.5, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) - -} diff --git a/man/pbayesdecisionprob1cont.Rd b/man/pbayesdecisionprob1cont.Rd deleted file mode 100644 index 59d9976..0000000 --- a/man/pbayesdecisionprob1cont.Rd +++ /dev/null @@ -1,344 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayesdecisionprob1cont.R -\name{pbayesdecisionprob1cont} -\alias{pbayesdecisionprob1cont} -\title{Bayesian Go/NoGo/Gray Decision Probabilities for Single Continuous Endpoint} -\usage{ -pbayesdecisionprob1cont( - nsim, - prob, - design, - prior, - CalcMethod, - theta_TV = NULL, - theta_MAV = NULL, - theta_NULL = NULL, - nMC = NULL, - gamma_go, - gamma_nogo, - n_t, - n_c = NULL, - m_t = NULL, - m_c = NULL, - kappa0_t = NULL, - kappa0_c = NULL, - nu0_t = NULL, - nu0_c = NULL, - mu0_t = NULL, - mu0_c = NULL, - sigma0_t = NULL, - sigma0_c = NULL, - mu_t, - mu_c = NULL, - sigma_t, - sigma_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE, - seed -) -} -\arguments{ -\item{nsim}{A positive integer specifying the number of Monte Carlo simulation replicates.} - -\item{prob}{A character string specifying the probability type: \code{'posterior'} or -\code{'predictive'}.} - -\item{design}{A character string specifying the trial design: \code{'controlled'}, -\code{'uncontrolled'}, or \code{'external'}.} - -\item{prior}{A character string specifying the prior distribution: \code{'vague'} or -\code{'N-Inv-Chisq'}.} - -\item{CalcMethod}{A character string specifying the computation method: \code{'NI'} -(Numerical Integration), \code{'MC'} (Monte Carlo), or \code{'MM'} -(Moment Matching).} - -\item{theta_TV}{A numeric value representing the target value (TV) threshold for the -Go decision. Required if \code{prob = 'posterior'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{theta_MAV}{A numeric value representing the minimum acceptable value (MAV) threshold -for the NoGo decision. Required if \code{prob = 'posterior'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{theta_NULL}{A numeric value representing the null hypothesis threshold. -Required if \code{prob = 'predictive'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{nMC}{A positive integer specifying the number of Monte Carlo draws for computing -posterior probabilities. Required if \code{CalcMethod = 'MC'}; -otherwise \code{NULL}.} - -\item{gamma_go}{A numeric scalar in \code{(0, 1)} giving the minimum posterior or -predictive probability required for a Go decision.} - -\item{gamma_nogo}{A numeric scalar in \code{(0, 1)} giving the minimum posterior or -predictive probability required for a NoGo decision. No ordering -constraint on \code{gamma_go} and \code{gamma_nogo} is imposed, though -their combination determines the frequency of Miss outcomes.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the proof-of-concept (PoC) trial. Required for -\code{design = 'controlled'} or \code{'external'}; set to -\code{NULL} for \code{design = 'uncontrolled'}.} - -\item{m_t}{A positive integer representing the future sample size for the -treatment group. Required if \code{prob = 'predictive'}; -otherwise \code{NULL}. Default is \code{NULL}.} - -\item{m_c}{A positive integer representing the future sample size for the control group. -Required if \code{prob = 'predictive'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{kappa0_t}{A positive numeric value representing the prior hyperparameter kappa for -the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{kappa0_c}{A positive numeric value representing the prior hyperparameter kappa for -the control group. Required if \code{prior = 'N-Inv-Chisq'} and -\code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{nu0_t}{A positive numeric value representing the prior hyperparameter nu for -the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{nu0_c}{A positive numeric value representing the prior hyperparameter nu for -the control group. Required if \code{prior = 'N-Inv-Chisq'} and -\code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{mu0_t}{A numeric value representing the prior mean for the treatment group. Required if -\code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. Default is \code{NULL}.} - -\item{mu0_c}{A numeric value representing the prior mean for the control group. For -\code{design = 'uncontrolled'}, this represents the hypothetical control mean. -Required if \code{prior = 'N-Inv-Chisq'} and -\code{design \%in\% c('controlled', 'external')}, or if -\code{design = 'uncontrolled'}; otherwise \code{NULL}. Default is \code{NULL}.} - -\item{sigma0_t}{A positive numeric value representing the prior standard deviation for -the treatment group. Required if \code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{sigma0_c}{A positive numeric value representing the prior standard deviation for -the control group. Required if \code{prior = 'N-Inv-Chisq'} and -\code{design \%in\% c('controlled', 'external')}; otherwise \code{NULL}. -Default is \code{NULL}.} - -\item{mu_t}{A numeric value representing the true mean for the treatment group in the simulation.} - -\item{mu_c}{A numeric value representing the true mean for the control group in the simulation. -For uncontrolled design, this represents the historical control mean. -Set to \code{NULL} if \code{design = 'uncontrolled'}.} - -\item{sigma_t}{A positive numeric value representing the true standard deviation -for the treatment group in the simulation.} - -\item{sigma_c}{A positive numeric value representing the true standard deviation -for the control group in the simulation. For uncontrolled design, this represents -the historical control standard deviation. -Set to \code{NULL} if \code{design = 'uncontrolled'}.} - -\item{r}{A positive numeric value representing the variance scaling factor that allows -the scale of hypothetical control to be different from treatment. Specifically, -\code{sd.control = sqrt(r) * sd.treatment}. Required if \code{design = 'uncontrolled'}. -When \code{r = 1}, the control and treatment have the same variance scale.} - -\item{ne_t}{A positive integer representing the number of patients in the treatment group for -the external data. Required if \code{design = 'external'} and external -treatment data are available.} - -\item{ne_c}{A positive integer representing the number of patients in the control group for -the external data. Required if \code{design = 'external'} and external -control data are available.} - -\item{alpha0e_t}{A numeric value in \code{(0, 1]} representing the power prior scale parameter -for the treatment group. Controls the degree of borrowing from external treatment data: -0 = no borrowing, 1 = full borrowing. Required if \code{ne_t} is specified.} - -\item{alpha0e_c}{A numeric value in \code{(0, 1]} representing the power prior scale parameter -for the control group. Controls the degree of borrowing from external control data: -0 = no borrowing, 1 = full borrowing. Required if \code{ne_c} is specified.} - -\item{bar_ye_t}{A numeric value representing the sample mean of the external data -for the treatment group. Required if \code{ne_t} is specified.} - -\item{bar_ye_c}{A numeric value representing the sample mean of the external data -for the control group. Required if \code{ne_c} is specified.} - -\item{se_t}{A positive numeric value representing the sample standard deviation -of the external data for the treatment group. Required if \code{ne_t} is specified.} - -\item{se_c}{A positive numeric value representing the sample standard deviation -of the external data for the control group. Required if \code{ne_c} is specified.} - -\item{error_if_Miss}{A logical value; if \code{TRUE} (default), the function stops -with an error when positive Miss probability is obtained, indicating poorly -chosen thresholds. If \code{FALSE}, the function proceeds and reports Miss -probability based on \code{Gray_inc_Miss} setting.} - -\item{Gray_inc_Miss}{A logical value; if \code{TRUE}, Miss probability is included -in Gray probability (Miss is not reported separately). If \code{FALSE} -(default), Miss probability is reported as a separate category. This parameter -is only active when \code{error_if_Miss = FALSE}.} - -\item{seed}{A numeric value representing the seed number for reproducible random number generation.} -} -\value{ -A data frame containing the true means for both groups and the Go, NoGo, and -Gray probabilities. When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = FALSE}, -Miss probability is also included as a separate column. For uncontrolled design, -only mu_t is included (not mu_c). -} -\description{ -Evaluates Go/NoGo/Gray decision probabilities for a single continuous endpoint -via Monte Carlo simulation. Supports controlled (parallel control), uncontrolled -(single-arm with informative priors), and external (power prior borrowing) -designs with both posterior and predictive probability approaches. -} -\details{ -The function performs Monte Carlo simulation to evaluate operating characteristics by: -\itemize{ -\item Generating random trial data based on specified true parameters -\item Computing posterior or predictive probabilities for each simulated trial -\item Classifying each trial as Go, NoGo, or Gray based on decision thresholds -} - -Posterior parameter calculations (mu.t1, mu.t2, sd.t1, sd.t2, nu.t1, nu.t2) are -fully vectorized over the nsim simulated datasets. pbayespostpred1cont is called -twice (once per threshold), with each call receiving vectors of length nsim and -returning a vector of nsim probabilities - no inner loop over simulation replicates -is required. - -For external designs, power priors are incorporated using exact conjugate representation: -\itemize{ -\item Power priors for normal data are mathematically equivalent to Normal-Inverse-Chi-squared distributions -\item This enables closed-form computation without MCMC sampling -\item Alpha parameters control the degree of borrowing (0 = no borrowing, 1 = full borrowing) -} - -\strong{Decision rules}: -\itemize{ -\item \strong{Go}: gGo >= gamma_go and gNoGo < gamma_nogo -\item \strong{NoGo}: gGo < gamma_go and gNoGo >= gamma_nogo -\item \strong{Gray}: neither Go nor NoGo criterion is met -\item \strong{Miss}: both Go and NoGo criteria are met simultaneously -} - -\strong{Handling Miss probability}: -\itemize{ -\item When \code{error_if_Miss = TRUE} (default): Function stops with error if -Miss probability > 0, prompting reconsideration of thresholds -\item When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = TRUE}: Miss -probability is added to Gray probability -\item When \code{error_if_Miss = FALSE} and \code{Gray_inc_Miss = FALSE}: Miss -probability is reported as a separate category -} - -The function can be used for: -\itemize{ -\item \strong{Controlled design}: Two-arm randomized trial -\item \strong{Uncontrolled design}: Single-arm trial with informative priors (historical control) -\item \strong{External design}: Incorporating historical data through power priors -} -} -\examples{ -# Example 1: Controlled design with vague prior and NI method -# (default: error_if_Miss = TRUE, Gray_inc_Miss = FALSE) -pbayesdecisionprob1cont( - nsim = 100, prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'NI', - theta_TV = 1.5, theta_MAV = -0.5, theta_NULL = NULL, - nMC = NULL, gamma_go = 0.7, gamma_nogo = 0.2, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = 3, mu_c = 1, sigma_t = 1.2, sigma_c = 1.1, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 2 -) - -# Example 2: Uncontrolled design with informative prior -pbayesdecisionprob1cont( - nsim = 100, prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Chisq', CalcMethod = 'NI', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, - nMC = NULL, gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 20, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = 2, kappa0_c = NULL, nu0_t = 5, nu0_c = NULL, - mu0_t = 3.0, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = NULL, - mu_t = 3.5, mu_c = NULL, sigma_t = 1.3, sigma_c = NULL, - r = 1, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 3 -) - -# Example 3: External design with control data using MM approximation -pbayesdecisionprob1cont( - nsim = 100, prob = 'posterior', design = 'external', prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, - nMC = NULL, gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 12, n_c = 12, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = 2, mu_c = 0, sigma_t = 1, sigma_c = 1, - r = NULL, ne_t = NULL, ne_c = 20, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = 0, se_t = NULL, se_c = 1, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 4 -) - -# Example 4: Controlled design with predictive probability -pbayesdecisionprob1cont( - nsim = 100, prob = 'predictive', design = 'controlled', prior = 'N-Inv-Chisq', CalcMethod = 'NI', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 2.0, - nMC = NULL, gamma_go = 0.75, gamma_nogo = 0.35, - n_t = 15, n_c = 15, m_t = 50, m_c = 50, - kappa0_t = 3, kappa0_c = 3, nu0_t = 4, nu0_c = 4, - mu0_t = 3.5, mu0_c = 1.5, sigma0_t = 1.5, sigma0_c = 1.5, - mu_t = 3.2, mu_c = 1.3, sigma_t = 1.4, sigma_c = 1.2, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 5 -) - -# Example 5: Uncontrolled design with predictive probability -pbayesdecisionprob1cont( - nsim = 100, prob = 'predictive', design = 'uncontrolled', prior = 'vague', CalcMethod = 'NI', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.0, - nMC = NULL, gamma_go = 0.75, gamma_nogo = 0.35, - n_t = 20, n_c = NULL, m_t = 40, m_c = 40, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 1.5, sigma0_t = NULL, sigma0_c = NULL, - mu_t = 3, mu_c = NULL, sigma_t = 1.3, sigma_c = NULL, - r = 1, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 9 -) - -# Example 6: External design with predictive probability using MC method -pbayesdecisionprob1cont( - nsim = 100, prob = 'predictive', design = 'external', prior = 'vague', CalcMethod = 'MC', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1.5, - nMC = 5000, gamma_go = 0.7, gamma_nogo = 0.4, - n_t = 12, n_c = 12, m_t = 30, m_c = 30, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = 2.5, mu_c = 1.0, sigma_t = 1.3, sigma_c = 1.1, - r = NULL, ne_t = 15, ne_c = 18, alpha0e_t = 0.6, alpha0e_c = 0.7, - bar_ye_t = 2.3, bar_ye_c = 0.9, se_t = 1.2, se_c = 1.0, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE, seed = 6 -) - -} diff --git a/man/pbayesdecisionprob2bin.Rd b/man/pbayesdecisionprob2bin.Rd deleted file mode 100644 index 334de29..0000000 --- a/man/pbayesdecisionprob2bin.Rd +++ /dev/null @@ -1,550 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayesdecisionprob2bin.R -\name{pbayesdecisionprob2bin} -\alias{pbayesdecisionprob2bin} -\title{Go/NoGo/Gray Decision Probabilities for a Clinical Trial with Two Binary -Endpoints} -\usage{ -pbayesdecisionprob2bin( - nsim = 10000L, - prob = "posterior", - design = "controlled", - GoRegions, - NoGoRegions, - gamma_go, - gamma_nogo, - pi_t1, - pi_t2, - rho_t, - pi_c1 = NULL, - pi_c2 = NULL, - rho_c = NULL, - n_t, - n_c = NULL, - a_t_00, - a_t_01, - a_t_10, - a_t_11, - a_c_00, - a_c_01, - a_c_10, - a_c_11, - m_t = NULL, - m_c = NULL, - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - z00 = NULL, - z01 = NULL, - z10 = NULL, - z11 = NULL, - xe_t_00 = NULL, - xe_t_01 = NULL, - xe_t_10 = NULL, - xe_t_11 = NULL, - xe_c_00 = NULL, - xe_c_01 = NULL, - xe_c_10 = NULL, - xe_c_11 = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - nMC = 10000L, - CalcMethod = "Exact", - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE -) -} -\arguments{ -\item{nsim}{A positive integer giving the number of PoC count vectors -sampled via \code{rmultinom} per arm per scenario when -\code{CalcMethod = 'MC'} (outer loop). The sampled vectors are -deduplicated into \eqn{K_t} and \eqn{K_c} unique vectors -(\eqn{K_t, K_c \ll} \code{nsim}); Dirichlet sampling is then -performed only for these unique vectors using \code{nMC} draws each. -Ignored when \code{CalcMethod = 'Exact'}. Default is \code{10000}.} - -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{GoRegions}{An integer vector specifying which of the nine posterior -regions (R1--R9) or four predictive regions (R1--R4) constitute a -Go decision. For \code{prob = 'posterior'}, valid values are -integers in 1--9; for \code{prob = 'predictive'}, in 1--4. -A common choice is \code{GoRegions = 1} (both endpoints exceed TV -or NULL for posterior/predictive, respectively).} - -\item{NoGoRegions}{An integer vector specifying which regions constitute a -NoGo decision. A common choice is \code{NoGoRegions = 9} (both -endpoints below MAV) for posterior, or \code{NoGoRegions = 4} for -predictive. Must be disjoint from \code{GoRegions}.} - -\item{gamma_go}{A numeric scalar in \code{(0, 1)}. Go threshold: -a Go decision is made if \eqn{P(\mathrm{GoRegions}) \ge \gamma_1}.} - -\item{gamma_nogo}{A numeric scalar in \code{(0, 1)}. NoGo threshold: -a NoGo decision is made if \eqn{P(\mathrm{NoGoRegions}) \ge \gamma_2}. -No ordering constraint on \code{gamma_go} and \code{gamma_nogo} is -imposed; their combination determines the frequency of Miss outcomes.} - -\item{pi_t1}{A numeric vector of true treatment response probabilities -for Endpoint 1. Each element must be in \code{(0, 1)}.} - -\item{pi_t2}{A numeric vector of true treatment response probabilities -for Endpoint 2. Must have the same length as \code{pi_t1}.} - -\item{rho_t}{A numeric vector of true within-treatment-arm correlations -between Endpoint 1 and Endpoint 2. Must have the same length as -\code{pi_t1}. If any element is outside the feasible range for -the corresponding \code{(pi_t1, pi_t2)} pair, that scenario returns -\code{NA} for all decision probabilities instead of stopping with -an error.} - -\item{pi_c1}{A numeric vector of true control response probabilities for -Endpoint 1. For \code{design = 'uncontrolled'}, this parameter -is not used in probability calculations but must still be supplied; -it is retained in the output for reference. Must have the same -length as \code{pi_t1}.} - -\item{pi_c2}{A numeric vector of true control response probabilities for -Endpoint 2. For \code{design = 'uncontrolled'}, see note for -\code{pi_c1}. Must have the same length as \code{pi_t1}.} - -\item{rho_c}{A numeric vector of true within-control-arm correlations. -For \code{design = 'uncontrolled'}, not used in probability -calculations. Must have the same length as \code{pi_t1}. If any -element is outside the feasible range for the corresponding -\code{(pi_c1, pi_c2)} pair, that scenario returns \code{NA} for -all decision probabilities.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. For \code{design = 'uncontrolled'}, -this is the hypothetical control sample size (required for -consistency with other designs).} - -\item{a_t_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 0)} response pattern in the treatment -group.} - -\item{a_t_01}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 1)} response pattern in the treatment -group.} - -\item{a_t_10}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 0)} response pattern in the treatment -group.} - -\item{a_t_11}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 1)} response pattern in the treatment -group.} - -\item{a_c_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 0)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_01}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 1)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_10}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 0)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_11}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 1)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{theta_TV1}{A numeric scalar giving the target value (TV) threshold -for Endpoint 1. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV1}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 1. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_TV2}{A numeric scalar giving the target value (TV) threshold -for Endpoint 2. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV2}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 2. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{z00}{A non-negative integer giving the hypothetical control count -for pattern \code{(0, 0)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z01}{A non-negative integer giving the hypothetical control count -for pattern \code{(0, 1)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z10}{A non-negative integer giving the hypothetical control count -for pattern \code{(1, 0)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z11}{A non-negative integer giving the hypothetical control count -for pattern \code{(1, 1)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{xe_t_00}{A non-negative integer giving the external treatment group -count for pattern \code{(0, 0)}. Required when -\code{design = 'external'} and external treatment data are used; -otherwise \code{NULL}.} - -\item{xe_t_01}{A non-negative integer giving the external treatment group -count for pattern \code{(0, 1)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_t_10}{A non-negative integer giving the external treatment group -count for pattern \code{(1, 0)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_t_11}{A non-negative integer giving the external treatment group -count for pattern \code{(1, 1)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_c_00}{A non-negative integer giving the external control group -count for pattern \code{(0, 0)}. Required when -\code{design = 'external'} and external control data are used; -otherwise \code{NULL}.} - -\item{xe_c_01}{A non-negative integer giving the external control group -count for pattern \code{(0, 1)}. Required for external control -data; otherwise \code{NULL}.} - -\item{xe_c_10}{A non-negative integer giving the external control group -count for pattern \code{(1, 0)}. Required for external control -data; otherwise \code{NULL}.} - -\item{xe_c_11}{A non-negative integer giving the external control group -count for pattern \code{(1, 1)}. Required for external control -data; otherwise \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the treatment group. Required when external treatment -data are used; otherwise \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the control group. Required when external control -data are used; otherwise \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Dirichlet draws used to -evaluate the decision probability for each count combination in -Stage 1. Used by both \code{CalcMethod = 'Exact'} and -\code{CalcMethod = 'MC'} (inner loop). Default is \code{10000}.} - -\item{CalcMethod}{A character string specifying the computation method. -Must be \code{'Exact'} (default) or \code{'MC'}. -\code{'Exact'} uses full enumeration of all possible multinomial -count combinations (two-stage approach described in Details). -\code{'MC'} samples \code{nsim} \eqn{(x_t, x_c)} pairs via -\code{rmultinom}, deduplicates them into \eqn{K} unique pairs -(\eqn{K \ll} \code{nsim}), calls -\code{\link{pbayespostpred2bin}} for each unique pair to obtain -Go/NoGo probabilities, and weights the decisions by the observed -pair frequencies. This reuses the same validated probability logic -as the Exact method, avoiding any duplication of computation. -The \code{'MC'} method trades some Monte Carlo variance for -substantially reduced computation time when \code{n_t} and/or -\code{n_c} are large.} - -\item{error_if_Miss}{A logical scalar; if \code{TRUE} (default), the -function stops with an error if the Miss probability is positive, -prompting reconsideration of the thresholds.} - -\item{Gray_inc_Miss}{A logical scalar; if \code{TRUE}, the Miss -probability is added to Gray. If \code{FALSE} (default), Miss is -reported separately. Active only when -\code{error_if_Miss = FALSE}.} -} -\value{ -A data frame with one row per scenario and columns: -\describe{ -\item{pi_t1}{True treatment response probability for Endpoint 1.} -\item{pi_t2}{True treatment response probability for Endpoint 2.} -\item{rho_t}{True within-arm correlation in the treatment arm.} -\item{pi_c1}{True control response probability for Endpoint 1 -(omitted when \code{design = 'uncontrolled'}).} -\item{pi_c2}{True control response probability for Endpoint 2 -(omitted when \code{design = 'uncontrolled'}).} -\item{rho_c}{True within-arm correlation in the control arm -(omitted when \code{design = 'uncontrolled'}).} -\item{Go}{Probability of making a Go decision.} -\item{Gray}{Probability of making a Gray (inconclusive) decision.} -\item{NoGo}{Probability of making a NoGo decision.} -\item{Miss}{Probability where Go and NoGo criteria are simultaneously -met. Included when \code{error_if_Miss = FALSE} and -\code{Gray_inc_Miss = FALSE}.} -} -The returned object has S3 class \code{pbayesdecisionprob2bin} with -an associated \code{print} method. -} -\description{ -Evaluates operating characteristics (Go, NoGo, Gray probabilities) for -clinical trials with two binary endpoints under the Bayesian framework. -The function supports controlled, uncontrolled, and external designs, -and uses both posterior probability and posterior predictive probability -criteria. -} -\details{ -Computation proceeds in two stages for efficiency. In Stage 1, posterior -or predictive probabilities are precomputed for every possible multinomial -count combination \eqn{(x_t, x_c)}. In Stage 2, operating characteristics -for each scenario are obtained by weighting the Stage 1 decisions by their -multinomial probabilities under the true parameters, avoiding repeated Monte -Carlo sampling per scenario. - -\strong{Two-stage computation.} - -Stage 1 (precomputation): All possible multinomial count combinations -\eqn{x_t} are enumerated using \code{\link{allmultinom}}. -For \code{design = 'controlled'} or \code{'external'}, all combinations -\eqn{x_c} are also enumerated and the Go/NoGo probability matrix -\code{PrGo[i, j]} has dimensions \eqn{n_t \times n_c}. -For \code{design = 'uncontrolled'}, the control distribution is fixed as -\eqn{\mathrm{Dir}(\alpha_{2,**} + z_{**})} and does not depend on any -observed control counts; the probability matrix therefore has dimensions -\eqn{n_t \times 1}, eliminating the \eqn{\binom{n_2+3}{3}}-row control -enumeration and the associated Gamma sampling. -This stage is independent of the true scenario parameters. - -Stage 2 (scenario evaluation): For each scenario -\eqn{(\pi_{t1}, \pi_{t2}, \rho_t, \pi_{c1}, \pi_{c2}, \rho_c)}, -\code{\link{getjointbin}} converts the marginal rates and correlation -into the four-cell probability vector \eqn{p_k}. The multinomial -probability mass function weights the Stage 1 decisions: -\deqn{\Pr(\mathrm{Go} \mid \Theta) = \sum_{i,j} - \mathbf{1}(\mathrm{Go}_{ij}) \cdot - P(x_{t,i} \mid n_1, p_t) \cdot P(x_{c,j} \mid n_2, p_c),} -where \eqn{\mathbf{1}(\mathrm{Go}_{ij})} is the Go indicator from Stage 1. -Stage 2 requires no additional Monte Carlo and is fast even for large -scenario grids. - -\strong{Decision categories.} -\itemize{ -\item \strong{Go}: sum of Go region probabilities \eqn{\ge \gamma_1} -AND sum of NoGo region probabilities \eqn{< \gamma_2}. -\item \strong{NoGo}: sum of Go region probabilities \eqn{< \gamma_1} -AND sum of NoGo region probabilities \eqn{\ge \gamma_2}. -\item \strong{Miss}: both Go and NoGo criteria satisfied simultaneously. -\item \strong{Gray}: neither Go nor NoGo criterion satisfied. -} -} -\examples{ - -# Example 1: Posterior probability, controlled design (rho > 0) -# Explores the impact of positive within-arm endpoint correlation. -pbayesdecisionprob2bin( - prob = 'posterior', - design = 'controlled', - GoRegions = 1L, - NoGoRegions = 9L, - gamma_go = 0.52, - gamma_nogo = 0.52, - pi_t1 = c(0.15, 0.25, 0.30, 0.40), - pi_t2 = c(0.20, 0.30, 0.35, 0.45), - rho_t = rep(0.6, 4), - pi_c1 = rep(0.15, 4), - pi_c2 = rep(0.20, 4), - rho_c = rep(0.6, 4), - n_t = 10, n_c = 10, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -# Example 2: Posterior probability, uncontrolled design -# Hypothetical control specified via pseudo-counts. -pbayesdecisionprob2bin( - prob = 'posterior', - design = 'uncontrolled', - GoRegions = 1L, - NoGoRegions = 9L, - gamma_go = 0.27, - gamma_nogo = 0.36, - pi_t1 = c(0.15, 0.30, 0.40), - pi_t2 = c(0.20, 0.35, 0.45), - rho_t = rep(0.2, 3), - pi_c1 = NULL, - pi_c2 = NULL, - rho_c = NULL, - n_t = 10, n_c = NULL, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -# Example 3: Posterior probability, external control design -# External control data incorporated via power prior (alpha0e_c = 0.5). -pbayesdecisionprob2bin( - prob = 'posterior', - design = 'external', - GoRegions = 1L, - NoGoRegions = 9L, - gamma_go = 0.27, - gamma_nogo = 0.36, - pi_t1 = c(0.15, 0.25, 0.30, 0.40), - pi_t2 = c(0.20, 0.30, 0.35, 0.45), - rho_t = rep(0.0, 4), - pi_c1 = rep(0.15, 4), - pi_c2 = rep(0.20, 4), - rho_c = rep(0.0, 4), - n_t = 10, n_c = 10, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.15, theta_MAV1 = 0.10, - theta_TV2 = 0.15, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = 4L, xe_c_01 = 2L, xe_c_10 = 3L, xe_c_11 = 1L, - alpha0e_t = NULL, alpha0e_c = 0.5, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -# Example 4: Predictive probability, controlled design -# Future trial has m_t = m_c = 30 patients per arm. -pbayesdecisionprob2bin( - prob = 'predictive', - design = 'controlled', - GoRegions = 1L, - NoGoRegions = 4L, - gamma_go = 0.60, - gamma_nogo = 0.80, - pi_t1 = c(0.15, 0.25, 0.30, 0.40), - pi_t2 = c(0.20, 0.30, 0.35, 0.45), - rho_t = rep(0.3, 4), - pi_c1 = rep(0.15, 4), - pi_c2 = rep(0.20, 4), - rho_c = rep(0.3, 4), - n_t = 10, n_c = 10, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 30L, m_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -# Example 5: Predictive probability, uncontrolled design -# Hypothetical control specified via pseudo-counts; future trial m_t = m_c = 30. -pbayesdecisionprob2bin( - prob = 'predictive', - design = 'uncontrolled', - GoRegions = 1L, - NoGoRegions = 4L, - gamma_go = 0.60, - gamma_nogo = 0.80, - pi_t1 = c(0.15, 0.30, 0.40), - pi_t2 = c(0.20, 0.35, 0.45), - rho_t = rep(0.7, 3), - pi_c1 = rep(0.15, 3), - pi_c2 = rep(0.20, 3), - rho_c = rep(0.7, 3), - n_t = 10, n_c = 10, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 30L, m_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -# Example 6: Predictive probability, external treatment design -# External treatment data incorporated via power prior (alpha0e_t = 0.5). -pbayesdecisionprob2bin( - prob = 'predictive', - design = 'external', - GoRegions = 1L, - NoGoRegions = 4L, - gamma_go = 0.60, - gamma_nogo = 0.80, - pi_t1 = c(0.15, 0.25, 0.30, 0.40), - pi_t2 = c(0.20, 0.30, 0.35, 0.45), - rho_t = rep(0.5, 4), - pi_c1 = rep(0.15, 4), - pi_c2 = rep(0.20, 4), - rho_c = rep(0.5, 4), - n_t = 10, n_c = 10, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 30L, m_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = 3L, xe_t_01 = 2L, xe_t_10 = 3L, xe_t_11 = 2L, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = 0.5, alpha0e_c = NULL, - nMC = 100, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE -) - -} diff --git a/man/pbayesdecisionprob2cont.Rd b/man/pbayesdecisionprob2cont.Rd deleted file mode 100644 index b627d68..0000000 --- a/man/pbayesdecisionprob2cont.Rd +++ /dev/null @@ -1,424 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayesdecisionprob2cont.R -\name{pbayesdecisionprob2cont} -\alias{pbayesdecisionprob2cont} -\title{Go/NoGo/Gray Decision Probabilities for Two Continuous Endpoints} -\usage{ -pbayesdecisionprob2cont( - nsim, - prob, - design, - prior, - GoRegions, - NoGoRegions, - gamma_go, - gamma_nogo, - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - n_t, - n_c = NULL, - m_t = NULL, - m_c = NULL, - mu_t, - Sigma_t, - mu_c = NULL, - Sigma_c = NULL, - kappa0_t = NULL, - nu0_t = NULL, - mu0_t = NULL, - Lambda0_t = NULL, - kappa0_c = NULL, - nu0_c = NULL, - mu0_c = NULL, - Lambda0_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - nMC = NULL, - CalcMethod = "MC", - error_if_Miss = TRUE, - Gray_inc_Miss = FALSE, - seed -) -} -\arguments{ -\item{nsim}{A positive integer. Number of simulated datasets per scenario.} - -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{prior}{A character string specifying the prior distribution. -Must be \code{'vague'} or \code{'N-Inv-Wishart'}.} - -\item{GoRegions}{An integer vector specifying which of the nine posterior -regions (R1--R9) or four predictive regions (R1--R4) constitute a -Go decision. For \code{prob = 'posterior'}, valid values are -integers in 1--9; for \code{prob = 'predictive'}, in 1--4. -A common choice is \code{GoRegions = 1} (both endpoints exceed TV -or NULL for posterior/predictive, respectively).} - -\item{NoGoRegions}{An integer vector specifying which regions constitute a -NoGo decision. A common choice is \code{NoGoRegions = 9} (both -endpoints below MAV) for posterior, or \code{NoGoRegions = 4} for -predictive. Must be disjoint from \code{GoRegions}.} - -\item{gamma_go}{A numeric scalar in \code{(0, 1)}. Go threshold: -a Go decision is made if \eqn{P(\mathrm{GoRegions}) \ge \gamma_1}.} - -\item{gamma_nogo}{A numeric scalar in \code{(0, 1)}. NoGo threshold: -a NoGo decision is made if \eqn{P(\mathrm{NoGoRegions}) \ge \gamma_2}. -No ordering constraint on \code{gamma_go} and \code{gamma_nogo} is -imposed; their combination determines the frequency of Miss outcomes.} - -\item{theta_TV1}{A numeric scalar giving the target value (TV) threshold -for Endpoint 1. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV1}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 1. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_TV2}{A numeric scalar giving the target value (TV) threshold -for Endpoint 2. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV2}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 2. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. For \code{design = 'uncontrolled'}, -this is the hypothetical control sample size (required for -consistency with other designs).} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{mu_t}{Numeric matrix with 2 columns. Each row gives the true treatment -mean vector for one scenario. A length-2 vector is coerced to a -1-row matrix.} - -\item{Sigma_t}{A 2x2 positive-definite matrix. True treatment covariance.} - -\item{mu_c}{Numeric matrix with 2 columns or a length-2 vector. True control -(or hypothetical control) mean vector(s).} - -\item{Sigma_c}{A 2x2 positive-definite matrix. True control covariance.} - -\item{kappa0_t}{A positive numeric scalar giving the NIW prior -concentration parameter for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{nu0_t}{A numeric scalar giving the NIW prior degrees of freedom for -the treatment group. Must be greater than 3. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{mu0_t}{A numeric vector of length 2 giving the NIW prior mean for -the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{Lambda0_t}{A 2x2 positive-definite numeric matrix giving the NIW -prior scale matrix for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{kappa0_c}{A positive numeric scalar giving the NIW prior -concentration parameter for the control group. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{nu0_c}{A numeric scalar giving the NIW prior degrees of freedom for -the control group. Must be greater than 3. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{mu0_c}{A numeric vector of length 2 giving the NIW prior mean for -the control group, or the hypothetical control location when -\code{design = 'uncontrolled'}. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{Lambda0_c}{A 2x2 positive-definite numeric matrix giving the NIW -prior scale matrix for the control group. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{r}{A positive numeric scalar giving the variance scaling factor for -the hypothetical control distribution. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{ne_t}{A positive integer giving the external treatment group sample -size. Required when \code{design = 'external'} and external -treatment data are used; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the external control group sample -size. Required when \code{design = 'external'} and external -control data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external treatment data. Required when external -treatment data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external control data. Required when external -control data are used; otherwise set to \code{NULL}.} - -\item{bar_ye_t}{A numeric vector of length 2 giving the external treatment -group sample mean. Required when external treatment data are used; -otherwise set to \code{NULL}.} - -\item{bar_ye_c}{A numeric vector of length 2 giving the external control -group sample mean. Required when external control data are used; -otherwise set to \code{NULL}.} - -\item{se_t}{A 2x2 numeric matrix giving the external treatment group -sum-of-squares matrix. Required when external treatment data are -used; otherwise set to \code{NULL}.} - -\item{se_c}{A 2x2 numeric matrix giving the external control group -sum-of-squares matrix. Required when external control data are -used; otherwise set to \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Monte Carlo draws used -to estimate region probabilities. Default is \code{10000}. Required -when \code{CalcMethod = 'MC'}. May be set to \code{NULL} when -\code{CalcMethod = 'MM'} and \eqn{\nu_k > 4} (the MM method uses -\code{mvtnorm::pmvt} analytically); if \code{CalcMethod = 'MM'} but -\eqn{\nu_k \le 4} causes a fallback to MC, \code{nMC} must be a -positive integer.} - -\item{CalcMethod}{A character string specifying the computation method. -Must be \code{'MC'} (Monte Carlo, default) or \code{'MM'} -(Moment-Matching via \code{mvtnorm::pmvt}). When -\code{CalcMethod = 'MM'} and \eqn{\nu_k \le 4}, a warning is issued -and the function falls back to \code{CalcMethod = 'MC'}.} - -\item{error_if_Miss}{Logical. If \code{TRUE} (default), the function stops -with an error when positive Miss probability is obtained. If -\code{FALSE}, Miss probability is handled according to -\code{Gray_inc_Miss}.} - -\item{Gray_inc_Miss}{Logical. If \code{TRUE}, Miss probability is included -in Gray probability. If \code{FALSE} (default), Miss probability is -reported as a separate column. Active only when -\code{error_if_Miss = FALSE}.} - -\item{seed}{A single numeric value. Seed for reproducible random number -generation.} -} -\value{ -A data frame of class \code{c("pbayesdecisionprob2cont", "data.frame")} -with columns for the scenario parameters and Go, NoGo, Gray -(and optionally Miss) probabilities. All input parameters are -attached as attributes. -} -\description{ -Computes the operating characteristics (Go, NoGo, Gray, and optionally Miss -probabilities) for a two-continuous-endpoint Bayesian Go/NoGo decision -framework by Monte Carlo simulation over treatment scenarios. -} -\details{ -The function follows the same structure as -\code{\link{pbayesdecisionprob1cont}}: -\enumerate{ -\item For each scenario \eqn{s}, \code{nsim} datasets are simulated by -generating treatment (and control) observations from -\eqn{N_2(\mu_k^{(s)}, \Sigma_k)}. To minimise overhead, raw -standardised residuals are generated \emph{once} (scenario- -invariant) and shifted by the scenario mean. -\item All \code{nsim} simulated sufficient statistics -\eqn{(\bar{y}_{1,i}, S_{1,i})} (and \eqn{(\bar{y}_{2,i}, S_{2,i})} -for controlled/external designs) are passed to -\code{\link{pbayespostpred2cont}} in a \emph{single vectorised -call}, returning an \eqn{nsim \times n_{\rm regions}} matrix of -region probabilities. -\item Go/NoGo/Miss probabilities are obtained as the column means of -indicator matrices derived from the region probability matrix. -} -} -\examples{ -# Example 1: Controlled design, posterior probability, vague prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, m_t = NULL, m_c = NULL, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), - Sigma_c = Sigma, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 1L -) - -# Example 2: Uncontrolled design, posterior probability, NIW prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'posterior', design = 'uncontrolled', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = NULL, m_t = NULL, m_c = NULL, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), - Sigma_c = Sigma, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 3L -) - -# Example 3: External design (control only), posterior probability, NIW prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -se_mat <- matrix(c(7.0, 1.2, 1.2, 1.8), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'posterior', design = 'external', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, m_t = NULL, m_c = NULL, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), - Sigma_c = Sigma, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = 15L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(0.2, 0.1), se_t = NULL, se_c = se_mat, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 5L -) - -# Example 4: Controlled design, predictive probability, NIW prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'predictive', design = 'controlled', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 4L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 20L, n_c = 20L, m_t = 60L, m_c = 60L, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), - Sigma_c = Sigma, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 4L -) - -# Example 5: Uncontrolled design, predictive probability, vague prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'predictive', design = 'uncontrolled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 4L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 20L, n_c = NULL, m_t = 60L, m_c = 60L, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = NULL, - Sigma_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 8L -) - -# Example 6: External design (control only), predictive probability, NIW prior -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -se_mat <- matrix(c(7.0, 1.2, 1.2, 1.8), 2, 2) -pbayesdecisionprob2cont( - nsim = 100L, prob = 'predictive', design = 'external', - prior = 'N-Inv-Wishart', - GoRegions = 1L, NoGoRegions = 4L, - gamma_go = 0.8, gamma_nogo = 0.8, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 20L, n_c = 20L, m_t = 60L, m_c = 60L, - mu_t = rbind(c(1.0, 0.5), c(2.5, 1.5), c(4.0, 2.5)), - Sigma_t = Sigma, - mu_c = rbind(c(0.0, 0.0), c(0.0, 0.0), c(0.0, 0.0)), - Sigma_c = Sigma, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = 15L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(0.2, 0.1), se_t = NULL, se_c = se_mat, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 9L -) - -} diff --git a/man/pbayespostpred1bin.Rd b/man/pbayespostpred1bin.Rd deleted file mode 100644 index 935a31e..0000000 --- a/man/pbayespostpred1bin.Rd +++ /dev/null @@ -1,214 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayespostpred1bin.R -\name{pbayespostpred1bin} -\alias{pbayespostpred1bin} -\title{Bayesian Posterior or Posterior Predictive Probability for a Single -Binary Endpoint} -\usage{ -pbayespostpred1bin( - prob = "posterior", - design = "controlled", - theta0, - n_t, - n_c, - y_t, - y_c = NULL, - a_t, - a_c, - b_t, - b_c, - m_t = NULL, - m_c = NULL, - z = NULL, - ne_t = NULL, - ne_c = NULL, - ye_t = NULL, - ye_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - lower.tail = TRUE -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{theta0}{A numeric scalar in \code{(-1, 1)} giving the threshold for the -treatment effect (difference in response rates).} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. For \code{design = 'uncontrolled'}, -this is the hypothetical control sample size (required for -consistency with other designs).} - -\item{y_t}{A non-negative integer or integer vector giving the observed -number of responders in the treatment group (must satisfy -\code{0 <= y_t <= n_t}).} - -\item{y_c}{A non-negative integer or integer vector giving the number of -responders in the control group (must satisfy -\code{0 <= y_c <= n_c}). Set to \code{NULL} for -\code{design = 'uncontrolled'} and use \code{z} instead. When -provided as a vector, must have the same length as \code{y_t}.} - -\item{a_t}{A positive numeric scalar giving the first shape parameter -(alpha) of the prior Beta distribution for the treatment group.} - -\item{a_c}{A positive numeric scalar giving the first shape parameter -(alpha) of the prior Beta distribution for the control group.} - -\item{b_t}{A positive numeric scalar giving the second shape parameter -(beta) of the prior Beta distribution for the treatment group.} - -\item{b_c}{A positive numeric scalar giving the second shape parameter -(beta) of the prior Beta distribution for the control group.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{z}{A non-negative integer giving the hypothetical number of responders -in the control group. Required when \code{design = 'uncontrolled'}; -otherwise set to \code{NULL}. When used, \code{y_c} should be -\code{NULL}.} - -\item{ne_t}{A positive integer giving the number of patients in the -treatment group of the external data set. Required when -\code{design = 'external'} and external treatment data are -available; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the number of patients in the -control group of the external data set. Required when -\code{design = 'external'} and external control data are available; -otherwise set to \code{NULL}.} - -\item{ye_t}{A non-negative integer giving the number of responders in the -treatment group of the external data set. Required when -\code{design = 'external'}; otherwise set to \code{NULL}.} - -\item{ye_c}{A non-negative integer giving the number of responders in the -control group of the external data set. Required when -\code{design = 'external'}; otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external treatment data. Required when external -treatment data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external control data. Required when external -control data are used; otherwise set to \code{NULL}.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(\mathrm{effect} \le \theta_0)}, otherwise -\eqn{P(\mathrm{effect} > \theta_0)}.} -} -\value{ -A numeric scalar or vector in \code{[0, 1]}. When \code{y_t} and -\code{y_c} are vectors of length \eqn{n}, a vector of length -\eqn{n} is returned. -} -\description{ -Computes the Bayesian posterior probability or posterior predictive -probability for binary-outcome clinical trials under a beta-binomial -conjugate model. The function supports controlled, uncontrolled, and -external designs, with optional incorporation of external data through -power priors. Vector inputs for \code{y_t} and \code{y_c} are supported -for efficient batch processing (e.g., across all possible trial outcomes -in \code{\link{pbayesdecisionprob1bin}}). -} -\details{ -Posterior shape parameters are computed from the beta-binomial conjugate -model: -\itemize{ -\item Prior: \eqn{\pi_j \sim \mathrm{Beta}(a_j, b_j)}. -\item Posterior: -\eqn{\pi_j \mid y_j \sim \mathrm{Beta}(a_j + y_j, b_j + n_j - y_j)}. -} - -For \code{design = 'external'}, external data are incorporated through -the power prior, which inflates the prior by the weighted external -sufficient statistics: -\deqn{(\alpha_j^*, \beta_j^*) = (a_j + ae_j \cdot ye_j, b_j + ae_j \cdot - (ne_j - ye_j)).} - -For \code{design = 'uncontrolled'}, the hypothetical control value -\code{z} is used in place of \code{y_c}, and \code{n_c} acts as the -hypothetical control sample size. - -The final probability is obtained by calling \code{\link{pbetadiff}} for -\code{prob = 'posterior'} or \code{\link{pbetabinomdiff}} for -\code{prob = 'predictive'}, applied element-wise via \code{mapply}. -} -\examples{ -# Example 1: Controlled design - posterior probability -pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.15, - n_t = 12, n_c = 15, y_t = 7, y_c = 5, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -) - -# Example 2: Uncontrolled design - posterior probability -pbayespostpred1bin( - prob = 'posterior', design = 'uncontrolled', theta0 = 0.20, - n_t = 20, n_c = 20, y_t = 12, y_c = NULL, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = 3, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -) - -# Example 3: External design - posterior probability -pbayespostpred1bin( - prob = 'posterior', design = 'external', theta0 = 0.15, - n_t = 12, n_c = 15, y_t = 7, y_c = 9, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = 12, ne_c = 12, ye_t = 6, ye_c = 6, alpha0e_t = 0.5, alpha0e_c = 0.5, - lower.tail = FALSE -) - -# Example 4: Controlled design - posterior predictive probability -pbayespostpred1bin( - prob = 'predictive', design = 'controlled', theta0 = 0.10, - n_t = 12, n_c = 15, y_t = 7, y_c = 5, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = 30, m_c = 30, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -) - -# Example 5: Uncontrolled design - posterior predictive probability -pbayespostpred1bin( - prob = 'predictive', design = 'uncontrolled', theta0 = 0.20, - n_t = 20, n_c = 20, y_t = 12, y_c = NULL, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = 30, m_c = 30, z = 3, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, lower.tail = FALSE -) - -# Example 6: External design - posterior predictive probability -pbayespostpred1bin( - prob = 'predictive', design = 'external', theta0 = 0.15, - n_t = 12, n_c = 15, y_t = 7, y_c = 9, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - m_t = 30, m_c = 30, z = NULL, - ne_t = 12, ne_c = 12, ye_t = 6, ye_c = 6, alpha0e_t = 0.5, alpha0e_c = 0.5, - lower.tail = FALSE -) - -} diff --git a/man/pbayespostpred1cont.Rd b/man/pbayespostpred1cont.Rd deleted file mode 100644 index 8ff6059..0000000 --- a/man/pbayespostpred1cont.Rd +++ /dev/null @@ -1,294 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayespostpred1cont.R -\name{pbayespostpred1cont} -\alias{pbayespostpred1cont} -\title{Bayesian Posterior or Posterior Predictive Probability for a Single -Continuous Endpoint} -\usage{ -pbayespostpred1cont( - prob = "posterior", - design = "controlled", - prior = "vague", - CalcMethod = "NI", - theta0, - nMC = NULL, - n_t, - n_c = NULL, - m_t = NULL, - m_c = NULL, - kappa0_t = NULL, - kappa0_c = NULL, - nu0_t = NULL, - nu0_c = NULL, - mu0_t = NULL, - mu0_c = NULL, - sigma0_t = NULL, - sigma0_c = NULL, - bar_y_t, - bar_y_c = NULL, - s_t, - s_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - lower.tail = TRUE -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{prior}{A character string specifying the prior type. -Must be \code{'vague'} (Jeffreys) or \code{'N-Inv-Chisq'} -(Normal-Inverse-Chi-squared conjugate).} - -\item{CalcMethod}{A character string specifying the calculation method. -Must be \code{'NI'} (numerical integration), \code{'MC'} -(Monte Carlo), or \code{'MM'} (Moment-Matching approximation). -For large \code{nsim} or multi-scenario use, \code{'MM'} is -strongly recommended; see Details.} - -\item{theta0}{A numeric scalar giving the threshold for the treatment -effect (difference in means).} - -\item{nMC}{A positive integer giving the number of Monte Carlo draws. -Required when \code{CalcMethod = 'MC'}; otherwise \code{NULL}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. Required for -\code{design = 'controlled'} or \code{'external'}; set to -\code{NULL} for \code{design = 'uncontrolled'}.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{kappa0_t}{A positive numeric scalar giving the prior precision -parameter for the treatment group. Required when -\code{prior = 'N-Inv-Chisq'}; otherwise \code{NULL}.} - -\item{kappa0_c}{A positive numeric scalar giving the prior precision -parameter for the control group. Required when -\code{prior = 'N-Inv-Chisq'} and \code{design = 'controlled'}; -otherwise \code{NULL}.} - -\item{nu0_t}{A positive numeric scalar giving the prior degrees of freedom -for the treatment group. Required when \code{prior = 'N-Inv-Chisq'}; -otherwise \code{NULL}.} - -\item{nu0_c}{A positive numeric scalar giving the prior degrees of freedom -for the control group. Required when \code{prior = 'N-Inv-Chisq'} -and \code{design = 'controlled'}; otherwise \code{NULL}.} - -\item{mu0_t}{A numeric scalar giving the prior mean for the treatment -group. Required when \code{prior = 'N-Inv-Chisq'}; otherwise -\code{NULL}.} - -\item{mu0_c}{A numeric scalar giving the prior mean for the control group -(\code{design = 'controlled'} with \code{prior = 'N-Inv-Chisq'}) -or the hypothetical control mean (\code{design = 'uncontrolled'}). -Required for uncontrolled design; otherwise \code{NULL}.} - -\item{sigma0_t}{A positive numeric scalar giving the prior scale for the -treatment group. Required when \code{prior = 'N-Inv-Chisq'}; -otherwise \code{NULL}.} - -\item{sigma0_c}{A positive numeric scalar giving the prior scale for the -control group. Required when \code{prior = 'N-Inv-Chisq'} and -\code{design = 'controlled'}; otherwise \code{NULL}.} - -\item{bar_y_t}{A numeric scalar or vector giving the sample mean for the -treatment group. When a vector of length \code{nsim} is supplied, -all posterior parameters are computed simultaneously for all -replicates.} - -\item{bar_y_c}{A numeric scalar or vector giving the sample mean for the -control group. Required for \code{design = 'controlled'} or -\code{'external'}; set to \code{NULL} for uncontrolled design.} - -\item{s_t}{A positive numeric scalar or vector giving the sample standard -deviation for the treatment group.} - -\item{s_c}{A positive numeric scalar or vector giving the sample standard -deviation for the control group. Required for -\code{design = 'controlled'} or \code{'external'}; otherwise -\code{NULL}.} - -\item{r}{A positive numeric scalar giving the variance scaling factor for -the hypothetical control. Required for \code{design = 'uncontrolled'}; -otherwise \code{NULL}. The hypothetical control scale is -\eqn{\mathrm{sd.control} = \sqrt{r} \cdot \mathrm{sd.treatment}}.} - -\item{ne_t}{A positive integer giving the number of patients in the -treatment group of the external data set. Required when -\code{design = 'external'} and external treatment data are -available; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the number of patients in the -control group of the external data set. Required when -\code{design = 'external'} and external control data are available; -otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external treatment data. Required when external -treatment data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external control data. Required when external -control data are used; otherwise set to \code{NULL}.} - -\item{bar_ye_t}{A numeric scalar giving the external treatment group -sample mean. Required when \code{ne_t} is provided; otherwise -\code{NULL}.} - -\item{bar_ye_c}{A numeric scalar giving the external control group sample -mean. Required when \code{ne_c} is provided; otherwise \code{NULL}.} - -\item{se_t}{A positive numeric scalar giving the external treatment group -sample SD. Required when \code{ne_t} is provided; otherwise -\code{NULL}.} - -\item{se_c}{A positive numeric scalar giving the external control group -sample SD. Required when \code{ne_c} is provided; otherwise -\code{NULL}.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(\mathrm{effect} \le \theta_0)}, otherwise -\eqn{P(\mathrm{effect} > \theta_0)}.} -} -\value{ -A numeric scalar or vector in \code{[0, 1]}. When the input data -parameters (\code{bar_y_t}, etc.) are vectors of length \eqn{n}, -a vector of length \eqn{n} is returned. -} -\description{ -Computes the Bayesian posterior probability or posterior predictive -probability for continuous-outcome clinical trials under a -Normal-Inverse-Chi-squared (or vague Jeffreys) conjugate model. The -function supports controlled, uncontrolled, and external designs, with -optional incorporation of external data through power priors. Vector -inputs for \code{bar_y_t}, \code{s_t}, \code{bar_y_c}, and \code{s_c} -are supported for efficient batch processing (e.g., across simulation -replicates in \code{\link{pbayesdecisionprob1cont}}). -} -\details{ -Under the Normal-Inverse-Chi-squared (N-Inv-ChiSq) conjugate model, the -marginal posterior/predictive distribution of the group mean follows a -non-standardised t-distribution, parameterised by a location -\eqn{\mu_j}, a scale \eqn{\sigma_j}, and degrees of freedom \eqn{\nu_j} -that depend on the design and probability type. The final probability is -computed by one of three methods: -\itemize{ -\item \code{NI}: exact numerical integration via \code{\link{ptdiff_NI}}. -\item \code{MC}: Monte Carlo simulation via \code{\link{ptdiff_MC}}. -\item \code{MM}: Moment-Matching approximation via -\code{\link{ptdiff_MM}}. -} - -\strong{Performance note}: \code{CalcMethod = 'NI'} calls -\code{integrate()} once per element of the input vector, which is -prohibitively slow for large vectors (e.g., \code{nsim x n_scenarios}). -\code{CalcMethod = 'MC'} creates an \code{nMC x n} matrix internally, -consuming \eqn{O(nMC \cdot n)} memory. For large-scale simulation use -\code{CalcMethod = 'MM'}, which is fully vectorised and exact in the -normal limit. -} -\examples{ -# Example 1: Controlled design - posterior probability with N-Inv-Chisq -pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'N-Inv-Chisq', - CalcMethod = 'NI', theta0 = 2, n_t = 12, n_c = 12, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), - bar_y_t = 2, bar_y_c = 0, s_t = 1, s_c = 1, - m_t = NULL, m_c = NULL, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - lower.tail = FALSE -) - -# Example 2: Uncontrolled design - posterior probability with vague prior -pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.5, n_t = 15, n_c = NULL, - bar_y_t = 3.5, bar_y_c = NULL, s_t = 1.2, s_c = NULL, - mu0_c = 1.5, r = 1.2, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, sigma0_t = NULL, sigma0_c = NULL, - m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - lower.tail = FALSE -) - -# Example 3: External design - posterior probability -pbayespostpred1cont( - prob = 'posterior', design = 'external', prior = 'N-Inv-Chisq', - CalcMethod = 'MM', theta0 = 2, n_t = 12, n_c = 12, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), - bar_y_t = 2.5, bar_y_c = 1, s_t = 1.1, s_c = 0.9, - m_t = NULL, m_c = NULL, r = NULL, - ne_t = 10, ne_c = 10, alpha0e_t = 0.5, alpha0e_c = 0.5, - bar_ye_t = 2, bar_ye_c = 0.5, se_t = 1, se_c = 0.8, - lower.tail = FALSE -) - -# Example 4: Controlled design - posterior predictive probability -pbayespostpred1cont( - prob = 'predictive', design = 'controlled', prior = 'N-Inv-Chisq', - CalcMethod = 'MM', theta0 = 1, n_t = 12, n_c = 12, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), - bar_y_t = 2, bar_y_c = 0, s_t = 1, s_c = 1, - m_t = 20, m_c = 20, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - lower.tail = FALSE -) - -# Example 5: Uncontrolled design - posterior predictive probability -pbayespostpred1cont( - prob = 'predictive', design = 'uncontrolled', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.5, n_t = 15, n_c = NULL, - bar_y_t = 3.5, bar_y_c = NULL, s_t = 1.2, s_c = NULL, - mu0_c = 1.5, r = 1.2, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, sigma0_t = NULL, sigma0_c = NULL, - m_t = 20, m_c = 20, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - lower.tail = FALSE -) - -# Example 6: External design - posterior predictive probability -pbayespostpred1cont( - prob = 'predictive', design = 'external', prior = 'N-Inv-Chisq', - CalcMethod = 'MM', theta0 = 1, n_t = 12, n_c = 12, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 5, mu0_c = 5, sigma0_t = sqrt(5), sigma0_c = sqrt(5), - bar_y_t = 2.5, bar_y_c = 1, s_t = 1.1, s_c = 0.9, - m_t = 20, m_c = 20, r = NULL, - ne_t = 10, ne_c = 10, alpha0e_t = 0.5, alpha0e_c = 0.5, - bar_ye_t = 2, bar_ye_c = 0.5, se_t = 1, se_c = 0.8, - lower.tail = FALSE -) - -} diff --git a/man/pbayespostpred2bin.Rd b/man/pbayespostpred2bin.Rd deleted file mode 100644 index d44cd7d..0000000 --- a/man/pbayespostpred2bin.Rd +++ /dev/null @@ -1,366 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayespostpred2bin.R -\name{pbayespostpred2bin} -\alias{pbayespostpred2bin} -\title{Bayesian Posterior or Posterior Predictive Probability for Two Binary -Endpoints} -\usage{ -pbayespostpred2bin( - prob = "posterior", - design = "controlled", - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - x_t_00, - x_t_01, - x_t_10, - x_t_11, - x_c_00 = NULL, - x_c_01 = NULL, - x_c_10 = NULL, - x_c_11 = NULL, - a_t_00, - a_t_01, - a_t_10, - a_t_11, - a_c_00, - a_c_01, - a_c_10, - a_c_11, - m_t = NULL, - m_c = NULL, - z00 = NULL, - z01 = NULL, - z10 = NULL, - z11 = NULL, - xe_t_00 = NULL, - xe_t_01 = NULL, - xe_t_10 = NULL, - xe_t_11 = NULL, - xe_c_00 = NULL, - xe_c_01 = NULL, - xe_c_10 = NULL, - xe_c_11 = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - nMC = 10000L -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{theta_TV1}{A numeric scalar giving the target value (TV) threshold -for Endpoint 1. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV1}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 1. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_TV2}{A numeric scalar giving the target value (TV) threshold -for Endpoint 2. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV2}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 2. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{x_t_00}{A non-negative integer giving the count of -\code{(0, 0)} responses in the treatment group (Endpoint 1 = 0, -Endpoint 2 = 0).} - -\item{x_t_01}{A non-negative integer giving the count of \code{(0, 1)} -responses in the treatment group.} - -\item{x_t_10}{A non-negative integer giving the count of \code{(1, 0)} -responses in the treatment group.} - -\item{x_t_11}{A non-negative integer giving the count of \code{(1, 1)} -responses in the treatment group.} - -\item{x_c_00}{A non-negative integer giving the count of \code{(0, 0)} -responses in the control group. Not used when -\code{design = 'uncontrolled'}; set to \code{NULL} in that case.} - -\item{x_c_01}{A non-negative integer giving the count of \code{(0, 1)} -responses in the control group. Not used when -\code{design = 'uncontrolled'}; set to \code{NULL} in that case.} - -\item{x_c_10}{A non-negative integer giving the count of \code{(1, 0)} -responses in the control group. Not used when -\code{design = 'uncontrolled'}; set to \code{NULL} in that case.} - -\item{x_c_11}{A non-negative integer giving the count of \code{(1, 1)} -responses in the control group. Not used when -\code{design = 'uncontrolled'}; set to \code{NULL} in that case.} - -\item{a_t_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 0)} response pattern in the treatment -group.} - -\item{a_t_01}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 1)} response pattern in the treatment -group.} - -\item{a_t_10}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 0)} response pattern in the treatment -group.} - -\item{a_t_11}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 1)} response pattern in the treatment -group.} - -\item{a_c_00}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 0)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_01}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(0, 1)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_10}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 0)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{a_c_11}{A positive numeric scalar giving the Dirichlet prior -parameter for the \code{(1, 1)} response pattern in the control -group. For \code{design = 'uncontrolled'}, serves as a -hyperparameter of the hypothetical control distribution.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{z00}{A non-negative integer giving the hypothetical control count -for pattern \code{(0, 0)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z01}{A non-negative integer giving the hypothetical control count -for pattern \code{(0, 1)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z10}{A non-negative integer giving the hypothetical control count -for pattern \code{(1, 0)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{z11}{A non-negative integer giving the hypothetical control count -for pattern \code{(1, 1)}. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{xe_t_00}{A non-negative integer giving the external treatment group -count for pattern \code{(0, 0)}. Required when -\code{design = 'external'} and external treatment data are used; -otherwise \code{NULL}.} - -\item{xe_t_01}{A non-negative integer giving the external treatment group -count for pattern \code{(0, 1)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_t_10}{A non-negative integer giving the external treatment group -count for pattern \code{(1, 0)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_t_11}{A non-negative integer giving the external treatment group -count for pattern \code{(1, 1)}. Required for external treatment -data; otherwise \code{NULL}.} - -\item{xe_c_00}{A non-negative integer giving the external control group -count for pattern \code{(0, 0)}. Required when -\code{design = 'external'} and external control data are used; -otherwise \code{NULL}.} - -\item{xe_c_01}{A non-negative integer giving the external control group -count for pattern \code{(0, 1)}. Required for external control -data; otherwise \code{NULL}.} - -\item{xe_c_10}{A non-negative integer giving the external control group -count for pattern \code{(1, 0)}. Required for external control -data; otherwise \code{NULL}.} - -\item{xe_c_11}{A non-negative integer giving the external control group -count for pattern \code{(1, 1)}. Required for external control -data; otherwise \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external treatment data. Required when external -treatment data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external control data. Required when external -control data are used; otherwise set to \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Monte Carlo draws used -to estimate region probabilities. Default is \code{10000}. Larger -values reduce Monte Carlo error at the cost of computation time.} -} -\value{ -A named numeric vector of region probabilities. For -\code{prob = 'posterior'}: length 9, named \code{R1}, ..., -\code{R9}, corresponding to regions defined by TV and MAV -thresholds for both endpoints (row-major order: Endpoint 1 varies -slowest). For \code{prob = 'predictive'}: length 4, named -\code{R1}, ..., \code{R4}. All elements are non-negative and sum -to 1. -} -\description{ -Computes the Bayesian posterior probability or posterior predictive -probability for clinical trials with two binary endpoints under a -Dirichlet-multinomial conjugate model. The function returns probabilities -for nine decision regions (posterior) or four decision regions (predictive) -defined by target values (TV) and minimum acceptable values (MAV) for both -endpoints. Three study designs are supported: controlled, uncontrolled -(hypothetical control), and external (power prior). -} -\details{ -\strong{Model.} The four response categories are ordered as -\code{(0, 0)}, \code{(0, 1)}, \code{(1, 0)}, \code{(1, 1)}. For each -group \eqn{j}, the observed count vector follows a multinomial -distribution, and a conjugate Dirichlet prior is placed on the cell -probability vector \eqn{p_j}: -\deqn{p_j \sim \mathrm{Dir}(\alpha_{j,00}, \alpha_{j,01}, \alpha_{j,10}, - \alpha_{j,11}).} -The posterior is -\deqn{p_j \mid x_j \sim \mathrm{Dir}(\alpha_{j,00} + x_{j,00}, - \alpha_{j,01} + x_{j,01}, \alpha_{j,10} + x_{j,10}, - \alpha_{j,11} + x_{j,11}).} - -Marginal response rates are \eqn{\pi_{j1} = p_{j,10} + p_{j,11}} -(Endpoint 1) and \eqn{\pi_{j2} = p_{j,01} + p_{j,11}} (Endpoint 2). -Treatment effects are \eqn{\theta_1 = \pi_{t1} - \pi_{c1}} and -\eqn{\theta_2 = \pi_{t2} - \pi_{c2}}. - -\strong{Uncontrolled design.} When \code{design = 'uncontrolled'}, the -hypothetical control distribution is specified as a Dirichlet -distribution directly via the prior hyperparameters and hypothetical -control counts \code{z00}, \code{z01}, \code{z10}, \code{z11}. - -\strong{External design.} When \code{design = 'external'}, the power -prior augments the Dirichlet prior parameters. -} -\examples{ -# Example 1: Controlled design - posterior probability -pbayespostpred2bin( - prob = 'posterior', design = 'controlled', - theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 2: Uncontrolled design - posterior probability -pbayespostpred2bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = NULL, m_c = NULL, - z00 = 1, z01 = 2, z10 = 2, z11 = 1, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 3: External design - posterior probability -pbayespostpred2bin( - prob = 'posterior', design = 'external', - theta_TV1 = 0.15, theta_MAV1 = 0.05, theta_TV2 = 0.10, theta_MAV2 = 0.0, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = 2, xe_t_01 = 2, xe_t_10 = 3, xe_t_11 = 1, - xe_c_00 = 2, xe_c_01 = 1, xe_c_10 = 2, xe_c_11 = 1, - alpha0e_t = 0.5, alpha0e_c = 0.5 -) - -# Example 4: Controlled design - posterior predictive probability -pbayespostpred2bin( - prob = 'predictive', design = 'controlled', - theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.05, theta_NULL2 = 0.0, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = 20, m_c = 20, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 5: Uncontrolled design - posterior predictive probability -pbayespostpred2bin( - prob = 'predictive', design = 'uncontrolled', - theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.05, theta_NULL2 = 0.0, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = 20, m_c = 20, - z00 = 1, z01 = 2, z10 = 2, z11 = 1, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) - -# Example 6: External design - posterior predictive probability -pbayespostpred2bin( - prob = 'predictive', design = 'external', - theta_TV1 = NULL, theta_MAV1 = NULL, theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.05, theta_NULL2 = 0.0, - x_t_00 = 2, x_t_01 = 3, x_t_10 = 5, x_t_11 = 2, - x_c_00 = 3, x_c_01 = 2, x_c_10 = 4, x_c_11 = 1, - a_t_00 = 1, a_t_01 = 1, a_t_10 = 1, a_t_11 = 1, - a_c_00 = 1, a_c_01 = 1, a_c_10 = 1, a_c_11 = 1, - m_t = 20, m_c = 20, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = 2, xe_t_01 = 2, xe_t_10 = 3, xe_t_11 = 1, - xe_c_00 = 2, xe_c_01 = 1, xe_c_10 = 2, xe_c_11 = 1, - alpha0e_t = 0.5, alpha0e_c = 0.5 -) - -} diff --git a/man/pbayespostpred2cont.Rd b/man/pbayespostpred2cont.Rd deleted file mode 100644 index be48082..0000000 --- a/man/pbayespostpred2cont.Rd +++ /dev/null @@ -1,434 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayespostpred2cont.R -\name{pbayespostpred2cont} -\alias{pbayespostpred2cont} -\title{Region Probabilities for Two Continuous Endpoints} -\usage{ -pbayespostpred2cont( - prob, - design, - prior, - theta_TV1 = NULL, - theta_MAV1 = NULL, - theta_TV2 = NULL, - theta_MAV2 = NULL, - theta_NULL1 = NULL, - theta_NULL2 = NULL, - n_t, - n_c = NULL, - ybar_t, - S_t, - ybar_c = NULL, - S_c = NULL, - m_t = NULL, - m_c = NULL, - kappa0_t = NULL, - nu0_t = NULL, - mu0_t = NULL, - Lambda0_t = NULL, - kappa0_c = NULL, - nu0_c = NULL, - mu0_c = NULL, - Lambda0_c = NULL, - r = NULL, - ne_t = NULL, - ne_c = NULL, - alpha0e_t = NULL, - alpha0e_c = NULL, - bar_ye_t = NULL, - bar_ye_c = NULL, - se_t = NULL, - se_c = NULL, - nMC = 10000L, - CalcMethod = "MC" -) -} -\arguments{ -\item{prob}{A character string specifying the probability type. -Must be \code{'posterior'} or \code{'predictive'}.} - -\item{design}{A character string specifying the trial design. -Must be \code{'controlled'}, \code{'uncontrolled'}, or -\code{'external'}.} - -\item{prior}{A character string specifying the prior distribution. -Must be \code{'vague'} or \code{'N-Inv-Wishart'}.} - -\item{theta_TV1}{A numeric scalar giving the target value (TV) threshold -for Endpoint 1. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV1}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 1. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV1 > theta_MAV1}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_TV2}{A numeric scalar giving the target value (TV) threshold -for Endpoint 2. Required when \code{prob = 'posterior'}; must -satisfy \code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_MAV2}{A numeric scalar giving the minimum acceptable value -(MAV) threshold for Endpoint 2. Required when -\code{prob = 'posterior'}; must satisfy -\code{theta_TV2 > theta_MAV2}. Set to \code{NULL} when -\code{prob = 'predictive'}.} - -\item{theta_NULL1}{A numeric scalar giving the null hypothesis threshold -for Endpoint 1. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{theta_NULL2}{A numeric scalar giving the null hypothesis threshold -for Endpoint 2. Required when \code{prob = 'predictive'}; set to -\code{NULL} when \code{prob = 'posterior'}.} - -\item{n_t}{A positive integer giving the number of patients in the -treatment group in the proof-of-concept (PoC) trial.} - -\item{n_c}{A positive integer giving the number of patients in the -control group in the PoC trial. For \code{design = 'uncontrolled'}, -this is the hypothetical control sample size (required for -consistency with other designs).} - -\item{ybar_t}{A numeric vector of length 2 \strong{or} a numeric matrix -with 2 columns giving the sample mean(s) for the treatment group. -When a matrix with \eqn{N} rows is supplied, the function computes -probabilities for all \eqn{N} observations simultaneously and -returns an \eqn{N \times n_{\rm regions}} matrix.} - -\item{S_t}{A 2x2 numeric matrix giving the sum-of-squares matrix for the -treatment group (single observation), \strong{or} a list of \eqn{N} -such matrices (vectorised call). Must be consistent with -\code{ybar_t}: if \code{ybar_t} is a matrix, \code{S_t} must be a -list of the same length.} - -\item{ybar_c}{A numeric vector of length 2, a numeric matrix with 2 -columns, or \code{NULL} giving the sample mean(s) for the control -group. Not used when \code{design = 'uncontrolled'}.} - -\item{S_c}{A 2x2 numeric matrix, a list of 2x2 matrices, or \code{NULL} -giving the sum-of-squares matrix/matrices for the control group. -Not used when \code{design = 'uncontrolled'}.} - -\item{m_t}{A positive integer giving the number of patients in the -treatment group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{m_c}{A positive integer giving the number of patients in the -control group for the future trial. Required when -\code{prob = 'predictive'}; otherwise set to \code{NULL}.} - -\item{kappa0_t}{A positive numeric scalar giving the NIW prior -concentration parameter for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{nu0_t}{A numeric scalar giving the NIW prior degrees of freedom for -the treatment group. Must be greater than 3. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{mu0_t}{A numeric vector of length 2 giving the NIW prior mean for -the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{Lambda0_t}{A 2x2 positive-definite numeric matrix giving the NIW -prior scale matrix for the treatment group. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{kappa0_c}{A positive numeric scalar giving the NIW prior -concentration parameter for the control group. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{nu0_c}{A numeric scalar giving the NIW prior degrees of freedom for -the control group. Must be greater than 3. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{mu0_c}{A numeric vector of length 2 giving the NIW prior mean for -the control group, or the hypothetical control location when -\code{design = 'uncontrolled'}. Required when -\code{prior = 'N-Inv-Wishart'}; otherwise set to \code{NULL}.} - -\item{Lambda0_c}{A 2x2 positive-definite numeric matrix giving the NIW -prior scale matrix for the control group. Required when -\code{prior = 'N-Inv-Wishart'} and -\code{design != 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{r}{A positive numeric scalar giving the variance scaling factor for -the hypothetical control distribution. Required when -\code{design = 'uncontrolled'}; otherwise set to \code{NULL}.} - -\item{ne_t}{A positive integer giving the external treatment group sample -size. Required when \code{design = 'external'} and external -treatment data are used; otherwise set to \code{NULL}.} - -\item{ne_c}{A positive integer giving the external control group sample -size. Required when \code{design = 'external'} and external -control data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_t}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external treatment data. Required when external -treatment data are used; otherwise set to \code{NULL}.} - -\item{alpha0e_c}{A numeric scalar in \code{(0, 1]} giving the power prior -weight for the external control data. Required when external -control data are used; otherwise set to \code{NULL}.} - -\item{bar_ye_t}{A numeric vector of length 2 giving the external treatment -group sample mean. Required when external treatment data are used; -otherwise set to \code{NULL}.} - -\item{bar_ye_c}{A numeric vector of length 2 giving the external control -group sample mean. Required when external control data are used; -otherwise set to \code{NULL}.} - -\item{se_t}{A 2x2 numeric matrix giving the external treatment group -sum-of-squares matrix. Required when external treatment data are -used; otherwise set to \code{NULL}.} - -\item{se_c}{A 2x2 numeric matrix giving the external control group -sum-of-squares matrix. Required when external control data are -used; otherwise set to \code{NULL}.} - -\item{nMC}{A positive integer giving the number of Monte Carlo draws used -to estimate region probabilities. Default is \code{10000}. Required -when \code{CalcMethod = 'MC'}. May be set to \code{NULL} when -\code{CalcMethod = 'MM'} and \eqn{\nu_k > 4} (the MM method uses -\code{mvtnorm::pmvt} analytically); if \code{CalcMethod = 'MM'} but -\eqn{\nu_k \le 4} causes a fallback to MC, \code{nMC} must be a -positive integer.} - -\item{CalcMethod}{A character string specifying the computation method. -Must be \code{'MC'} (Monte Carlo, default) or \code{'MM'} -(Moment-Matching via \code{mvtnorm::pmvt}). When -\code{CalcMethod = 'MM'} and \eqn{\nu_k \le 4}, a warning is issued -and the function falls back to \code{CalcMethod = 'MC'}.} -} -\value{ -When \code{ybar_t} is a length-2 vector (single observation): a -named numeric vector of length 9 (\code{R1}--\code{R9}) for -\code{prob = 'posterior'} or length 4 (\code{R1}--\code{R4}) for -\code{prob = 'predictive'}. All elements are non-negative and sum -to 1. - -\if{html}{\out{
}}\preformatted{ When \code{ybar_t} is an \eqn{N \times 2} matrix (vectorised call): - a numeric matrix with \eqn{N} rows and 9 (or 4) columns, with - column names \code{R1}--\code{R9} (or \code{R1}--\code{R4}). Each - row sums to 1. -}\if{html}{\out{
}} -} -\description{ -Computes the posterior or posterior predictive probability that the -bivariate treatment effect \eqn{\theta = \mu_t - \mu_c} falls in each of -the 9 (posterior) or 4 (predictive) rectangular regions defined by the -decision thresholds. -} -\details{ -\strong{Model.} -Both endpoints follow a bivariate Normal distribution -\eqn{y_{k,j} \sim N_2(\mu_k, \Sigma_k)} for group \eqn{k \in \{t, c\}}. -The treatment effect is \eqn{\theta = \mu_t - \mu_c}. - -\strong{Posterior distribution (vague prior).} -\deqn{\mu_k | Y_k \sim t_{n_k - 2}\!\left(\bar{y}_k,\; - \frac{S_k}{n_k(n_k - 2)}\right)} - -\strong{Posterior distribution (NIW prior).} -\deqn{\mu_k | Y_k \sim t_{\nu_{nk} - 1}\!\left(\mu_{nk},\; - \frac{\Lambda_{nk}}{\kappa_{nk}(\nu_{nk} - 1)}\right)} -with updated hyperparameters -\eqn{\kappa_{nk} = \kappa_{0k} + n_k}, -\eqn{\nu_{nk} = \nu_{0k} + n_k}, -\eqn{\mu_{nk} = (\kappa_{0k}\mu_{0k} + n_k\bar{y}_k)/\kappa_{nk}}, and -\eqn{\Lambda_{nk} = \Lambda_{0k} + S_k + -\kappa_{0k}n_k(\bar{y}_k - \mu_{0k})(\bar{y}_k - \mu_{0k})^T / \kappa_{nk}}. - -\strong{Predictive distribution.} -The scale matrix of a single future observation is inflated by -\eqn{(1 + n_k)/n_k} (vague) or \eqn{(1 + \kappa_{nk})/\kappa_{nk}} (NIW) -relative to the posterior. The mean of \eqn{m_k} future observations has -scale divided by \eqn{m_k}. - -\strong{Posterior probability regions (prob = 'posterior').} -Row-major 3x3 grid; Endpoint 1 varies slowest: -\itemize{ -\item R1: \eqn{\theta_1 > TV_1} AND \eqn{\theta_2 > TV_2} -\item R2: \eqn{\theta_1 > TV_1} AND \eqn{TV_2 \ge \theta_2 > MAV_2} -\item R3: \eqn{\theta_1 > TV_1} AND \eqn{\theta_2 \le MAV_2} -\item R4: \eqn{TV_1 \ge \theta_1 > MAV_1} AND \eqn{\theta_2 > TV_2} -\item R5: \eqn{TV_1 \ge \theta_1 > MAV_1} AND -\eqn{TV_2 \ge \theta_2 > MAV_2} -\item R6: \eqn{TV_1 \ge \theta_1 > MAV_1} AND \eqn{\theta_2 \le MAV_2} -\item R7: \eqn{\theta_1 \le MAV_1} AND \eqn{\theta_2 > TV_2} -\item R8: \eqn{\theta_1 \le MAV_1} AND -\eqn{TV_2 \ge \theta_2 > MAV_2} -\item R9: \eqn{\theta_1 \le MAV_1} AND \eqn{\theta_2 \le MAV_2} -} - -\strong{Predictive probability regions (prob = 'predictive').} -Row-major 2x2 grid; Endpoint 1 varies slowest: -\itemize{ -\item R1: \eqn{\tilde\theta_1 > \theta_{\rm NULL1}} AND -\eqn{\tilde\theta_2 > \theta_{\rm NULL2}} -\item R2: \eqn{\tilde\theta_1 > \theta_{\rm NULL1}} AND -\eqn{\tilde\theta_2 \le \theta_{\rm NULL2}} -\item R3: \eqn{\tilde\theta_1 \le \theta_{\rm NULL1}} AND -\eqn{\tilde\theta_2 > \theta_{\rm NULL2}} -\item R4: \eqn{\tilde\theta_1 \le \theta_{\rm NULL1}} AND -\eqn{\tilde\theta_2 \le \theta_{\rm NULL2}} -} - -\strong{Uncontrolled design.} -Under NIW prior: -\eqn{\mu_c \sim t_{\nu_{nt} - 1}(\mu_{0c},\; -r\Lambda_{nt} / [\kappa_{nt}(\nu_{nt} - 1)])}. -The parameter \code{r} allows the variance scale of the hypothetical -control to differ from the treatment group. - -\strong{External design.} -Incorporated via the power prior with NIW conjugate representation. -The effective posterior hyperparameters are obtained by constructing the -power prior from external data with weight \eqn{a_0}, then updating with -current PoC data (see Conjugate_power_prior.pdf, Theorem 5). - -\strong{Vectorised usage.} -When \code{ybar_t} is supplied as an \eqn{N \times 2} matrix and -\code{S_t} as a list of \eqn{N} scatter matrices, the function computes -region probabilities for all \eqn{N} observations in a single call, -returning an \eqn{N \times n_{\rm regions}} matrix. For -\code{CalcMethod = 'MC'}, standard normal and chi-squared variates are -pre-generated once (size \code{nMC}) and reused across all observations, -with only the Cholesky factor of the replicate-specific scale matrix -recomputed per observation. For \code{CalcMethod = 'MM'}, the -moment-matching parameters are computed per observation (since they depend -on the replicate-specific \eqn{V_k}) and \code{mvtnorm::pmvt} is called -once per region per observation. -} -\examples{ -# Example 1: Controlled design - posterior probability, vague prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 12L, n_c = 12L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 1000L -) - -# Example 2: Uncontrolled design - posterior probability, NIW prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -pbayespostpred2cont( - prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Wishart', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 12L, n_c = NULL, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = NULL, S_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.5), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 1000L -) - -# Example 3: External design - posterior probability, NIW prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -se_c <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) -pbayespostpred2cont( - prob = 'posterior', design = 'external', prior = 'N-Inv-Wishart', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 12L, n_c = 12L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(1.0, 0.5), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = se_c, - nMC = 1000L -) - -# Example 4: Controlled design - posterior predictive probability, vague prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -pbayespostpred2cont( - prob = 'predictive', design = 'controlled', prior = 'vague', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 12L, n_c = 12L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = 30L, m_c = 30L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 1000L -) - -# Example 5: Uncontrolled design - posterior predictive probability, NIW prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -pbayespostpred2cont( - prob = 'predictive', design = 'uncontrolled', prior = 'N-Inv-Wishart', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 12L, n_c = NULL, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = NULL, S_c = NULL, - m_t = 30L, m_c = 30L, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.5), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 1000L -) - -# Example 6: External design - posterior predictive probability, NIW prior -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -L0 <- matrix(c(20.0, 0.0, 0.0, 10.0), 2, 2) -se_c <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) -pbayespostpred2cont( - prob = 'predictive', design = 'external', prior = 'N-Inv-Wishart', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 12L, n_c = 12L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = 30L, m_c = 30L, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(1.0, 0.5), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = se_c, - nMC = 1000L -) - -} diff --git a/man/pbetabinomdiff.Rd b/man/pbetabinomdiff.Rd index 84f4f73..047ecb5 100644 --- a/man/pbetabinomdiff.Rd +++ b/man/pbetabinomdiff.Rd @@ -2,86 +2,58 @@ % Please edit documentation in R/pbetabinomdiff.R \name{pbetabinomdiff} \alias{pbetabinomdiff} -\title{Cumulative Distribution Function of the Difference Between Two -Independent Beta-Binomial Proportions} +\title{Distribution function of the difference of two Beta-binomial proportions} \usage{ -pbetabinomdiff( - q, - m_t, - m_c, - alpha_t, - alpha_c, - beta_t, - beta_c, - lower.tail = TRUE -) +pbetabinomdiff(q, m_t, a_t, b_t, m_c, a_c, b_c, lower.tail = TRUE) } \arguments{ -\item{q}{A numeric scalar representing the quantile threshold for the -difference in proportions.} +\item{q}{Numeric vector of quantiles.} -\item{m_t}{A positive integer giving the number of future patients in the -treatment group.} +\item{m_t, m_c}{Numbers of future subjects in the treatment and control +groups (whole numbers of at least 1).} -\item{m_c}{A positive integer giving the number of future patients in the -control group.} +\item{a_t, b_t}{Positive shape parameters of the treatment group.} -\item{alpha_t}{A positive numeric scalar giving the first shape parameter -of the Beta mixing distribution for the treatment group.} +\item{a_c, b_c}{Positive shape parameters of the control group.} -\item{alpha_c}{A positive numeric scalar giving the first shape parameter -of the Beta mixing distribution for the control group.} - -\item{beta_t}{A positive numeric scalar giving the second shape parameter -of the Beta mixing distribution for the treatment group.} - -\item{beta_c}{A positive numeric scalar giving the second shape parameter -of the Beta mixing distribution for the control group.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P((Y_t / m_t) - (Y_c / m_c) \le q)}, otherwise -\eqn{P((Y_t / m_t) - (Y_c / m_c) > q)}.} +\item{lower.tail}{Logical; if \code{TRUE} (default), probabilities are +\eqn{\Pr(Y_t / m_t - Y_c / m_c \le q)}, otherwise +\eqn{\Pr(Y_t / m_t - Y_c / m_c > q)}.} } \value{ -A numeric scalar in \code{[0, 1]}. +A numeric vector of probabilities. The arguments \code{q}, +\code{a_t}, \code{b_t}, \code{a_c} and \code{b_c} are recycled to a common +length; each must have length 1 or the common length. } \description{ -Calculates the cumulative distribution function (CDF) of the difference -between two independent Beta-Binomial proportions by exact enumeration. -Specifically, computes \eqn{P((Y_t / m_t) - (Y_c / m_c) \le q)} or -\eqn{P((Y_t / m_t) - (Y_c / m_c) > q)}, where -\eqn{Y_j \sim \mathrm{BetaBinomial}(m_j, \alpha_j, \beta_j)} for -\eqn{j \in \{t, c\}}. +Computes \eqn{\Pr(Y_t / m_t - Y_c / m_c \le q)} (or the upper tail +\eqn{\Pr(Y_t / m_t - Y_c / m_c > q)}) for independent +\eqn{Y_t \sim \textrm{Beta-binomial}(m_t, a_t, b_t)} and +\eqn{Y_c \sim \textrm{Beta-binomial}(m_c, a_c, b_c)}. This is the posterior +predictive probability for the difference in response proportions of a +future study with \eqn{m_t} and \eqn{m_c} subjects. } \details{ -The probability mass function of -\eqn{Y_j \sim \mathrm{BetaBinomial}(m_j, \alpha_j, \beta_j)} is: -\deqn{P(Y_j = k) = \binom{m_j}{k} - \frac{B(k + \alpha_j,\; m_j - k + \beta_j)}{B(\alpha_j, \beta_j)}, - \quad k = 0, \ldots, m_j} -where \eqn{B(\cdot, \cdot)} is the Beta function. - -The exact CDF is obtained by enumerating all -\eqn{(m_t + 1)(m_c + 1)} outcome combinations and summing the joint -probabilities for which the proportion difference satisfies the specified -condition. Computation time therefore grows quadratically in \eqn{m_t} and -\eqn{m_c}; for large future sample sizes consider a normal approximation. - -The Beta-Binomial distribution arises when the success probability in a -Binomial model follows a Beta prior, making it appropriate for -posterior predictive calculations in Bayesian binary-endpoint trials. +The probability is an exact finite sum. The probability mass functions are +computed on the log scale, so large values of \eqn{m_t} and \eqn{m_c} do not +cause overflow. Each difference is compared with \code{q} after a single +division of the exact integer numerator \eqn{m_c Y_t - m_t Y_c} by +\eqn{m_t m_c}, so differences that are mathematically equal to a decimal +\code{q} are classified correctly (they belong to the lower tail). } \examples{ -# P((Y_t/12) - (Y_c/12) > 0.2) with symmetric Beta(0.5, 0.5) priors -pbetabinomdiff(0.2, 12, 12, 0.5, 0.5, 0.5, 0.5, lower.tail = FALSE) - -# P((Y_t/20) - (Y_c/15) > 0.1) with different future sample sizes -pbetabinomdiff(0.1, 20, 15, 1, 1, 1, 1, lower.tail = FALSE) - -# P((Y_t/10) - (Y_c/10) > 0) with informative priors -pbetabinomdiff(0, 10, 10, 2, 3, 3, 2, lower.tail = FALSE) - -# Lower tail: P((Y_t/15) - (Y_c/15) <= 0.05) with vague priors -pbetabinomdiff(0.05, 15, 15, 1, 1, 1, 1, lower.tail = TRUE) - +# Predictive probability that the future difference exceeds 0, with +# Jeffreys priors, 7/12 versus 4/12 responders and 20 future subjects per +# group +pbetabinomdiff(0, m_t = 20, a_t = 7.5, b_t = 5.5, m_c = 20, a_c = 4.5, + b_c = 8.5, lower.tail = FALSE) +} +\seealso{ +Other distributions: +\code{\link[=cellprob_binary2]{cellprob_binary2()}}, +\code{\link[=pbetadiff]{pbetadiff()}}, +\code{\link[=psurvdiff]{psurvdiff()}}, +\code{\link[=ptdiff]{ptdiff()}}, +\code{\link[=rdirichlet]{rdirichlet()}} } +\concept{distributions} diff --git a/man/pbetadiff.Rd b/man/pbetadiff.Rd index a5ba9f3..3f183e4 100644 --- a/man/pbetadiff.Rd +++ b/man/pbetadiff.Rd @@ -2,68 +2,61 @@ % Please edit documentation in R/pbetadiff.R \name{pbetadiff} \alias{pbetadiff} -\title{Cumulative Distribution Function of the Difference Between Two -Independent Beta Variables} +\title{Distribution function of the difference of two Beta variables} \usage{ -pbetadiff(q, alpha_t, alpha_c, beta_t, beta_c, lower.tail = TRUE) +pbetadiff(q, a_t, b_t, a_c, b_c, lower.tail = TRUE) } \arguments{ -\item{q}{A numeric scalar in \code{[-1, 1]} representing the quantile -threshold for the difference in proportions.} +\item{q}{Numeric vector of quantiles.} -\item{alpha_t}{A positive numeric scalar giving the first shape parameter -of the Beta distribution for the treatment group.} +\item{a_t, b_t}{Positive shape parameters of the treatment group.} -\item{alpha_c}{A positive numeric scalar giving the first shape parameter -of the Beta distribution for the control group.} +\item{a_c, b_c}{Positive shape parameters of the control group.} -\item{beta_t}{A positive numeric scalar giving the second shape parameter -of the Beta distribution for the treatment group.} - -\item{beta_c}{A positive numeric scalar giving the second shape parameter -of the Beta distribution for the control group.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(\pi_t - \pi_c \le q)}, otherwise -\eqn{P(\pi_t - \pi_c > q)}.} +\item{lower.tail}{Logical; if \code{TRUE} (default), probabilities are +\eqn{\Pr(\pi_t - \pi_c \le q)}, otherwise \eqn{\Pr(\pi_t - \pi_c > q)}.} } \value{ -A numeric scalar in \code{[0, 1]}. +A numeric vector of probabilities. All arguments except +\code{lower.tail} are recycled to a common length; each must have length +1 or the common length. } \description{ -Calculates the cumulative distribution function (CDF) of the difference -between two independent Beta-distributed random variables. Specifically, -computes \eqn{P(\pi_t - \pi_c \le q)} or \eqn{P(\pi_t - \pi_c > q)}, where -\eqn{\pi_j \sim \mathrm{Beta}(\alpha_j, \beta_j)} for -\eqn{j \in \{t, c\}}. +Computes \eqn{\Pr(\pi_t - \pi_c \le q)} (or the upper tail +\eqn{\Pr(\pi_t - \pi_c > q)}) for independent +\eqn{\pi_t \sim \textrm{Beta}(a_t, b_t)} and +\eqn{\pi_c \sim \textrm{Beta}(a_c, b_c)}. This is the posterior probability +used for a single binary endpoint. } \details{ -The upper-tail probability is obtained via the convolution formula: -\deqn{P(\pi_t - \pi_c > q) - = \int_0^1 F_{\mathrm{Beta}(\alpha_c, \beta_c)}(x - q)\, - f_{\mathrm{Beta}(\alpha_t, \beta_t)}(x)\, dx} -where \eqn{f_{\mathrm{Beta}(\alpha_t, \beta_t)}} is the density of -\eqn{\pi_t} and \eqn{F_{\mathrm{Beta}(\alpha_c, \beta_c)}} is the CDF of -\eqn{\pi_c}. Boundary cases are handled automatically by \code{pbeta} -(\eqn{0} for \eqn{x - q \le 0}, \eqn{1} for \eqn{x - q \ge 1}), so -integrating over \code{[0, 1]} is safe. - -This single-integral convolution replaces an equivalent double-integral -formulation based on Appell's F1 hypergeometric function, yielding the -same result with lower computational cost because both \code{pbeta} and -\code{dbeta} are implemented in compiled C code. +The upper tail is computed as +\deqn{\Pr(\pi_t - \pi_c > q) = \Pr(\pi_c < -q) + + \int f_c(x) \Pr(\pi_t > x + q) \, dx,} +where the integral runs over the values of \eqn{x} with +\eqn{0 \le x + q \le 1}, and the first term is zero for +\eqn{q \ge 0}. The integral is evaluated by adaptive Gauss-Kronrod +quadrature (the QUADPACK routine used by \code{\link[stats]{integrate}}), +with the range split at quantiles of both Beta distributions so that +concentrated distributions are integrated accurately. When the density of +\eqn{\pi_c} is unbounded at 0 (\eqn{a_c < 1}) or at 1 (\eqn{b_c < 1}), the +integral on that side of the median of \eqn{\pi_c} is evaluated in the +variable \eqn{s = x^{a_c}} or \eqn{s = (1 - x)^{b_c}}, in which the +integrand is bounded. The lower tail is +computed directly from the same formula with the roles of the two groups +exchanged, so both tails are accurate near 0. } \examples{ -# P(pi_t - pi_c > 0.2) with symmetric Beta(0.5, 0.5) priors -pbetadiff(0.2, 0.5, 0.5, 0.5, 0.5, lower.tail = FALSE) - -# P(pi_t - pi_c > -0.1) with informative priors -pbetadiff(-0.1, 2, 1, 3, 4, lower.tail = FALSE) - -# P(pi_t - pi_c > 0) with equal priors -- should be approximately 0.5 -pbetadiff(0, 1, 1, 1, 1, lower.tail = FALSE) - -# Lower tail: P(pi_t - pi_c <= 0.1) with symmetric priors -pbetadiff(0.1, 2, 2, 2, 2, lower.tail = TRUE) - +# Posterior probability that the response rate difference exceeds 0.1, +# with Jeffreys priors and 7/12 versus 4/12 responders +pbetadiff(0.1, a_t = 7.5, b_t = 5.5, a_c = 4.5, b_c = 8.5, + lower.tail = FALSE) +} +\seealso{ +Other distributions: +\code{\link[=cellprob_binary2]{cellprob_binary2()}}, +\code{\link[=pbetabinomdiff]{pbetabinomdiff()}}, +\code{\link[=psurvdiff]{psurvdiff()}}, +\code{\link[=ptdiff]{ptdiff()}}, +\code{\link[=rdirichlet]{rdirichlet()}} } +\concept{distributions} diff --git a/man/plot.getgamma1bin.Rd b/man/plot.getgamma1bin.Rd deleted file mode 100644 index 027fa42..0000000 --- a/man/plot.getgamma1bin.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.getgamma1bin.R -\name{plot.getgamma1bin} -\alias{plot.getgamma1bin} -\title{Plot Method for getgamma1bin Objects} -\usage{ -\method{plot}{getgamma1bin}( - x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{getgamma1bin}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays calibration curves of marginal Go and NoGo probabilities against -the threshold grid \eqn{\gamma} for results returned by -\code{\link{getgamma1bin}}. -} -\details{ -The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -The y-axis represents the marginal probability: -\itemize{ -\item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -under the Go-calibration scenario (typically the Null scenario). -\item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -evaluated under the NoGo-calibration scenario (typically the -Alternative scenario). -} - -Horizontal reference lines are drawn at \code{target_go} and -\code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -with their values shown in the legend. -If either optimal threshold is \code{NA}, the corresponding point is omitted. -} diff --git a/man/plot.getgamma1cont.Rd b/man/plot.getgamma1cont.Rd deleted file mode 100644 index 706124b..0000000 --- a/man/plot.getgamma1cont.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.getgamma1cont.R -\name{plot.getgamma1cont} -\alias{plot.getgamma1cont} -\title{Plot Method for getgamma1cont Objects} -\usage{ -\method{plot}{getgamma1cont}( - x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{getgamma1cont}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays calibration curves of marginal Go and NoGo probabilities against -the threshold grid \eqn{\gamma} for results returned by -\code{\link{getgamma1cont}}. -} -\details{ -The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -The y-axis represents the marginal probability: -\itemize{ -\item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -under the Go-calibration scenario (typically the Null scenario). -\item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -evaluated under the NoGo-calibration scenario (typically the -Alternative scenario). -} - -Horizontal reference lines are drawn at \code{target_go} and -\code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -with their values shown in the legend. -If either optimal threshold is \code{NA}, the corresponding point is omitted. -} diff --git a/man/plot.getgamma2bin.Rd b/man/plot.getgamma2bin.Rd deleted file mode 100644 index 18c30a4..0000000 --- a/man/plot.getgamma2bin.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.getgamma2bin.R -\name{plot.getgamma2bin} -\alias{plot.getgamma2bin} -\title{Plot Method for getgamma2bin Objects} -\usage{ -\method{plot}{getgamma2bin}( - x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{getgamma2bin}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays calibration curves of marginal Go and NoGo probabilities against -the threshold grid \eqn{\gamma} for results returned by -\code{\link{getgamma2bin}}. -} -\details{ -The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -The y-axis represents the marginal probability: -\itemize{ -\item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -under the Go-calibration scenario (typically the Null scenario). -\item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -evaluated under the NoGo-calibration scenario (typically the -Alternative scenario). -} - -Horizontal reference lines are drawn at \code{target_go} and -\code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -with their values shown in the legend. -If either optimal threshold is \code{NA}, the corresponding point is omitted. -} diff --git a/man/plot.getgamma2cont.Rd b/man/plot.getgamma2cont.Rd deleted file mode 100644 index b1cc682..0000000 --- a/man/plot.getgamma2cont.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.getgamma2cont.R -\name{plot.getgamma2cont} -\alias{plot.getgamma2cont} -\title{Plot Method for getgamma2cont Objects} -\usage{ -\method{plot}{getgamma2cont}( - x, - title = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{getgamma2cont}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays calibration curves of marginal Go and NoGo probabilities against -the threshold grid \eqn{\gamma} for results returned by -\code{\link{getgamma2cont}}. -} -\details{ -The x-axis represents candidate threshold values \eqn{\gamma \in (0, 1)}. -The y-axis represents the marginal probability: -\itemize{ -\item \strong{Go curve}: \eqn{\Pr(g_{\mathrm{Go}} \ge \gamma)} evaluated -under the Go-calibration scenario (typically the Null scenario). -\item \strong{NoGo curve}: \eqn{\Pr(g_{\mathrm{NoGo}} \ge \gamma)} -evaluated under the NoGo-calibration scenario (typically the -Alternative scenario). -} - -Horizontal reference lines are drawn at \code{target_go} and -\code{target_nogo}. Filled circles (\code{geom_point}) mark the optimal -thresholds \eqn{(\gamma_{\mathrm{go}},\, \Pr(\mathrm{Go})_{\mathrm{opt}})} -and \eqn{(\gamma_{\mathrm{nogo}},\, \Pr(\mathrm{NoGo})_{\mathrm{opt}})}, -with their values shown in the legend. -If either optimal threshold is \code{NA}, the corresponding point is omitted. -} diff --git a/man/plot.pbayesdecisionprob1bin.Rd b/man/plot.pbayesdecisionprob1bin.Rd deleted file mode 100644 index 70ba58f..0000000 --- a/man/plot.pbayesdecisionprob1bin.Rd +++ /dev/null @@ -1,63 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.pbayesdecisionprob1bin.R -\name{plot.pbayesdecisionprob1bin} -\alias{plot.pbayesdecisionprob1bin} -\title{Plot Method for pbayesdecisionprob1bin Objects} -\usage{ -\method{plot}{pbayesdecisionprob1bin}( - x, - title = NULL, - xlab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob1bin}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{xlab}{A character string or expression for the x-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{col_gray}{A character string specifying the colour for the Gray curve. -Default is \code{"#939597"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays an operating characteristics curve of Go/NoGo/Gray decision -probabilities against the true treatment effect for binary endpoint results -returned by \code{\link{pbayesdecisionprob1bin}}. -} -\details{ -For \code{design = 'controlled'} or \code{design = 'external'}, the -x-axis represents the treatment-minus-control difference -\eqn{\theta = \pi_t - \bar{\pi}_c}, where \eqn{\bar{\pi}_c} is the mean -of the supplied \code{pi_c} values. For \code{design = 'uncontrolled'}, -the x-axis represents \eqn{\pi_t} directly. - -Vertical reference lines are drawn at the decision thresholds: -\itemize{ -\item When \code{prob = 'posterior'}: lines at \eqn{\theta_{TV}} and -\eqn{\theta_{MAV}} (converted to the x-axis scale). -\item When \code{prob = 'predictive'}: a single line at \eqn{\theta_{NULL}}. -} -} diff --git a/man/plot.pbayesdecisionprob1cont.Rd b/man/plot.pbayesdecisionprob1cont.Rd deleted file mode 100644 index 98d3594..0000000 --- a/man/plot.pbayesdecisionprob1cont.Rd +++ /dev/null @@ -1,63 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.pbayesdecisionprob1cont.R -\name{plot.pbayesdecisionprob1cont} -\alias{plot.pbayesdecisionprob1cont} -\title{Plot Method for pbayesdecisionprob1cont Objects} -\usage{ -\method{plot}{pbayesdecisionprob1cont}( - x, - title = NULL, - xlab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob1cont}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{xlab}{A character string or expression for the x-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{col_go}{A character string specifying the colour for the Go curve. -Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the colour for the NoGo curve. -Default is \code{"#D91E49"}.} - -\item{col_gray}{A character string specifying the colour for the Gray curve. -Default is \code{"#939597"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object. -} -\description{ -Displays an operating characteristics curve of Go/NoGo/Gray decision -probabilities against the true treatment effect for continuous endpoint -results returned by \code{\link{pbayesdecisionprob1cont}}. -} -\details{ -For \code{design = 'controlled'} or \code{design = 'external'}, the -x-axis represents the treatment-minus-control difference -\eqn{\theta = \mu_t - \bar{\mu}_c}, where \eqn{\bar{\mu}_c} is the mean -of the supplied \code{mu_c} values. For \code{design = 'uncontrolled'}, -the x-axis represents \eqn{\mu_t} directly. - -Vertical reference lines are drawn at the decision thresholds: -\itemize{ -\item When \code{prob = 'posterior'}: lines at \eqn{\theta_{TV}} and -\eqn{\theta_{MAV}} (converted to the x-axis scale). -\item When \code{prob = 'predictive'}: a single line at \eqn{\theta_{NULL}}. -} -} diff --git a/man/plot.pbayesdecisionprob2bin.Rd b/man/plot.pbayesdecisionprob2bin.Rd deleted file mode 100644 index 695e0bb..0000000 --- a/man/plot.pbayesdecisionprob2bin.Rd +++ /dev/null @@ -1,96 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.pbayesdecisionprob2bin.R -\name{plot.pbayesdecisionprob2bin} -\alias{plot.pbayesdecisionprob2bin} -\title{Plot Method for pbayesdecisionprob2bin Objects} -\usage{ -\method{plot}{pbayesdecisionprob2bin}( - x, - which = "Go", - title = NULL, - xlab = NULL, - ylab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob2bin}.} - -\item{which}{A character string specifying which decision probability to -plot. Must be one of \code{"Go"}, \code{"Gray"}, \code{"NoGo"}, -\code{"all"}, or \code{"overlay"}. Default is \code{"Go"}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{xlab}{A character string or expression for the x-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{ylab}{A character string or expression for the y-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{col_go}{A character string specifying the high-end fill colour for the -Go probability gradient. Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the high-end fill colour for -the NoGo probability gradient. Default is \code{"#D91E49"}.} - -\item{col_gray}{A character string specifying the high-end fill colour for -the Gray probability gradient. Default is \code{"#939597"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object (single panel) or a -\code{gtable} object (\code{which = "all"}). -} -\description{ -Displays operating characteristics for two-binary-endpoint results returned -by \code{\link{pbayesdecisionprob2bin}}. -} -\details{ -When the input scenarios form a regular grid over -\code{(pi_t1, pi_t2)} (i.e., every combination of the unique values of -\code{pi_t1} and \code{pi_t2} is present) and \code{rho_t} is constant, -the function produces a \strong{filled tile plot}: each panel (Go, Gray, -NoGo) is coloured by its own probability on a continuous gradient (white to -the panel colour), so intensity directly reflects the probability magnitude. -A solid white contour line is overlaid at the corresponding decision -threshold (\code{gamma_go} for the Go panel, \code{gamma_nogo} for the -NoGo panel, and their mean for the Gray panel) to mark the boundary where -the probability equals the threshold. Otherwise the function falls back to -a \strong{scatter plot} in which point colour encodes the decision -probability on a continuous scale. - -When \code{which = "all"}, the three panels are arranged side-by-side using -\code{gridExtra::grid.arrange}, so each panel retains its own independent -colour scale. This requires the \pkg{gridExtra} package. - -For \code{design = 'controlled'} or \code{design = 'external'}, both axes -are expressed as treatment-minus-control differences: -\eqn{\theta_1 = \pi_{t1} - \bar{\pi}_{c1}} and -\eqn{\theta_2 = \pi_{t2} - \bar{\pi}_{c2}}, -where \eqn{\bar{\pi}_{c1}} and \eqn{\bar{\pi}_{c2}} are the means of the -supplied \code{pi_c1} and \code{pi_c2} vectors. -For \code{design = 'uncontrolled'}, the axes represent \eqn{\pi_{t1}} and -\eqn{\pi_{t2}} directly. - -Vertical and horizontal reference lines are drawn at the decision thresholds: -\itemize{ -\item When \code{prob = 'posterior'}: vertical lines at \eqn{\theta_{TV1}} -and \eqn{\theta_{MAV1}} (x-axis) and horizontal lines at -\eqn{\theta_{TV2}} and \eqn{\theta_{MAV2}} (y-axis). -\item When \code{prob = 'predictive'}: a single vertical line at -\eqn{\theta_{NULL1}} and a single horizontal line at -\eqn{\theta_{NULL2}}. -} -} diff --git a/man/plot.pbayesdecisionprob2cont.Rd b/man/plot.pbayesdecisionprob2cont.Rd deleted file mode 100644 index beeb932..0000000 --- a/man/plot.pbayesdecisionprob2cont.Rd +++ /dev/null @@ -1,92 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/plot.pbayesdecisionprob2cont.R -\name{plot.pbayesdecisionprob2cont} -\alias{plot.pbayesdecisionprob2cont} -\title{Plot Method for pbayesdecisionprob2cont Objects} -\usage{ -\method{plot}{pbayesdecisionprob2cont}( - x, - which = "Go", - title = NULL, - xlab = NULL, - ylab = NULL, - col_go = "#658D1B", - col_nogo = "#D91E49", - col_gray = "#939597", - base_size = 28, - ... -) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob2cont}.} - -\item{which}{A character string specifying which decision probability to -plot. Must be one of \code{"Go"}, \code{"Gray"}, \code{"NoGo"}, -\code{"all"}, or \code{"overlay"}. Default is \code{"Go"}.} - -\item{title}{A character string for the plot title. Defaults to -\code{NULL} (no title displayed).} - -\item{xlab}{A character string or expression for the x-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{ylab}{A character string or expression for the y-axis label. -Defaults to \code{NULL}, which auto-generates a label based on -\code{design}.} - -\item{col_go}{A character string specifying the high-end fill colour for the -Go probability gradient. Default is \code{"#658D1B"}.} - -\item{col_nogo}{A character string specifying the high-end fill colour for -the NoGo probability gradient. Default is \code{"#D91E49"}.} - -\item{col_gray}{A character string specifying the high-end fill colour for -the Gray probability gradient. Default is \code{"#939597"}.} - -\item{base_size}{A positive numeric scalar specifying the base font size -(in points) passed to \code{theme_bw()}. Default is \code{28}.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns a \code{ggplot} object (single panel) or a -\code{gtable} object (\code{which = "all"}). -} -\description{ -Displays operating characteristics for two-continuous-endpoint results -returned by \code{\link{pbayesdecisionprob2cont}}. -} -\details{ -When the input scenarios form a regular grid over -\code{(mu_t1, mu_t2)} (i.e., every combination of the unique values of -\code{mu_t1} and \code{mu_t2} is present) and \code{rho_t} is constant, -the function produces a \strong{filled tile plot}: each panel (Go, Gray, -NoGo) is coloured by its own probability on a continuous gradient (white to -the panel colour), so intensity directly reflects the probability magnitude. -Otherwise the function falls back to a \strong{scatter plot} in which point -colour encodes the decision probability on a continuous scale. - -When \code{which = "all"}, the three panels are arranged side-by-side using -\code{gridExtra::grid.arrange}, so each panel retains its own independent -colour scale. This requires the \pkg{gridExtra} package. - -For \code{design = 'controlled'} or \code{design = 'external'}, both axes -are expressed as treatment-minus-control differences: -\eqn{\theta_1 = \mu_{t1} - \bar{\mu}_{c1}} and -\eqn{\theta_2 = \mu_{t2} - \bar{\mu}_{c2}}, -where \eqn{\bar{\mu}_{c1}} and \eqn{\bar{\mu}_{c2}} are the means of the -supplied \code{mu_c1} and \code{mu_c2} vectors. -For \code{design = 'uncontrolled'}, the axes represent \eqn{\mu_{t1}} and -\eqn{\mu_{t2}} directly. - -Vertical and horizontal reference lines are drawn at the decision thresholds: -\itemize{ -\item When \code{prob = 'posterior'}: vertical lines at \eqn{\theta_{TV1}} -and \eqn{\theta_{MAV1}} (x-axis) and horizontal lines at -\eqn{\theta_{TV2}} and \eqn{\theta_{MAV2}} (y-axis). -\item When \code{prob = 'predictive'}: a single vertical line at -\eqn{\theta_{NULL1}} and a single horizontal line at -\eqn{\theta_{NULL2}}. -} -} diff --git a/man/plot.qdm_boundary.Rd b/man/plot.qdm_boundary.Rd new file mode 100644 index 0000000..3365416 --- /dev/null +++ b/man/plot.qdm_boundary.Rd @@ -0,0 +1,59 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.qdm_boundary.R +\name{plot.qdm_boundary} +\alias{plot.qdm_boundary} +\title{Plot a decision boundary} +\usage{ +\method{plot}{qdm_boundary}( + x, + col_go = "#658D1B", + col_nogo = "#D91E49", + col_gray = "#939597", + col_miss = "#E69F00", + base_size = 11, + legend_position = "bottom", + ... +) +} +\arguments{ +\item{x}{An object of class \code{"qdm_boundary"}.} + +\item{col_go, col_nogo, col_gray, col_miss}{Colors of the Go, NoGo, Gray and +Miss decisions: color names or hexadecimal codes. The defaults are +green, red, gray and orange. Transparency (an alpha value in the code) +is not used in the heat maps.} + +\item{base_size}{Base font size of \code{ggplot2::theme_bw()}, in points, +which sets the size of the axis labels, tick labels, legend and caption.} + +\item{legend_position}{Position of the legend: \code{"bottom"} (the +default), \code{"top"}, \code{"left"}, \code{"right"} or \code{"none"}. +To place the legend inside the plot, add \code{ggplot2::theme()}.} + +\item{...}{Not used; arguments given here are ignored with a warning.} +} +\value{ +A \code{ggplot} object. +} +\description{ +Draws the decision (Go, NoGo, Gray, or Miss if it occurs) at each point of +the grid computed by \code{\link{qdm_boundary}} as a tile filled by the +decision. The edges between regions of different decisions are the +decision boundaries of the design. +} +\details{ +The plot is a \code{ggplot} object, so it can be changed further by adding +\pkg{ggplot2} functions, for example \code{ggplot2::labs()}, +\code{ggplot2::theme()} and \code{ggplot2::scale_fill_manual()}. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +b <- qdm_boundary(des) +plot(b) +plot(b, col_gray = "gray80", base_size = 14, legend_position = "right") +} diff --git a/man/plot.qdm_calibration.Rd b/man/plot.qdm_calibration.Rd new file mode 100644 index 0000000..ab29e42 --- /dev/null +++ b/man/plot.qdm_calibration.Rd @@ -0,0 +1,62 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.qdm_calibration.R +\name{plot.qdm_calibration} +\alias{plot.qdm_calibration} +\title{Plot a calibration} +\usage{ +\method{plot}{qdm_calibration}( + x, + col_go = "#658D1B", + col_nogo = "#D91E49", + linewidth = 1, + base_size = 11, + legend_position = "bottom", + ... +) +} +\arguments{ +\item{x}{An object of class \code{"qdm_calibration"}.} + +\item{col_go, col_nogo}{Colors of the curves, targets and thresholds of the +Go and NoGo criteria: color names or hexadecimal codes. The defaults +are green and red.} + +\item{linewidth}{Width of the calibration curves, in the units of the +\code{linewidth} aesthetic of \pkg{ggplot2}.} + +\item{base_size}{Base font size of \code{ggplot2::theme_bw()}, in points, +which sets the size of the axis labels, tick labels and legend.} + +\item{legend_position}{Position of the legend: \code{"bottom"} (the +default), \code{"top"}, \code{"left"}, \code{"right"} or \code{"none"}. +To place the legend inside the plot, add \code{ggplot2::theme()}.} + +\item{...}{Not used; arguments given here are ignored with a warning.} +} +\value{ +A \code{ggplot} object. +} +\description{ +Draws the probability that the Go criterion is met under +\code{scenario_go} and the probability that the NoGo criterion is met under +\code{scenario_nogo} against the threshold, with the targets (horizontal +lines) and the chosen thresholds (vertical lines). +} +\details{ +The plot is a \code{ggplot} object, so it can be changed further by adding +\pkg{ggplot2} functions, for example \code{ggplot2::labs()} and +\code{ggplot2::theme()}. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +cal <- qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), + data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.05, target_nogo = 0.2) +plot(cal) +plot(cal, linewidth = 0.6, base_size = 14, legend_position = "top") +} diff --git a/man/plot.qdm_oc.Rd b/man/plot.qdm_oc.Rd new file mode 100644 index 0000000..40fcee4 --- /dev/null +++ b/man/plot.qdm_oc.Rd @@ -0,0 +1,100 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/plot.qdm_oc.R +\name{plot.qdm_oc} +\alias{plot.qdm_oc} +\title{Plot operating characteristics} +\usage{ +\method{plot}{qdm_oc}( + x, + col_go = "#658D1B", + col_nogo = "#D91E49", + col_gray = "#939597", + col_miss = "#E69F00", + linewidth = 1, + point_size = 1.5, + label_size = NULL, + base_size = 11, + legend_position = "bottom", + ... +) +} +\arguments{ +\item{x}{An object of class \code{"qdm_oc"}.} + +\item{col_go, col_nogo, col_gray, col_miss}{Colors of the Go, NoGo, Gray and +Miss decisions: color names or hexadecimal codes. The defaults are +green, red, gray and orange. Transparency (an alpha value in the code) +is not used in the heat maps.} + +\item{linewidth}{Width of the curves, in the units of the \code{linewidth} +aesthetic of \pkg{ggplot2}.} + +\item{point_size}{Size of the points, in millimeters.} + +\item{label_size}{Size of the text drawn in the plot, in millimeters: the +labels of the thresholds, or the probabilities in the cells of the heat +maps. \code{NULL} (the default) gives the size of the axis tick labels, +\code{0.8 * base_size / ggplot2::.pt}.} + +\item{base_size}{Base font size of \code{ggplot2::theme_bw()}, in points, +which sets the size of the axis labels, tick labels, legend and caption.} + +\item{legend_position}{Position of the legend: \code{"bottom"} (the +default), \code{"top"}, \code{"left"}, \code{"right"} or \code{"none"}. +To place the legend inside the plot, add \code{ggplot2::theme()}.} + +\item{...}{Not used; arguments given here are ignored with a warning.} +} +\value{ +A \code{ggplot} object. +} +\description{ +Draws the probabilities of Go, NoGo and Gray decisions (and Miss decisions +if they have positive probability) against the true treatment effect of +the scenarios. For a time-to-event endpoint, the effect is the difference +of the milestone survival probabilities \eqn{\exp(-\log(2) t_0 / m)} +given by the median survival times \eqn{m} of the scenarios. For a design +without a concurrent control group, the horizontal axis is the true +response rate (binary endpoint), mean (continuous endpoint) or milestone +survival probability (time-to-event endpoint) of the treatment group, and +the thresholds of the criterion are shifted by the fixed control value, or +otherwise by the mean (binary and time-to-event) or location (continuous) +of the distribution of the control group. The scenarios must have +distinct values on the horizontal axis, so scenarios with the same effect +(for example, with several standard deviations or control parameters) are +plotted separately. +} +\details{ +For two endpoints, the plot has one heat map per decision, with the true +treatment effects of the two endpoints (or the true parameters of the +treatment group without a concurrent control group) on the axes and the +probability of the decision in each cell; scenarios that are not evaluable +are marked "NE". The scenarios must have distinct values on the axes, so +scenarios with several correlations (or several parameters of the control +group) are plotted separately. Each panel is shaded from white +(probability 0) to the color of its decision (probability 1); the heat maps +have no legend. + +The plot is a \code{ggplot} object, so it can be changed further by adding +\pkg{ggplot2} functions, for example \code{ggplot2::labs()} for the title +and the axis labels, \code{ggplot2::theme()} for the text and the legend, +and \code{ggplot2::scale_colour_manual()} or +\code{ggplot2::scale_linetype_manual()} for the curves of one endpoint. +The colors of the heat maps are set by the color arguments. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +oc <- qdm_oc(des, data.frame(pi_t = seq(0.2, 0.9, by = 0.05), pi_c = 0.4)) +plot(oc) + +# Other colors, thinner lines, larger text and the legend on the right, +# with a title added by ggplot2 +plot(oc, col_go = "darkgreen", col_nogo = "firebrick", linewidth = 0.6, + base_size = 14, legend_position = "right") + + ggplot2::labs(title = "Operating characteristics") +} diff --git a/man/print.pbayesdecisionprob1bin.Rd b/man/print.pbayesdecisionprob1bin.Rd deleted file mode 100644 index 2c357d6..0000000 --- a/man/print.pbayesdecisionprob1bin.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/print.pbayesdecisionprob1bin.R -\name{print.pbayesdecisionprob1bin} -\alias{print.pbayesdecisionprob1bin} -\title{Print Method for pbayesdecisionprob1bin Objects} -\usage{ -\method{print}{pbayesdecisionprob1bin}(x, digits = 4, ...) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob1bin}.} - -\item{digits}{A positive integer specifying the number of decimal places -for probability values. Default is 4.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns \code{x}. -} -\description{ -Displays a formatted summary of Go/NoGo/Gray decision probabilities -for binary endpoint results returned by \code{\link{pbayesdecisionprob1bin}}. -} diff --git a/man/print.pbayesdecisionprob1cont.Rd b/man/print.pbayesdecisionprob1cont.Rd deleted file mode 100644 index 5882318..0000000 --- a/man/print.pbayesdecisionprob1cont.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/print.pbayesdecisionprob1cont.R -\name{print.pbayesdecisionprob1cont} -\alias{print.pbayesdecisionprob1cont} -\title{Print Method for pbayesdecisionprob1cont Objects} -\usage{ -\method{print}{pbayesdecisionprob1cont}(x, digits = 4, ...) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob1cont}.} - -\item{digits}{A positive integer specifying the number of decimal places -for probability values. Default is 4.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns \code{x}. -} -\description{ -Displays a formatted summary of Go/NoGo/Gray decision probabilities -for continuous endpoint results returned by \code{\link{pbayesdecisionprob1cont}}. -} diff --git a/man/print.pbayesdecisionprob2bin.Rd b/man/print.pbayesdecisionprob2bin.Rd deleted file mode 100644 index 3af954a..0000000 --- a/man/print.pbayesdecisionprob2bin.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/print.pbayesdecisionprob2bin.R -\name{print.pbayesdecisionprob2bin} -\alias{print.pbayesdecisionprob2bin} -\title{Print Method for pbayesdecisionprob2bin Objects} -\usage{ -\method{print}{pbayesdecisionprob2bin}(x, digits = 4, ...) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob2bin}.} - -\item{digits}{A positive integer specifying the number of decimal places -for probability values. Default is 4.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns \code{x}. -} -\description{ -Displays a formatted summary of Go/NoGo/Gray decision probabilities for -two-binary-endpoint results returned by \code{\link{pbayesdecisionprob2bin}}. -} diff --git a/man/print.pbayesdecisionprob2cont.Rd b/man/print.pbayesdecisionprob2cont.Rd deleted file mode 100644 index 8fe6124..0000000 --- a/man/print.pbayesdecisionprob2cont.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/pbayesdecisionprob2cont.R, -% R/print.pbayesdecisionprob2cont.R -\name{print.pbayesdecisionprob2cont} -\alias{print.pbayesdecisionprob2cont} -\title{Print Method for pbayesdecisionprob2cont Objects} -\usage{ -\method{print}{pbayesdecisionprob2cont}(x, digits = 4, ...) - -\method{print}{pbayesdecisionprob2cont}(x, digits = 4, ...) -} -\arguments{ -\item{x}{An object of class \code{pbayesdecisionprob2cont}.} - -\item{digits}{A positive integer specifying the number of decimal places -for probability values. Default is 4.} - -\item{...}{Further arguments passed to or from other methods (ignored).} -} -\value{ -Invisibly returns \code{x}. - -Invisibly returns \code{x}. -} -\description{ -Displays a formatted summary of Go/NoGo/Gray decision probabilities for -two-continuous-endpoint results returned by -\code{\link{pbayesdecisionprob2cont}}. - -Displays a formatted summary of Go/NoGo/Gray decision probabilities for -two-continuous-endpoint results returned by -\code{\link{pbayesdecisionprob2cont}}. -} diff --git a/man/print.qdm_borrow.Rd b/man/print.qdm_borrow.Rd new file mode 100644 index 0000000..0485326 --- /dev/null +++ b/man/print.qdm_borrow.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_borrow.R +\name{print.qdm_borrow} +\alias{print.qdm_borrow} +\title{Print an external data specification} +\usage{ +\method{print}{qdm_borrow}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_borrow"}.} + +\item{...}{Passed to \code{\link{format.qdm_borrow}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print an external data specification +} +\examples{ +print(borrow(data_binary(n = 20, y = 8), a0 = 0.5)) +} diff --git a/man/print.qdm_boundary.Rd b/man/print.qdm_boundary.Rd new file mode 100644 index 0000000..933d117 --- /dev/null +++ b/man/print.qdm_boundary.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_boundary.R +\name{print.qdm_boundary} +\alias{print.qdm_boundary} +\title{Print a decision boundary} +\usage{ +\method{print}{qdm_boundary}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_boundary"}.} + +\item{...}{Not used.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Prints the number of grid points with each decision and the first rows of +the grid. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +qdm_boundary(des) +} diff --git a/man/print.qdm_calibration.Rd b/man/print.qdm_calibration.Rd new file mode 100644 index 0000000..c9a075c --- /dev/null +++ b/man/print.qdm_calibration.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_calibration.R +\name{print.qdm_calibration} +\alias{print.qdm_calibration} +\title{Print a calibration} +\usage{ +\method{print}{qdm_calibration}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_calibration"}.} + +\item{digits}{Number of significant digits for numeric values.} + +\item{...}{Not used.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Prints the chosen thresholds and the decision probabilities of the design +with these thresholds under the two scenarios. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +print(qdm_calibrate(des, data.frame(pi_t = 0.4, pi_c = 0.4), + data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.05, target_nogo = 0.2)) +} diff --git a/man/print.qdm_conduct.Rd b/man/print.qdm_conduct.Rd new file mode 100644 index 0000000..92bc4db --- /dev/null +++ b/man/print.qdm_conduct.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_conduct.R +\name{print.qdm_conduct} +\alias{print.qdm_conduct} +\title{Print the conduct of a study} +\usage{ +\method{print}{qdm_conduct}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_conduct"}.} + +\item{...}{Passed to \code{\link{format.qdm_conduct}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print the conduct of a study +} +\examples{ +conduct_tte(accrual_time = c(0, 12), cut_events = 20) +} diff --git a/man/print.qdm_criterion.Rd b/man/print.qdm_criterion.Rd new file mode 100644 index 0000000..b3e88a9 --- /dev/null +++ b/man/print.qdm_criterion.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_criterion.R +\name{print.qdm_criterion} +\alias{print.qdm_criterion} +\title{Print a decision criterion} +\usage{ +\method{print}{qdm_criterion}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_criterion"}.} + +\item{...}{Passed to \code{\link{format.qdm_criterion}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a decision criterion +} +\examples{ +print(criterion_predictive(theta_null = 0, m_t = 50, gamma_go = 0.9, + gamma_nogo = 0.7)) +} diff --git a/man/print.qdm_data.Rd b/man/print.qdm_data.Rd new file mode 100644 index 0000000..2afb5e3 --- /dev/null +++ b/man/print.qdm_data.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_data.R +\name{print.qdm_data} +\alias{print.qdm_data} +\title{Print a data specification} +\usage{ +\method{print}{qdm_data}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_data"}.} + +\item{...}{Passed to \code{\link{format.qdm_data}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a data specification +} +\examples{ +print(data_continuous(n = 12, mean = 3.2, sd = 2)) +} diff --git a/man/print.qdm_decision.Rd b/man/print.qdm_decision.Rd new file mode 100644 index 0000000..9ea5eb5 --- /dev/null +++ b/man/print.qdm_decision.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_decision.R +\name{print.qdm_decision} +\alias{print.qdm_decision} +\title{Print a decision} +\usage{ +\method{print}{qdm_decision}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_decision"}.} + +\item{...}{Passed to \code{\link{format.qdm_decision}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a decision +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_predictive(theta_null = 0, m_t = 50, + gamma_go = 0.9, gamma_nogo = 0.7) +) +print(qdm_decide(des, data_binary(12, 9), data_binary(12, 4))) +} diff --git a/man/print.qdm_design.Rd b/man/print.qdm_design.Rd new file mode 100644 index 0000000..b14f5fe --- /dev/null +++ b/man/print.qdm_design.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_design.R +\name{print.qdm_design} +\alias{print.qdm_design} +\title{Print a design} +\usage{ +\method{print}{qdm_design}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_design"}.} + +\item{...}{Passed to \code{\link{format.qdm_design}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a design +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 0, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8), + hypothetical_c = hypothetical(data = data_binary(n = 12, y = 4)) +) +print(des) +} diff --git a/man/print.qdm_hypothetical.Rd b/man/print.qdm_hypothetical.Rd new file mode 100644 index 0000000..f2b9d6e --- /dev/null +++ b/man/print.qdm_hypothetical.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_hypothetical.R +\name{print.qdm_hypothetical} +\alias{print.qdm_hypothetical} +\title{Print a hypothetical control specification} +\usage{ +\method{print}{qdm_hypothetical}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_hypothetical"}.} + +\item{...}{Passed to \code{\link{format.qdm_hypothetical}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a hypothetical control specification +} +\examples{ +print(hypothetical(data = data_binary(n = 15, y = 5))) +} diff --git a/man/print.qdm_oc.Rd b/man/print.qdm_oc.Rd new file mode 100644 index 0000000..639ac28 --- /dev/null +++ b/man/print.qdm_oc.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_oc.R +\name{print.qdm_oc} +\alias{print.qdm_oc} +\title{Print operating characteristics} +\usage{ +\method{print}{qdm_oc}(x, digits = 4L, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_oc"}.} + +\item{digits}{Number of significant digits for the probabilities.} + +\item{...}{Not used.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print operating characteristics +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +print(qdm_oc(des, data.frame(pi_t = c(0.4, 0.6), pi_c = 0.4))) +} diff --git a/man/print.qdm_prior.Rd b/man/print.qdm_prior.Rd new file mode 100644 index 0000000..d1efd64 --- /dev/null +++ b/man/print.qdm_prior.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/print.qdm_prior.R +\name{print.qdm_prior} +\alias{print.qdm_prior} +\title{Print a prior specification} +\usage{ +\method{print}{qdm_prior}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{"qdm_prior"}.} + +\item{...}{Passed to \code{\link{format.qdm_prior}}.} +} +\value{ +\code{x}, invisibly. +} +\description{ +Print a prior specification +} +\examples{ +print(prior_nix(mu0 = 0, kappa0 = 1, nu0 = 3, sigma0 = 2)) +} diff --git a/man/prior_beta.Rd b/man/prior_beta.Rd new file mode 100644 index 0000000..986a004 --- /dev/null +++ b/man/prior_beta.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_beta.R +\name{prior_beta} +\alias{prior_beta} +\title{Beta prior for a response rate} +\usage{ +prior_beta(a, b) +} +\arguments{ +\item{a, b}{Positive shape parameters. \code{prior_beta(0.5, 0.5)} is the +Jeffreys prior and \code{prior_beta(1, 1)} is the uniform prior.} +} +\value{ +An object of class \code{c("qdm_prior_beta", "qdm_prior")} with +elements \code{a} and \code{b}. +} +\description{ +Creates a Beta prior distribution for the response rate of one group in an +analysis of a single binary endpoint. +} +\examples{ +prior_beta(0.5, 0.5) +} +\seealso{ +Other priors: +\code{\link[=prior_dirichlet]{prior_dirichlet()}}, +\code{\link[=prior_gamma]{prior_gamma()}}, +\code{\link[=prior_niw]{prior_niw()}}, +\code{\link[=prior_nix]{prior_nix()}}, +\code{\link[=prior_vague]{prior_vague()}} +} +\concept{priors} diff --git a/man/prior_dirichlet.Rd b/man/prior_dirichlet.Rd new file mode 100644 index 0000000..4c0e2fb --- /dev/null +++ b/man/prior_dirichlet.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_dirichlet.R +\name{prior_dirichlet} +\alias{prior_dirichlet} +\title{Dirichlet prior for two binary endpoints} +\usage{ +prior_dirichlet(alpha) +} +\arguments{ +\item{alpha}{A numeric vector of four positive concentration parameters in +the cell order \code{"00"}, \code{"01"}, \code{"10"}, \code{"11"}.} +} +\value{ +An object of class \code{c("qdm_prior_dirichlet", "qdm_prior")} +with element \code{alpha}, a named numeric vector of length 4. +} +\description{ +Creates a Dirichlet prior distribution for the four joint response +probabilities of two binary endpoints in one group. +} +\details{ +The four cells are ordered as \code{"00"}, \code{"01"}, \code{"10"} and +\code{"11"}, where the first digit is the response on endpoint 1 and the +second digit is the response on endpoint 2 (1 = response, 0 = no +response). The marginal response rates are therefore +\eqn{\pi_1 = p_{10} + p_{11}} and \eqn{\pi_2 = p_{01} + p_{11}}. +With \code{alpha = rep(0.25, 4)}, each marginal response rate has a +Beta(0.5, 0.5) prior distribution. +} +\examples{ +prior_dirichlet(rep(0.25, 4)) +} +\seealso{ +Other priors: +\code{\link[=prior_beta]{prior_beta()}}, +\code{\link[=prior_gamma]{prior_gamma()}}, +\code{\link[=prior_niw]{prior_niw()}}, +\code{\link[=prior_nix]{prior_nix()}}, +\code{\link[=prior_vague]{prior_vague()}} +} +\concept{priors} diff --git a/man/prior_gamma.Rd b/man/prior_gamma.Rd new file mode 100644 index 0000000..c8b591a --- /dev/null +++ b/man/prior_gamma.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_gamma.R +\name{prior_gamma} +\alias{prior_gamma} +\title{Gamma prior for a hazard rate} +\usage{ +prior_gamma(shape, rate) +} +\arguments{ +\item{shape, rate}{Positive shape and rate parameters (the prior mean of +the hazard is \code{shape / rate}).} +} +\value{ +An object of class \code{c("qdm_prior_gamma", "qdm_prior")} with +elements \code{shape} and \code{rate}. +} +\description{ +Creates a Gamma prior distribution for the hazard rate \eqn{\lambda} of +one group in an analysis of a time-to-event endpoint with exponential +event times. The milestone survival probability at time \eqn{t_0} is +\eqn{S(t_0) = \exp(-\lambda t_0)}. +} +\details{ +The prior is equivalent to \code{shape} events observed during a total +observed time of \code{rate}, so small values give a weakly informative +prior: \code{prior_gamma(0.1, 1)} carries the information of a tenth of an +event. +} +\examples{ +prior_gamma(0.1, 1) +} +\seealso{ +Other priors: +\code{\link[=prior_beta]{prior_beta()}}, +\code{\link[=prior_dirichlet]{prior_dirichlet()}}, +\code{\link[=prior_niw]{prior_niw()}}, +\code{\link[=prior_nix]{prior_nix()}}, +\code{\link[=prior_vague]{prior_vague()}} +} +\concept{priors} diff --git a/man/prior_niw.Rd b/man/prior_niw.Rd new file mode 100644 index 0000000..e6d1184 --- /dev/null +++ b/man/prior_niw.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_niw.R +\name{prior_niw} +\alias{prior_niw} +\title{Normal-Inverse-Wishart prior for two continuous endpoints} +\usage{ +prior_niw(mu0, kappa0, nu0, Lambda0) +} +\arguments{ +\item{mu0}{Numeric vector of length 2, the prior mean of \eqn{\mu}.} + +\item{kappa0}{Positive prior sample size for \eqn{\mu}.} + +\item{nu0}{Prior degrees of freedom of the inverse Wishart distribution; +must be greater than 1.} + +\item{Lambda0}{A 2 x 2 symmetric positive definite scale matrix.} +} +\value{ +An object of class \code{c("qdm_prior_niw", "qdm_prior")} with +elements \code{mu0}, \code{kappa0}, \code{nu0} and \code{Lambda0}. +} +\description{ +Creates the conjugate Normal-Inverse-Wishart prior for the mean vector +\eqn{\mu} and covariance matrix \eqn{\Sigma} of a bivariate normal endpoint +in one group: +\deqn{\mu \mid \Sigma \sim N_2(\mu_0, \Sigma / \kappa_0), \quad + \Sigma \sim \textrm{Inv-Wishart}(\nu_0, \Lambda_0).} +} +\examples{ +prior_niw(mu0 = c(0, 0), kappa0 = 1, nu0 = 4, Lambda0 = diag(2)) +} +\seealso{ +Other priors: +\code{\link[=prior_beta]{prior_beta()}}, +\code{\link[=prior_dirichlet]{prior_dirichlet()}}, +\code{\link[=prior_gamma]{prior_gamma()}}, +\code{\link[=prior_nix]{prior_nix()}}, +\code{\link[=prior_vague]{prior_vague()}} +} +\concept{priors} diff --git a/man/prior_nix.Rd b/man/prior_nix.Rd new file mode 100644 index 0000000..69ec9c6 --- /dev/null +++ b/man/prior_nix.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_nix.R +\name{prior_nix} +\alias{prior_nix} +\title{Normal-Inverse-chi-squared prior for a continuous endpoint} +\usage{ +prior_nix(mu0, kappa0, nu0, sigma0) +} +\arguments{ +\item{mu0}{Prior mean of \eqn{\mu}.} + +\item{kappa0}{Positive prior sample size for \eqn{\mu}.} + +\item{nu0}{Positive prior degrees of freedom for \eqn{\sigma^2}.} + +\item{sigma0}{Positive prior scale of \eqn{\sigma}, on the standard +deviation scale (the scaled inverse chi-squared distribution has scale +parameter \code{sigma0^2}).} +} +\value{ +An object of class \code{c("qdm_prior_nix", "qdm_prior")} with +elements \code{mu0}, \code{kappa0}, \code{nu0} and \code{sigma0}. +} +\description{ +Creates the conjugate Normal-Inverse-chi-squared prior for the mean +\eqn{\mu} and variance \eqn{\sigma^2} of a normally distributed endpoint in +one group: +\deqn{\mu \mid \sigma^2 \sim N(\mu_0, \sigma^2 / \kappa_0), \quad + \sigma^2 \sim \textrm{Inv-}\chi^2(\nu_0, \sigma_0^2).} +} +\examples{ +prior_nix(mu0 = 0, kappa0 = 1, nu0 = 3, sigma0 = 2) +} +\seealso{ +Other priors: +\code{\link[=prior_beta]{prior_beta()}}, +\code{\link[=prior_dirichlet]{prior_dirichlet()}}, +\code{\link[=prior_gamma]{prior_gamma()}}, +\code{\link[=prior_niw]{prior_niw()}}, +\code{\link[=prior_vague]{prior_vague()}} +} +\concept{priors} diff --git a/man/prior_vague.Rd b/man/prior_vague.Rd new file mode 100644 index 0000000..a7c1041 --- /dev/null +++ b/man/prior_vague.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prior_vague.R +\name{prior_vague} +\alias{prior_vague} +\title{Vague prior for continuous endpoints} +\usage{ +prior_vague() +} +\value{ +An object of class \code{c("qdm_prior_vague", "qdm_prior")}. +} +\description{ +Creates the vague (reference) prior for the parameters of a normally +distributed endpoint. For one endpoint the prior density is +\eqn{p(\mu, \sigma^2) \propto \sigma^{-2}}; for two endpoints it is +\eqn{p(\mu, \Sigma) \propto |\Sigma|^{-3/2}}. With \eqn{n} observations the +posterior distribution of the mean is a t distribution with \eqn{n - 1} +degrees of freedom for one endpoint and a bivariate t distribution with +\eqn{n - 2} degrees of freedom for two endpoints. +} +\examples{ +prior_vague() +} +\seealso{ +Other priors: +\code{\link[=prior_beta]{prior_beta()}}, +\code{\link[=prior_dirichlet]{prior_dirichlet()}}, +\code{\link[=prior_gamma]{prior_gamma()}}, +\code{\link[=prior_niw]{prior_niw()}}, +\code{\link[=prior_nix]{prior_nix()}} +} +\concept{priors} diff --git a/man/psurvdiff.Rd b/man/psurvdiff.Rd new file mode 100644 index 0000000..fa3de96 --- /dev/null +++ b/man/psurvdiff.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/psurvdiff.R +\name{psurvdiff} +\alias{psurvdiff} +\title{Distribution function of the difference of two milestone survival +probabilities} +\usage{ +psurvdiff(q, milestone, shape_t, rate_t, shape_c, rate_c, lower.tail = TRUE) +} +\arguments{ +\item{q}{Numeric vector of quantiles.} + +\item{milestone}{Positive milestone time \eqn{t_0}.} + +\item{shape_t, rate_t}{Positive shape and rate of the treatment hazard.} + +\item{shape_c, rate_c}{Positive shape and rate of the control hazard.} + +\item{lower.tail}{Logical; if \code{TRUE} (default), probabilities are +\eqn{\Pr(S_t - S_c \le q)}, otherwise \eqn{\Pr(S_t - S_c > q)}.} +} +\value{ +A numeric vector of probabilities. All arguments except +\code{lower.tail} are recycled to a common length; each must have length +1 or the common length. +} +\description{ +Computes \eqn{\Pr(S_t - S_c \le q)} (or the upper tail +\eqn{\Pr(S_t - S_c > q)}) for the milestone survival probabilities +\eqn{S_k = \exp(-\lambda_k t_0)}, where the hazards have independent +Gamma distributions, \eqn{\lambda_t \sim \textrm{Gamma}(a_t, b_t)} and +\eqn{\lambda_c \sim \textrm{Gamma}(a_c, b_c)} (shape and rate). This is +the posterior probability used for a time-to-event endpoint with a +concurrent, external or hypothetical control. +} +\details{ +The upper tail is computed as +\deqn{\Pr(S_t - S_c > q) = \Pr(S_c \le -q) + + \int g_c(\lambda) G_t\left(-\log(q + e^{-\lambda t_0}) / t_0\right) + \, d\lambda,} +where \eqn{g_c} is the density of \eqn{\lambda_c}, \eqn{G_t} is the +distribution function of \eqn{\lambda_t}, the integral runs over the +values of \eqn{\lambda} with \eqn{0 < q + e^{-\lambda t_0} < 1}, and the +first term is zero for \eqn{q \ge 0}. The integral is evaluated by +adaptive Gauss-Kronrod quadrature (the QUADPACK routine used by +\code{\link[stats]{integrate}}), with the range split at quantiles of the +control hazard and at the values that correspond to quantiles of the +treatment hazard. When the density of \eqn{\lambda_c} is unbounded at 0 +(\eqn{a_c < 1}), the integral below its median is evaluated in the +variable \eqn{u = \lambda^{a_c}}, in which the integrand is bounded. The +lower tail is computed from the same formula with the roles of the two +groups exchanged, so both tails are accurate near 0. +} +\examples{ +# Posterior probability that the 3-month survival is higher by more than +# 0.1 with 5 events in 40 months of follow-up versus 9 events in 35 months +# (Gamma(0.1, 1) priors) +psurvdiff(0.1, milestone = 3, shape_t = 5.1, rate_t = 41, + shape_c = 9.1, rate_c = 36, lower.tail = FALSE) +} +\seealso{ +Other distributions: +\code{\link[=cellprob_binary2]{cellprob_binary2()}}, +\code{\link[=pbetabinomdiff]{pbetabinomdiff()}}, +\code{\link[=pbetadiff]{pbetadiff()}}, +\code{\link[=ptdiff]{ptdiff()}}, +\code{\link[=rdirichlet]{rdirichlet()}} +} +\concept{distributions} diff --git a/man/ptdiff.Rd b/man/ptdiff.Rd new file mode 100644 index 0000000..b747b57 --- /dev/null +++ b/man/ptdiff.Rd @@ -0,0 +1,95 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ptdiff.R +\name{ptdiff} +\alias{ptdiff} +\title{Distribution function of the difference of two t variables} +\usage{ +ptdiff( + q, + mu_t, + scale_t, + df_t, + mu_c, + scale_c, + df_c, + method = c("NI", "MM", "MC"), + nMC = 10000L, + lower.tail = TRUE +) +} +\arguments{ +\item{q}{Numeric vector of quantiles.} + +\item{mu_t, scale_t, df_t}{Location, positive scale and positive degrees of +freedom of the treatment group.} + +\item{mu_c, scale_c, df_c}{Location, positive scale and positive degrees of +freedom of the control group.} + +\item{method}{One of \code{"NI"} (default), \code{"MM"} or \code{"MC"}.} + +\item{nMC}{Number of Monte Carlo draws per element for \code{method = "MC"}.} + +\item{lower.tail}{Logical; if \code{TRUE} (default), probabilities are +\eqn{\Pr(T_t - T_c \le q)}, otherwise \eqn{\Pr(T_t - T_c > q)}.} +} +\value{ +A numeric vector of probabilities. All arguments from \code{q} to +\code{df_c} are recycled to a common length; each must have length 1 or +the common length. +} +\description{ +Computes \eqn{\Pr(T_t - T_c \le q)} (or the upper tail +\eqn{\Pr(T_t - T_c > q)}) for independent location-scale t variables +\eqn{T_k = \mu_k + s_k X_k}, where \eqn{X_k} follows a t distribution with +\eqn{\nu_k} degrees of freedom. This is the posterior (or posterior +predictive) probability used for a single continuous endpoint. +} +\details{ +Three methods are available. +\describe{ +\item{\code{"NI"}}{Numerical integration over the whole real line by +adaptive Gauss-Kronrod quadrature (the QUADPACK routine used by +\code{\link[stats]{integrate}}). The integral is taken over the +variable of the group with the smaller scale, for example +\eqn{\int f_c(u) \Pr(T_t > u + q) \, du} when +\eqn{s_c \le s_t}. The range is split around the peak of the density +and around the change of the other factor, and the parts far from the +origin are integrated on a logarithmic scale, so that heavy tails and +very different scales are handled. The absolute error is below +\eqn{10^{-9}} in the tests, which include scale ratios from +\eqn{10^{-9}} to \eqn{10^3} and degrees of freedom from 0.5 to +\code{Inf}.} +\item{\code{"MM"}}{The moment-matching approximation of Yamaguchi, +Homma, Takeda and Maruo (submitted, Theorem 1), which replaces the +difference by a single t +distribution with matched second and fourth moments. It requires +\eqn{\nu_t > 4} and \eqn{\nu_c > 4}, is evaluated in closed form, and is +the fastest method.} +\item{\code{"MC"}}{Monte Carlo simulation with \code{nMC} draws for each +element, using the random number generator of R.} +} +Degrees of freedom may be \code{Inf} (normal distributions). For the lower +tail, the upper tail of \eqn{T_c - T_t} at \eqn{-q} is computed, so both +tails are accurate near 0. +} +\examples{ +ptdiff(1, mu_t = 3, scale_t = 1, df_t = 15, mu_c = 1, scale_c = 1, + df_c = 15, lower.tail = FALSE) +ptdiff(1, mu_t = 3, scale_t = 1, df_t = 15, mu_c = 1, scale_c = 1, + df_c = 15, method = "MM", lower.tail = FALSE) +} +\references{ +Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Moment-matching approximation for t-differences in clinical trials with +continuous endpoints. +} +\seealso{ +Other distributions: +\code{\link[=cellprob_binary2]{cellprob_binary2()}}, +\code{\link[=pbetabinomdiff]{pbetabinomdiff()}}, +\code{\link[=pbetadiff]{pbetadiff()}}, +\code{\link[=psurvdiff]{psurvdiff()}}, +\code{\link[=rdirichlet]{rdirichlet()}} +} +\concept{distributions} diff --git a/man/ptdiff_MC.Rd b/man/ptdiff_MC.Rd deleted file mode 100644 index 549228c..0000000 --- a/man/ptdiff_MC.Rd +++ /dev/null @@ -1,100 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ptdiff_MC.R -\name{ptdiff_MC} -\alias{ptdiff_MC} -\title{Cumulative Distribution Function of the Difference of Two -Independent t-Distributed Variables via Monte Carlo Simulation} -\usage{ -ptdiff_MC(nMC, q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail = TRUE) -} -\arguments{ -\item{nMC}{A positive integer giving the number of Monte Carlo draws. -Typical values range from 10,000 (quick estimates) to 100,000 -or more (high precision). Larger values reduce Monte Carlo error -at the cost of computation time.} - -\item{q}{A numeric scalar representing the quantile threshold.} - -\item{mu_t}{A numeric scalar or vector giving the location parameter of -the t-distribution for the treatment group.} - -\item{mu_c}{A numeric scalar or vector giving the location parameter of -the t-distribution for the control group.} - -\item{sd_t}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the treatment group.} - -\item{sd_c}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the control group.} - -\item{nu_t}{A numeric scalar giving the degrees of freedom of the -t-distribution for the treatment group. -Must be greater than 2 for finite variance.} - -\item{nu_c}{A numeric scalar giving the degrees of freedom of the -t-distribution for the control group. -Must be greater than 2 for finite variance.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(T_t - T_c \le q)}, otherwise -\eqn{P(T_t - T_c > q)}.} -} -\value{ -A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -\code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -\eqn{n}, a vector of length \eqn{n} is returned. -} -\description{ -Calculates the cumulative distribution function (CDF) of the difference -between two independent non-standardised t-distributed random variables -using Monte Carlo simulation. Specifically, computes -\eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -\eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -} -\details{ -The algorithm proceeds as follows: -\enumerate{ -\item Generate an \code{nMC x n} matrix of standard t draws for -\eqn{T_t} (\eqn{\nu_t} degrees of freedom), then scale and shift -each column by \code{sd_t[i]} and \code{mu_t[i]}. -\item Repeat for \eqn{T_c} with \eqn{\nu_c} degrees of freedom. -\item Compute the \code{nMC x n} difference matrix -\eqn{D = T_t - T_c}. -\item Return \code{colMeans(D > q)} as the estimated -\eqn{P(T_t - T_c > q)} for each parameter set. -} - -All operations are matrix-based (no R-level loop over parameter sets), so -performance scales well with \eqn{n}. However, note that the matrix size -is \code{nMC x n}, so memory usage grows linearly with both \code{nMC} -and \eqn{n}. When \eqn{n} is large (e.g., \code{nsim x n_scenarios} in -\code{\link{pbayesdecisionprob1cont}}), memory requirements can become -prohibitive; in such cases prefer \code{CalcMethod = 'MM'}. - -Monte Carlo error is approximately -\eqn{\sqrt{p(1 - p) / \mathrm{nMC}}}; near \eqn{p = 0.5} this is -roughly \eqn{0.5 / \sqrt{\mathrm{nMC}}}. -} -\examples{ -# P(T_t - T_c > 3) with equal parameters -ptdiff_MC(nMC = 1e5, q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, - nu_t = 17, nu_c = 17, lower.tail = FALSE) - -# P(T_t - T_c > 1) with unequal scales -ptdiff_MC(nMC = 1e5, q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, - nu_t = 10, nu_c = 15, lower.tail = FALSE) - -# P(T_t - T_c > 0) with different degrees of freedom -ptdiff_MC(nMC = 1e5, q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 5, nu_c = 20, lower.tail = FALSE) - -# Lower tail: P(T_t - T_c <= 2) -ptdiff_MC(nMC = 1e5, q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, - nu_t = 12, nu_c = 15, lower.tail = TRUE) - -# Vectorised usage -ptdiff_MC(nMC = 1e5, q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), - sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), - nu_t = 10, nu_c = 10, lower.tail = FALSE) - -} diff --git a/man/ptdiff_MM.Rd b/man/ptdiff_MM.Rd deleted file mode 100644 index 61c0626..0000000 --- a/man/ptdiff_MM.Rd +++ /dev/null @@ -1,89 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ptdiff_MM.R -\name{ptdiff_MM} -\alias{ptdiff_MM} -\title{Cumulative Distribution Function of the Difference of Two -Independent t-Distributed Variables via Moment-Matching Approximation} -\usage{ -ptdiff_MM(q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail = TRUE) -} -\arguments{ -\item{q}{A numeric scalar representing the quantile threshold.} - -\item{mu_t}{A numeric scalar or vector giving the location parameter of -the t-distribution for the treatment group.} - -\item{mu_c}{A numeric scalar or vector giving the location parameter of -the t-distribution for the control group.} - -\item{sd_t}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the treatment group.} - -\item{sd_c}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the control group.} - -\item{nu_t}{A numeric scalar giving the degrees of freedom of the -t-distribution for the treatment group. -Must be greater than 4 for finite fourth moment.} - -\item{nu_c}{A numeric scalar giving the degrees of freedom of the -t-distribution for the control group. -Must be greater than 4 for finite fourth moment.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(T_t - T_c \le q)}, otherwise -\eqn{P(T_t - T_c > q)}.} -} -\value{ -A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -\code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -\eqn{n}, a vector of length \eqn{n} is returned. -} -\description{ -Calculates the cumulative distribution function (CDF) of the difference -between two independent non-standardised t-distributed random variables -using a Moment-Matching approximation. Specifically, computes -\eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -\eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -} -\details{ -The difference \eqn{D = T_t - T_c} is approximated by a single -non-standardised t-distribution -\eqn{t(\mu^*, {\sigma^*}^2, \nu^*)} whose parameters are determined by -matching the first two even moments of \eqn{D}: -\itemize{ -\item \eqn{\mu^* = \mu_t - \mu_c}. -\item \eqn{{\sigma^*}^2} is obtained from the second-moment equation. -\item \eqn{\nu^*} is obtained from the fourth-moment equation. -} - -The approximation requires \eqn{\nu_t > 4} and \eqn{\nu_c > 4} for -finite fourth moments. It is exact in the normal limit -(\eqn{\nu \to \infty}) and works well in practice when \eqn{\nu > 10}. -Because it reduces to a single call to \code{pt()}, it is orders of -magnitude faster than the numerical integration method -(\code{\link{ptdiff_NI}}) and is fully vectorised. -} -\examples{ -# P(T_t - T_c > 3) with equal parameters -ptdiff_MM(q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, - nu_t = 17, nu_c = 17, lower.tail = FALSE) - -# P(T_t - T_c > 1) with unequal scales -ptdiff_MM(q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, - nu_t = 10, nu_c = 15, lower.tail = FALSE) - -# P(T_t - T_c > 0) with different degrees of freedom -ptdiff_MM(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 5, nu_c = 20, lower.tail = FALSE) - -# Lower tail: P(T_t - T_c <= 2) -ptdiff_MM(q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, - nu_t = 12, nu_c = 15, lower.tail = TRUE) - -# Vectorised usage -ptdiff_MM(q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), - sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), - nu_t = 10, nu_c = 10, lower.tail = FALSE) - -} diff --git a/man/ptdiff_NI.Rd b/man/ptdiff_NI.Rd deleted file mode 100644 index 94bc6fb..0000000 --- a/man/ptdiff_NI.Rd +++ /dev/null @@ -1,96 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ptdiff_NI.R -\name{ptdiff_NI} -\alias{ptdiff_NI} -\title{Cumulative Distribution Function of the Difference of Two -Independent t-Distributed Variables via Numerical Integration} -\usage{ -ptdiff_NI(q, mu_t, mu_c, sd_t, sd_c, nu_t, nu_c, lower.tail = TRUE) -} -\arguments{ -\item{q}{A numeric scalar representing the quantile threshold.} - -\item{mu_t}{A numeric scalar or vector giving the location parameter of -the t-distribution for the treatment group.} - -\item{mu_c}{A numeric scalar or vector giving the location parameter of -the t-distribution for the control group.} - -\item{sd_t}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the treatment group.} - -\item{sd_c}{A positive numeric scalar or vector giving the scale parameter -of the t-distribution for the control group.} - -\item{nu_t}{A numeric scalar giving the degrees of freedom of the -t-distribution for the treatment group. -Must be greater than 2 for finite variance.} - -\item{nu_c}{A numeric scalar giving the degrees of freedom of the -t-distribution for the control group. -Must be greater than 2 for finite variance.} - -\item{lower.tail}{A logical scalar; if \code{TRUE} (default), the function -returns \eqn{P(T_t - T_c \le q)}, otherwise -\eqn{P(T_t - T_c > q)}.} -} -\value{ -A numeric scalar or vector in \code{[0, 1]}. When \code{mu_t}, -\code{mu_c}, \code{sd_t}, or \code{sd_c} are vectors of length -\eqn{n}, a vector of length \eqn{n} is returned. -} -\description{ -Calculates the cumulative distribution function (CDF) of the difference -between two independent non-standardised t-distributed random variables -using numerical integration. Specifically, computes -\eqn{P(T_t - T_c \le q)} or \eqn{P(T_t - T_c > q)}, where -\eqn{T_k \sim t(\mu_k, \sigma_k^2, \nu_k)} for \eqn{k \in \{t, c\}}. -} -\details{ -The upper-tail probability is obtained via the convolution formula: -\deqn{P(T_t - T_c > q) - = \int_{-\infty}^{\infty} - F_{t(\mu_c, \sigma_c^2, \nu_c)}(x - q)\, - f_{t(\mu_t, \sigma_t^2, \nu_t)}(x)\, dx} -where \eqn{f_{t(\mu_t, \sigma_t^2, \nu_t)}} is the density of \eqn{T_t} -and \eqn{F_{t(\mu_c, \sigma_c^2, \nu_c)}} is the CDF of \eqn{T_c}. -The integral is evaluated by adaptive Gauss-Kronrod quadrature via -\code{stats::integrate}. - -When the input parameters are vectors, \code{mapply} applies the scalar -integration function across all parameter sets. - -Advantages: -\itemize{ -\item Exact within numerical precision. -\item Handles arbitrary parameter combinations. -} -Computational note: this method is substantially slower than the -Moment-Matching approximation (\code{\link{ptdiff_MM}}) because it calls -\code{integrate()} once per parameter set. For large-scale simulation -(many parameter sets), prefer \code{CalcMethod = 'MM'} in -\code{\link{pbayesdecisionprob1cont}}. -} -\examples{ -# P(T_t - T_c > 3) with equal parameters -ptdiff_NI(q = 3, mu_t = 2, mu_c = 0, sd_t = 1, sd_c = 1, - nu_t = 17, nu_c = 17, lower.tail = FALSE) - -# P(T_t - T_c > 1) with unequal scales -ptdiff_NI(q = 1, mu_t = 5, mu_c = 3, sd_t = 2, sd_c = 1.5, - nu_t = 10, nu_c = 15, lower.tail = FALSE) - -# P(T_t - T_c > 0) with different degrees of freedom -ptdiff_NI(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 5, nu_c = 20, lower.tail = FALSE) - -# Lower tail: P(T_t - T_c <= 2) -ptdiff_NI(q = 2, mu_t = 3, mu_c = 0, sd_t = 1.5, sd_c = 1.2, - nu_t = 12, nu_c = 15, lower.tail = TRUE) - -# Vectorised usage -ptdiff_NI(q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), - sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), - nu_t = 10, nu_c = 10, lower.tail = FALSE) - -} diff --git a/man/qdm_boundary.Rd b/man/qdm_boundary.Rd new file mode 100644 index 0000000..f9cee49 --- /dev/null +++ b/man/qdm_boundary.Rd @@ -0,0 +1,137 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qdm_boundary.R +\name{qdm_boundary} +\alias{qdm_boundary} +\title{Decision boundary of a design} +\usage{ +qdm_boundary( + design, + n_t = NULL, + mean_t = NULL, + sd_t = NULL, + cov_t = NULL, + events_t = NULL, + exposure_t = NULL, + data_c = NULL, + seed = NULL +) +} +\arguments{ +\item{design}{A design created by \code{\link{design_binary}}, +\code{\link{design_continuous}}, \code{\link{design_continuous2}} or +\code{\link{design_tte}}.} + +\item{n_t}{Numbers of subjects in the treatment group (whole numbers); by +default that of the design. Several values are allowed for one binary +endpoint without a concurrent control group and for one continuous +endpoint. For a time-to-event endpoint, \code{n_t} only sets the default +numbers of events.} + +\item{mean_t}{Observed treatment means: a numeric vector for one +continuous endpoint, or a list of two numeric vectors (endpoints 1 and +2) for two continuous endpoints.} + +\item{sd_t}{Observed treatment standard deviations (one continuous +endpoint; positive).} + +\item{cov_t}{Observed treatment covariance matrix (two continuous +endpoints; a 2 x 2 positive definite matrix).} + +\item{events_t}{Numbers of events of the treatment group (time-to-event +endpoint; whole numbers); by default \code{0:n_t}.} + +\item{exposure_t}{Total observed times of the treatment group +(time-to-event endpoint; positive).} + +\item{data_c}{Observed data of the concurrent control group, created by +\code{\link{data_continuous}}, \code{\link{data_continuous2}} or +\code{\link{data_tte}}; required for those endpoints with a concurrent +control group and \code{NULL} otherwise.} + +\item{seed}{Random seed for probabilities computed by Monte Carlo +simulation, or \code{NULL} to use the current random number stream. If +given, the previous state of the random number generator is restored on +exit.} +} +\value{ +An object of class \code{c("qdm_boundary", "data.frame")}: the +grid (columns named as the arguments, and \code{y_t} and \code{y_c} for +binary data or \code{diff}, \code{diff1} and \code{diff2} for +differences of means), the columns \code{prob_go} and \code{prob_nogo} +(for two endpoints with a marginal rule, \code{prob_go1}, +\code{prob_go2}, \code{prob_nogo1} and \code{prob_nogo2}) and the +factor \code{decision}. The attributes \code{design} and \code{axes} +record the design and the columns and labels of the axes of the plot. +} +\description{ +Computes the decision of a design (Go, NoGo, Gray or Miss) for every point +of a grid of possible observed data of the treatment group, so that the +regions of the data that lead to each decision can be plotted +(\code{\link{plot.qdm_boundary}}). Unlike the operating characteristics, +the result does not depend on the true parameters: it shows which data +lead to which decision. +} +\details{ +The grid depends on the endpoint of the design: +\describe{ +\item{One binary endpoint}{With a concurrent control group, all numbers +of responders \eqn{y_t = 0, \ldots, n_t} and \eqn{y_c = 0, \ldots, n_c} +(\code{n_t} must be a single number; \eqn{n_c} is that of the design). +Without one, all \eqn{(n, y_t)} with \eqn{n} in \code{n_t} and +\eqn{y_t = 0, \ldots, n}, which shows how the boundary changes with the +sample size.} +\item{One continuous endpoint}{All combinations of \code{mean_t}, +\code{sd_t} and \code{n_t}, of which at most one of \code{sd_t} and +\code{n_t} may have more than one value (the horizontal axis). With a +concurrent control group, \code{data_c} gives the observed control +data and the vertical axis is the observed difference of the means.} +\item{Two continuous endpoints}{All combinations of the observed +treatment means of the two endpoints, \code{mean_t[[1]]} and +\code{mean_t[[2]]}, with the sample covariance matrix \code{cov_t} and +\code{n_t} subjects (a single number). With a concurrent control +group, \code{data_c} gives the observed control data and the axes are +the observed differences of the means.} +\item{One time-to-event endpoint}{All combinations of the numbers of +events \code{events_t} and the total observed times +\code{exposure_t} of the treatment group. With a concurrent control +group, \code{data_c} gives the observed control data.} +} +Two binary endpoints are not supported, because their decision depends on +the four cell counts and cannot be shown on two axes. + +The decision at each point is made as in \code{\link{qdm_decide}}. +Probabilities computed by Monte Carlo simulation (\code{method = "MC"}, +or posterior predictive probabilities of a time-to-event endpoint) make +the boundary irregular; deterministic methods give smooth boundaries. +} +\examples{ +# Single-arm study with a fixed control response rate of 0.2 +des <- design_binary( + n_t = 20, n_c = 0, prior_t = prior_beta(1, 1), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.05, + gamma_go = 0.8, gamma_nogo = 0.8), + fixed_c = 0.2 +) +b <- qdm_boundary(des, n_t = 10:30) +plot(b) + +# Continuous endpoint with a concurrent control group +des2 <- design_continuous( + n_t = 12, n_c = 12, + prior_t = prior_vague(), prior_c = prior_vague(), + criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, + gamma_go = 0.6, gamma_nogo = 0.7), + method = "MM" +) +b2 <- qdm_boundary(des2, mean_t = seq(-20, 60, by = 2), + sd_t = seq(10, 40, by = 2), + data_c = data_continuous(12, 0, 25)) +plot(b2) +} +\seealso{ +Other operations: +\code{\link[=qdm_calibrate]{qdm_calibrate()}}, +\code{\link[=qdm_decide]{qdm_decide()}}, +\code{\link[=qdm_oc]{qdm_oc()}} +} +\concept{operations} diff --git a/man/qdm_calibrate.Rd b/man/qdm_calibrate.Rd new file mode 100644 index 0000000..4982b27 --- /dev/null +++ b/man/qdm_calibrate.Rd @@ -0,0 +1,105 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qdm_calibrate.R +\name{qdm_calibrate} +\alias{qdm_calibrate} +\title{Calibration of the decision thresholds} +\usage{ +qdm_calibrate( + design, + scenario_go, + scenario_nogo, + target_go, + target_nogo, + grid = seq(0.01, 0.99, by = 0.01), + nsim = 10000L, + seed = NULL +) +} +\arguments{ +\item{design}{A design created by \code{\link{design_binary}}, +\code{\link{design_continuous}}, \code{\link{design_binary2}}, +\code{\link{design_continuous2}} or \code{\link{design_tte}}. Its +thresholds are replaced by the calibrated ones. For two endpoints with a +marginal rule (\code{rule = "and"} or \code{"or"}), the same threshold is +used for both endpoints.} + +\item{scenario_go, scenario_nogo}{Data frames with one row each, giving the +scenarios used to calibrate \eqn{\gamma_{go}} and \eqn{\gamma_{nogo}} +(see \code{\link{qdm_oc}} for the columns). For two binary endpoints, the +correlations must be feasible.} + +\item{target_go, target_nogo}{Upper bounds for the probabilities that the +Go criterion is met under \code{scenario_go} and that the NoGo criterion +is met under \code{scenario_nogo}, strictly between 0 and 1.} + +\item{grid}{Candidate thresholds, strictly between 0 and 1.} + +\item{nsim, seed}{As in \code{\link{qdm_oc}}. The probabilities for all +values of \code{grid} are computed from the same outcomes (simulated +studies or enumerated outcomes) and the same Monte Carlo draws.} +} +\value{ +An object of class \code{"qdm_calibration"}: a list with elements +\describe{ +\item{gamma_go, gamma_nogo}{The chosen thresholds (\code{NA} if no +value in \code{grid} meets the target).} +\item{prob_go, prob_nogo}{The probabilities that the Go criterion is +met under \code{scenario_go} and that the NoGo criterion is met under +\code{scenario_nogo}, at the chosen thresholds.} +\item{target_go, target_nogo}{The targets.} +\item{curve}{A data frame with the columns \code{gamma} (the grid), +\code{prob_go} and \code{prob_nogo} (the two probabilities at each +threshold).} +\item{oc}{A data frame of the decision probabilities with the chosen +thresholds under the two scenarios (\code{NULL} if a threshold was +not found).} +\item{design}{The design with the chosen thresholds (\code{NULL} if a +threshold was not found).} +\item{scenario_go, scenario_nogo, method}{The scenarios and the method +of computation.} +} +} +\description{ +Chooses the thresholds \eqn{\gamma_{go}} and \eqn{\gamma_{nogo}} of the +criterion of a design so that the probabilities of a false Go decision and +a false NoGo decision are controlled. +} +\details{ +The threshold \eqn{\gamma_{go}} is the smallest value in \code{grid} for +which the probability that the Go criterion is met under +\code{scenario_go} (typically a scenario with no or a small treatment +effect) is at most \code{target_go}. The threshold \eqn{\gamma_{nogo}} is +the smallest value in \code{grid} for which the probability that the NoGo +criterion is met under \code{scenario_nogo} (typically a scenario with the +expected treatment effect) is at most \code{target_nogo}. Both +probabilities decrease as the threshold increases, so the chosen thresholds +are the least strict ones that meet the targets. + +The decision probabilities of the design with the chosen thresholds are +computed under both scenarios. If \eqn{\gamma_{go} + \gamma_{nogo} \le 1} +(and, for two endpoints with the marginal rule \code{"or"}, for any +thresholds), Miss decisions (both criteria met) can occur, and a warning is +given when they have positive probability. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +cal <- qdm_calibrate(des, + scenario_go = data.frame(pi_t = 0.4, pi_c = 0.4), + scenario_nogo = data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.05, target_nogo = 0.2) +cal +plot(cal) +cal$design +} +\seealso{ +Other operations: +\code{\link[=qdm_boundary]{qdm_boundary()}}, +\code{\link[=qdm_decide]{qdm_decide()}}, +\code{\link[=qdm_oc]{qdm_oc()}} +} +\concept{operations} diff --git a/man/qdm_decide.Rd b/man/qdm_decide.Rd new file mode 100644 index 0000000..07be85a --- /dev/null +++ b/man/qdm_decide.Rd @@ -0,0 +1,103 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qdm_decide.R +\name{qdm_decide} +\alias{qdm_decide} +\title{Go/NoGo decision for observed data} +\usage{ +qdm_decide(design, data_t, data_c = NULL, seed = NULL) +} +\arguments{ +\item{design}{A design created by \code{\link{design_binary}}, +\code{\link{design_continuous}}, \code{\link{design_binary2}}, +\code{\link{design_continuous2}} or \code{\link{design_tte}}.} + +\item{data_t}{Observed data of the treatment group, created by +\code{\link{data_binary}}, \code{\link{data_continuous}}, +\code{\link{data_binary2}}, \code{\link{data_continuous2}} or +\code{\link{data_tte}} (matching the endpoint of the design).} + +\item{data_c}{Observed data of the concurrent control group, created by +the same function as \code{data_t}; \code{NULL} (the default) for a +design without a concurrent control group.} + +\item{seed}{Random seed for probabilities computed by Monte Carlo +simulation (a continuous design with \code{method = "MC"}, posterior +probabilities for two binary endpoints, or posterior predictive +probabilities for a time-to-event endpoint), or \code{NULL} to use the +current random number stream. If given, the previous state of the random +number generator is restored on exit. Not used otherwise.} +} +\value{ +An object of class \code{"qdm_decision"}: a list with elements +\describe{ +\item{decision}{\code{"Go"}, \code{"NoGo"}, \code{"Gray"} or +\code{"Miss"}.} +\item{prob_go, prob_nogo}{Probabilities of the Go and NoGo regions +(for two endpoints with a marginal rule, one probability per +endpoint).} +\item{prob_regions}{For two endpoints, the probabilities of all +regions (see \code{\link{qdm_regions}}); \code{NULL} otherwise.} +\item{met_go, met_nogo}{Whether the Go and NoGo criteria are met.} +\item{posterior_t, posterior_c}{Parameters of the posterior +distributions of the treatment and control groups: for a binary +endpoint, the Beta parameters \code{a} and \code{b}; for a +continuous endpoint, the Normal-Inverse-chi-squared parameters +\code{mu}, \code{kappa}, \code{nu} and \code{sigma} (on the standard +deviation scale), so that the mean has the distribution +\eqn{t_{\nu}(\mu, \sigma^2 / \kappa)}. For a hypothetical control, +\code{posterior_c} gives the distribution of the control mean in the +same form (see \code{\link{design_continuous}}). For two binary +endpoints, the Dirichlet parameters of the cells \code{"00"}, +\code{"01"}, \code{"10"} and \code{"11"}. For two continuous +endpoints, the Normal-Inverse-Wishart parameters \code{mu1}, +\code{mu2}, \code{kappa}, \code{nu} and the elements \code{L11}, +\code{L12} and \code{L22} of \eqn{\Lambda}, so that the mean has the +distribution \eqn{t_{\nu - 1}(\mu, \Lambda / (\kappa (\nu - 1)))}. +For a time-to-event endpoint, the shape and rate of the Gamma +distribution of the hazard. For a fixed control, \code{posterior_c} +is the fixed value (named \code{value}, or \code{value1} and +\code{value2} for two endpoints).} +\item{design, data_t, data_c}{The arguments.} +} +} +\description{ +Computes the probabilities of the Go and NoGo regions given the observed +proof-of-concept data, and makes the decision of a design. +} +\details{ +The decision is Go if only the Go criterion is met, NoGo if only the NoGo +criterion is met, Gray if neither is met, and Miss if both are met (see +\code{\link{criterion_posterior}} and \code{\link{criterion_predictive}}). +A probability that is below a threshold by less than \eqn{10^{-10}} is +treated as equal to the threshold, so that ties that arise in symmetric +settings are not decided by rounding errors. + +The sample sizes of the observed data may differ from those of the design, +which are used only by \code{\link{qdm_oc}} and \code{\link{qdm_calibrate}}. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +qdm_decide(des, data_t = data_binary(12, 9), data_c = data_binary(12, 4)) + +# Continuous endpoint +des2 <- design_continuous( + n_t = 12, n_c = 12, + prior_t = prior_vague(), prior_c = prior_vague(), + criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, + gamma_go = 0.6, gamma_nogo = 0.7) +) +qdm_decide(des2, data_t = data_continuous(12, 18, 25), + data_c = data_continuous(12, -12, 25)) +} +\seealso{ +Other operations: +\code{\link[=qdm_boundary]{qdm_boundary()}}, +\code{\link[=qdm_calibrate]{qdm_calibrate()}}, +\code{\link[=qdm_oc]{qdm_oc()}} +} +\concept{operations} diff --git a/man/qdm_oc.Rd b/man/qdm_oc.Rd new file mode 100644 index 0000000..e732d42 --- /dev/null +++ b/man/qdm_oc.Rd @@ -0,0 +1,159 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qdm_oc.R +\name{qdm_oc} +\alias{qdm_oc} +\title{Operating characteristics of a design} +\usage{ +qdm_oc(design, scenarios, nsim = 10000L, seed = NULL) +} +\arguments{ +\item{design}{A design created by \code{\link{design_binary}}, +\code{\link{design_continuous}}, \code{\link{design_binary2}}, +\code{\link{design_continuous2}} or \code{\link{design_tte}}.} + +\item{scenarios}{A data frame with one row per scenario. For a binary +endpoint the columns \code{pi_t} and \code{pi_c} give the true response +rates of the treatment and control groups. For a continuous endpoint the +columns \code{mu_t}, \code{sd_t}, \code{mu_c} and \code{sd_c} give the +true means and standard deviations. For two binary endpoints the columns +\code{pi_t1}, \code{pi_t2}, \code{rho_t}, \code{pi_c1}, \code{pi_c2} and +\code{rho_c} give the true response rates of endpoints 1 and 2 (strictly +between 0 and 1) and the correlation of the two endpoints in each group. +For two continuous endpoints the columns \code{mu_t1}, \code{mu_t2}, +\code{sd_t1}, \code{sd_t2}, \code{rho_t}, \code{mu_c1}, \code{mu_c2}, +\code{sd_c1}, \code{sd_c2} and \code{rho_c} give the true means, +standard deviations and correlation of the two endpoints in each group +(the correlation strictly between -1 and 1). +For a time-to-event endpoint the columns \code{median_t} and +\code{median_c} give the true median survival times (positive). +The columns of the control group are not needed for a design without a +concurrent control group. Other columns, such as labels, are kept in the +result.} + +\item{nsim}{Number of simulated studies per scenario for designs whose +operating characteristics are computed by simulation.} + +\item{seed}{Random seed for the simulation and for Monte Carlo estimates +of probabilities, or \code{NULL} to use the current random number +stream. If given, the previous state of the random number generator is +restored on exit.} +} +\value{ +An object of class \code{c("qdm_oc", "data.frame")}: the scenarios +with the columns \code{Go}, \code{NoGo}, \code{Gray} and \code{Miss} +added. The attributes \code{design} and \code{method} record the design +and the method of computation. +} +\description{ +Computes the probabilities of Go, NoGo, Gray and Miss decisions of a design +under scenarios for the true parameters. +} +\details{ +For a binary endpoint, all possible outcomes of the proof-of-concept study +are enumerated and the probabilities are exact (Kang et al., 2026, Section +4.3); \code{nsim} and \code{seed} are not used. + +For a continuous endpoint, \code{nsim} studies are simulated under each +scenario. Only the sufficient statistics are simulated: the sample mean +\eqn{\bar y = \mu + \sigma Z / \sqrt{n}} and the sample standard deviation +\eqn{s = \sigma \sqrt{X / (n - 1)}}, with \eqn{Z \sim N(0, 1)} and +\eqn{X \sim \chi^2_{n - 1}}. The same random numbers are used for all +scenarios, so the results change smoothly across scenarios. The +probabilities have a simulation standard error of at most +\eqn{0.5 / \sqrt{nsim}} (0.005 for the default \code{nsim}). For each +simulated study, the probabilities of the Go and NoGo regions are computed +by the method of the design (see \code{\link{design_continuous}}), of which +\code{method = "MM"} is the fastest. To explore many scenarios or designs, +\code{method = "MM"} or a smaller \code{nsim} gives results quickly; the +chosen design can then be checked with \code{method = "NI"} and the +default \code{nsim}. + +For two binary endpoints, all outcomes are enumerated (Yamaguchi et al., +submitted, equation A.5) or \code{nsim} studies are simulated, as specified +by \code{enumerate} in \code{\link{design_binary2}}. The response rates +and correlation of each group are converted to cell probabilities by +\code{\link{cellprob_binary2}}; a scenario whose correlation is outside the +feasible range for its response rates is not evaluable, and its +probabilities are \code{NA} (with a warning). + +For two continuous endpoints, \code{nsim} studies are simulated under each +scenario. Only the sufficient statistics are simulated: the sample means +\eqn{\bar y = \mu + L z / \sqrt{n}} and the matrix of sums of squares and +cross-products \eqn{S = L A A^T L^T}, where \eqn{L} is the Cholesky +factor of the covariance matrix of the scenario, \eqn{z} has two +independent standard normal elements and \eqn{A} is the Bartlett factor +of a Wishart distribution with \eqn{n - 1} degrees of freedom. The same +random numbers are used for all scenarios. + +For a time-to-event endpoint, \code{nsim} studies are simulated under each +scenario as specified by the conduct of the design (enrollment, dropout +and analysis time; see \code{\link{conduct_tte}}), with exponential event +times whose hazard is \eqn{\log(2) / M} for the median survival time +\eqn{M} of the scenario. The same random numbers are used for all +scenarios. With a predictive criterion, every simulated study needs +\code{nMC} simulated future studies (see \code{\link{design_tte}}), so +the computing time grows with \code{nsim} times \code{nMC}. + +The decision for each outcome is made as in \code{\link{qdm_decide}}. A +warning is given when Miss decisions (both criteria met) have positive +probability in some scenario. +} +\examples{ +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +oc <- qdm_oc(des, data.frame(pi_t = seq(0.2, 0.8, by = 0.1), pi_c = 0.4)) +oc +plot(oc) + +# Continuous endpoint (moment-matching approximation for speed) +des2 <- design_continuous( + n_t = 12, n_c = 12, + prior_t = prior_vague(), prior_c = prior_vague(), + criterion = criterion_posterior(theta_tv = 30, theta_mav = 15, + gamma_go = 0.6, gamma_nogo = 0.7), + method = "MM" +) +oc2 <- qdm_oc(des2, data.frame(mu_t = seq(0, 50, by = 10), sd_t = 25, + mu_c = 0, sd_c = 25), + nsim = 2000, seed = 1) +oc2 + +# Two binary endpoints (small nMC for speed) +des3 <- design_binary2( + n_t = 6, n_c = 6, + prior_t = prior_dirichlet(rep(0.25, 4)), + prior_c = prior_dirichlet(rep(0.25, 4)), + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.3, gamma_nogo = 0.4), + nMC = 2000 +) +effects <- expand.grid(theta1 = c(0, 0.15, 0.3), theta2 = c(0, 0.15, 0.3)) +oc3 <- qdm_oc(des3, data.frame(pi_t1 = 0.2 + effects$theta1, + pi_t2 = 0.2 + effects$theta2, rho_t = 0.3, + pi_c1 = 0.2, pi_c2 = 0.2, rho_c = 0.3), + seed = 1) +oc3 +plot(oc3) +} +\references{ +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. \emph{Journal of Biopharmaceutical Statistics}. +\doi{10.1080/10543406.2026.2655410} + +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. +} +\seealso{ +Other operations: +\code{\link[=qdm_boundary]{qdm_boundary()}}, +\code{\link[=qdm_calibrate]{qdm_calibrate()}}, +\code{\link[=qdm_decide]{qdm_decide()}} +} +\concept{operations} diff --git a/man/qdm_regions.Rd b/man/qdm_regions.Rd new file mode 100644 index 0000000..265cc3b --- /dev/null +++ b/man/qdm_regions.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/qdm_regions.R +\name{qdm_regions} +\alias{qdm_regions} +\title{Region numbers for two endpoints} +\usage{ +qdm_regions(prob = c("posterior", "predictive")) +} +\arguments{ +\item{prob}{Either \code{"posterior"} (nine regions) or \code{"predictive"} +(four regions).} +} +\value{ +A character matrix of region labels (printed without quotes), with +the conditions on endpoint 1 as column names and those on endpoint 2 as +row names. +} +\description{ +Shows how the regions used by the decision criteria for two endpoints are +numbered (Yamaguchi et al., submitted, Tables 1 and 2). +} +\details{ +For posterior probability, the target value (TV) and the minimum acceptable +value (MAV) of each endpoint divide the plane of \eqn{(\theta_1, \theta_2)} +into nine regions. Columns correspond to endpoint 1 and rows to endpoint 2. +For posterior predictive probability, the null values divide the plane into +four regions. +} +\examples{ +qdm_regions("posterior") +qdm_regions("predictive") +} +\references{ +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. +} diff --git a/man/rdirichlet.Rd b/man/rdirichlet.Rd index f25ef12..9e3db9f 100644 --- a/man/rdirichlet.Rd +++ b/man/rdirichlet.Rd @@ -2,81 +2,35 @@ % Please edit documentation in R/rdirichlet.R \name{rdirichlet} \alias{rdirichlet} -\title{Generate Random Samples from a Dirichlet Distribution} +\title{Random generation from the Dirichlet distribution} \usage{ rdirichlet(n, alpha) } \arguments{ -\item{n}{A positive integer specifying the number of random vectors to -generate.} +\item{n}{Number of draws (a whole number of at least 1).} -\item{alpha}{A numeric vector of length \eqn{K \ge 2} containing positive -concentration parameters of the Dirichlet distribution. -All elements must be strictly positive.} +\item{alpha}{Numeric vector of at least two positive concentration +parameters.} } \value{ -A numeric matrix of dimensions \code{n x K} where each row is one -random draw from the Dirichlet distribution, with all elements in -\code{[0, 1]} and each row summing to 1. -When \code{n = 1}, a numeric vector of length \code{K} is returned. +A numeric matrix with \code{n} rows and \code{length(alpha)} +columns whose rows sum to 1 (a matrix is returned even when +\code{n = 1}). Column names are taken from \code{names(alpha)}. } \description{ -Generates random samples from a Dirichlet distribution using the Gamma -representation: if \eqn{Y_i \sim \mathrm{Gamma}(\alpha_i, 1)} independently -for \eqn{i = 1, \ldots, K}, then -\eqn{(Y_1 / S, \ldots, Y_K / S) \sim \mathrm{Dirichlet}(\alpha_1, \ldots, \alpha_K)}, -where \eqn{S = \sum_{i=1}^{K} Y_i}. -} -\details{ -The Dirichlet distribution is a multivariate generalisation of the Beta -distribution and is commonly used as a conjugate prior for multinomial -proportions in Bayesian statistics. - -The probability density function is: -\deqn{f(x_1, \ldots, x_K) = - \frac{\Gamma\!\left(\sum_{i=1}^{K} \alpha_i\right)} - {\prod_{i=1}^{K} \Gamma(\alpha_i)} - \prod_{i=1}^{K} x_i^{\alpha_i - 1}} -where \eqn{x_i > 0} and \eqn{\sum_{i=1}^{K} x_i = 1}. - -Key properties: -\itemize{ -\item Each marginal follows a Beta distribution: -\eqn{X_i \sim \mathrm{Beta}\!\left(\alpha_i,\, - \sum_{l \neq i} \alpha_l\right)}. -\item \eqn{E[X_i] = \alpha_i / \sum_{l=1}^{K} \alpha_l}. -\item Components are negatively correlated unless one component dominates. -} - -Implementation steps: -\enumerate{ -\item Generate independent \eqn{Y_i \sim \mathrm{Gamma}(\alpha_i, 1)} for -each \eqn{i = 1, \ldots, K}. -\item Normalise: \eqn{X_i = Y_i / \sum_{l=1}^{K} Y_l}. -} +Draws random vectors from the Dirichlet distribution by normalizing +independent Gamma variables, using the random number generator of R. } \examples{ -# Example 1: Generate 5 samples from Dirichlet(1, 1, 1) - uniform on simplex -samples <- rdirichlet(5, c(1, 1, 1)) -print(samples) -rowSums(samples) # Each row should sum to 1 - -# Example 2: Generate samples with unequal concentrations -samples <- rdirichlet(1000, c(2, 5, 3)) -colMeans(samples) # Expected values: approximately c(0.2, 0.5, 0.3) - -# Example 3: Sparse Dirichlet (small alpha values) -samples <- rdirichlet(100, c(0.1, 0.1, 0.1, 0.1)) -head(samples) # Most weight concentrated on one component - -# Example 4: Concentrated Dirichlet (large alpha values) -samples <- rdirichlet(100, c(100, 100, 100)) -colMeans(samples) # Concentrated around c(1/3, 1/3, 1/3) - -# Example 5: Bayesian update with Jeffreys prior for 4 categories -prior_alpha <- c(0.5, 0.5, 0.5, 0.5) -observed_counts <- c(10, 5, 8, 7) -posterior_samples <- rdirichlet(1000, prior_alpha + observed_counts) -colMeans(posterior_samples) # Posterior mean - -} +set.seed(1) +rdirichlet(3, c(1.5, 0.5, 2, 1)) +} +\seealso{ +Other distributions: +\code{\link[=cellprob_binary2]{cellprob_binary2()}}, +\code{\link[=pbetabinomdiff]{pbetabinomdiff()}}, +\code{\link[=pbetadiff]{pbetadiff()}}, +\code{\link[=psurvdiff]{psurvdiff()}}, +\code{\link[=ptdiff]{ptdiff()}} +} +\concept{distributions} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp new file mode 100644 index 0000000..959a599 --- /dev/null +++ b/src/RcppExports.cpp @@ -0,0 +1,243 @@ +// Generated by using Rcpp::compileAttributes() -> do not edit by hand +// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +#include + +using namespace Rcpp; + +#ifdef RCPP_USE_GLOBAL_ROSTREAM +Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); +Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); +#endif + +// cpp_pbetadiff_upper +Rcpp::NumericVector cpp_pbetadiff_upper(Rcpp::NumericVector q, Rcpp::NumericVector a_t, Rcpp::NumericVector b_t, Rcpp::NumericVector a_c, Rcpp::NumericVector b_c); +RcppExport SEXP _BayesianQDM_cpp_pbetadiff_upper(SEXP qSEXP, SEXP a_tSEXP, SEXP b_tSEXP, SEXP a_cSEXP, SEXP b_cSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q(qSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type a_t(a_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type b_t(b_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type a_c(a_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type b_c(b_cSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_pbetadiff_upper(q, a_t, b_t, a_c, b_c)); + return rcpp_result_gen; +END_RCPP +} +// cpp_psurvdiff_upper +Rcpp::NumericVector cpp_psurvdiff_upper(Rcpp::NumericVector q, Rcpp::NumericVector t0, Rcpp::NumericVector a_t, Rcpp::NumericVector b_t, Rcpp::NumericVector a_c, Rcpp::NumericVector b_c); +RcppExport SEXP _BayesianQDM_cpp_psurvdiff_upper(SEXP qSEXP, SEXP t0SEXP, SEXP a_tSEXP, SEXP b_tSEXP, SEXP a_cSEXP, SEXP b_cSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q(qSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type t0(t0SEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type a_t(a_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type b_t(b_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type a_c(a_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type b_c(b_cSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_psurvdiff_upper(q, t0, a_t, b_t, a_c, b_c)); + return rcpp_result_gen; +END_RCPP +} +// cpp_ptdiff_mc_upper +Rcpp::NumericVector cpp_ptdiff_mc_upper(Rcpp::NumericVector q, Rcpp::NumericVector mu_t, Rcpp::NumericVector scale_t, Rcpp::NumericVector df_t, Rcpp::NumericVector mu_c, Rcpp::NumericVector scale_c, Rcpp::NumericVector df_c, int nMC); +RcppExport SEXP _BayesianQDM_cpp_ptdiff_mc_upper(SEXP qSEXP, SEXP mu_tSEXP, SEXP scale_tSEXP, SEXP df_tSEXP, SEXP mu_cSEXP, SEXP scale_cSEXP, SEXP df_cSEXP, SEXP nMCSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q(qSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_t(mu_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_t(scale_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_t(df_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_c(mu_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_c(scale_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_c(df_cSEXP); + Rcpp::traits::input_parameter< int >::type nMC(nMCSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_ptdiff_mc_upper(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC)); + return rcpp_result_gen; +END_RCPP +} +// cpp_ptdiff_mc_regions +Rcpp::NumericMatrix cpp_ptdiff_mc_regions(Rcpp::NumericVector q_go, Rcpp::NumericVector q_nogo, Rcpp::NumericVector mu_t, Rcpp::NumericVector scale_t, Rcpp::NumericVector df_t, Rcpp::NumericVector mu_c, Rcpp::NumericVector scale_c, Rcpp::NumericVector df_c, int nMC); +RcppExport SEXP _BayesianQDM_cpp_ptdiff_mc_regions(SEXP q_goSEXP, SEXP q_nogoSEXP, SEXP mu_tSEXP, SEXP scale_tSEXP, SEXP df_tSEXP, SEXP mu_cSEXP, SEXP scale_cSEXP, SEXP df_cSEXP, SEXP nMCSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q_go(q_goSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q_nogo(q_nogoSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_t(mu_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_t(scale_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_t(df_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_c(mu_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_c(scale_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_c(df_cSEXP); + Rcpp::traits::input_parameter< int >::type nMC(nMCSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_ptdiff_mc_regions(q_go, q_nogo, mu_t, scale_t, df_t, mu_c, scale_c, df_c, nMC)); + return rcpp_result_gen; +END_RCPP +} +// cpp_ptdiff_ni_upper +Rcpp::NumericVector cpp_ptdiff_ni_upper(Rcpp::NumericVector q, Rcpp::NumericVector mu_t, Rcpp::NumericVector scale_t, Rcpp::NumericVector df_t, Rcpp::NumericVector mu_c, Rcpp::NumericVector scale_c, Rcpp::NumericVector df_c); +RcppExport SEXP _BayesianQDM_cpp_ptdiff_ni_upper(SEXP qSEXP, SEXP mu_tSEXP, SEXP scale_tSEXP, SEXP df_tSEXP, SEXP mu_cSEXP, SEXP scale_cSEXP, SEXP df_cSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q(qSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_t(mu_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_t(scale_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_t(df_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu_c(mu_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type scale_c(scale_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_c(df_cSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_ptdiff_ni_upper(q, mu_t, scale_t, df_t, mu_c, scale_c, df_c)); + return rcpp_result_gen; +END_RCPP +} +// cpp_post_regions_binary2 +Rcpp::NumericMatrix cpp_post_regions_binary2(Rcpp::NumericMatrix alpha_t, Rcpp::NumericMatrix alpha_c, Rcpp::IntegerVector pair_t, Rcpp::IntegerVector pair_c, Rcpp::NumericVector tv, Rcpp::NumericVector mav, Rcpp::IntegerVector masks, int nMC, Rcpp::NumericVector value_c); +RcppExport SEXP _BayesianQDM_cpp_post_regions_binary2(SEXP alpha_tSEXP, SEXP alpha_cSEXP, SEXP pair_tSEXP, SEXP pair_cSEXP, SEXP tvSEXP, SEXP mavSEXP, SEXP masksSEXP, SEXP nMCSEXP, SEXP value_cSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type alpha_t(alpha_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type alpha_c(alpha_cSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type pair_t(pair_tSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type pair_c(pair_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type tv(tvSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mav(mavSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type masks(masksSEXP); + Rcpp::traits::input_parameter< int >::type nMC(nMCSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type value_c(value_cSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_post_regions_binary2(alpha_t, alpha_c, pair_t, pair_c, tv, mav, masks, nMC, value_c)); + return rcpp_result_gen; +END_RCPP +} +// cpp_pred_regions_binary2 +Rcpp::NumericMatrix cpp_pred_regions_binary2(Rcpp::NumericMatrix alpha_t, Rcpp::NumericMatrix alpha_c, Rcpp::IntegerVector pair_t, Rcpp::IntegerVector pair_c, int m_t, int m_c, Rcpp::NumericVector q, Rcpp::IntegerVector masks, Rcpp::NumericVector value_c); +RcppExport SEXP _BayesianQDM_cpp_pred_regions_binary2(SEXP alpha_tSEXP, SEXP alpha_cSEXP, SEXP pair_tSEXP, SEXP pair_cSEXP, SEXP m_tSEXP, SEXP m_cSEXP, SEXP qSEXP, SEXP masksSEXP, SEXP value_cSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type alpha_t(alpha_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type alpha_c(alpha_cSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type pair_t(pair_tSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type pair_c(pair_cSEXP); + Rcpp::traits::input_parameter< int >::type m_t(m_tSEXP); + Rcpp::traits::input_parameter< int >::type m_c(m_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type q(qSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type masks(masksSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type value_c(value_cSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_pred_regions_binary2(alpha_t, alpha_c, pair_t, pair_c, m_t, m_c, q, masks, value_c)); + return rcpp_result_gen; +END_RCPP +} +// cpp_regions_continuous2_mm +Rcpp::NumericMatrix cpp_regions_continuous2_mm(Rcpp::NumericMatrix loc_t, Rcpp::NumericMatrix scale_t, Rcpp::NumericVector df_t, Rcpp::NumericMatrix loc_c, Rcpp::NumericMatrix scale_c, Rcpp::NumericVector df_c, Rcpp::NumericVector tv, Rcpp::NumericVector mav, Rcpp::IntegerVector masks); +RcppExport SEXP _BayesianQDM_cpp_regions_continuous2_mm(SEXP loc_tSEXP, SEXP scale_tSEXP, SEXP df_tSEXP, SEXP loc_cSEXP, SEXP scale_cSEXP, SEXP df_cSEXP, SEXP tvSEXP, SEXP mavSEXP, SEXP masksSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type loc_t(loc_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type scale_t(scale_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_t(df_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type loc_c(loc_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type scale_c(scale_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_c(df_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type tv(tvSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mav(mavSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type masks(masksSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_regions_continuous2_mm(loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks)); + return rcpp_result_gen; +END_RCPP +} +// cpp_regions_continuous2_mc +Rcpp::NumericMatrix cpp_regions_continuous2_mc(Rcpp::NumericMatrix loc_t, Rcpp::NumericMatrix scale_t, Rcpp::NumericVector df_t, Rcpp::NumericMatrix loc_c, Rcpp::NumericMatrix scale_c, Rcpp::NumericVector df_c, Rcpp::NumericVector tv, Rcpp::NumericVector mav, Rcpp::IntegerVector masks, int nMC); +RcppExport SEXP _BayesianQDM_cpp_regions_continuous2_mc(SEXP loc_tSEXP, SEXP scale_tSEXP, SEXP df_tSEXP, SEXP loc_cSEXP, SEXP scale_cSEXP, SEXP df_cSEXP, SEXP tvSEXP, SEXP mavSEXP, SEXP masksSEXP, SEXP nMCSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type loc_t(loc_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type scale_t(scale_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_t(df_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type loc_c(loc_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericMatrix >::type scale_c(scale_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type df_c(df_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type tv(tvSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mav(mavSEXP); + Rcpp::traits::input_parameter< Rcpp::IntegerVector >::type masks(masksSEXP); + Rcpp::traits::input_parameter< int >::type nMC(nMCSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_regions_continuous2_mc(loc_t, scale_t, df_t, loc_c, scale_c, df_c, tv, mav, masks, nMC)); + return rcpp_result_gen; +END_RCPP +} +// cpp_tte_oc_data +Rcpp::NumericMatrix cpp_tte_oc_data(int nsim, int n_t, int n_c, Rcpp::NumericVector hazard_t, Rcpp::NumericVector hazard_c, Rcpp::NumericVector acc_time, Rcpp::NumericVector acc_cum, Rcpp::NumericVector drop_start, Rcpp::NumericVector drop_hazard, double cut_time, int cut_events); +RcppExport SEXP _BayesianQDM_cpp_tte_oc_data(SEXP nsimSEXP, SEXP n_tSEXP, SEXP n_cSEXP, SEXP hazard_tSEXP, SEXP hazard_cSEXP, SEXP acc_timeSEXP, SEXP acc_cumSEXP, SEXP drop_startSEXP, SEXP drop_hazardSEXP, SEXP cut_timeSEXP, SEXP cut_eventsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< int >::type nsim(nsimSEXP); + Rcpp::traits::input_parameter< int >::type n_t(n_tSEXP); + Rcpp::traits::input_parameter< int >::type n_c(n_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type hazard_t(hazard_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type hazard_c(hazard_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type acc_time(acc_timeSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type acc_cum(acc_cumSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type drop_start(drop_startSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type drop_hazard(drop_hazardSEXP); + Rcpp::traits::input_parameter< double >::type cut_time(cut_timeSEXP); + Rcpp::traits::input_parameter< int >::type cut_events(cut_eventsSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_tte_oc_data(nsim, n_t, n_c, hazard_t, hazard_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events)); + return rcpp_result_gen; +END_RCPP +} +// cpp_pred_tte +Rcpp::NumericVector cpp_pred_tte(Rcpp::NumericVector shape_t, Rcpp::NumericVector rate_t, Rcpp::NumericVector shape_c, Rcpp::NumericVector rate_c, double fixed_c, Rcpp::NumericVector prior_t, Rcpp::NumericVector prior_c, int m_t, int m_c, Rcpp::NumericVector acc_time, Rcpp::NumericVector acc_cum, Rcpp::NumericVector drop_start, Rcpp::NumericVector drop_hazard, double cut_time, int cut_events, double t0, double q, int nMC); +RcppExport SEXP _BayesianQDM_cpp_pred_tte(SEXP shape_tSEXP, SEXP rate_tSEXP, SEXP shape_cSEXP, SEXP rate_cSEXP, SEXP fixed_cSEXP, SEXP prior_tSEXP, SEXP prior_cSEXP, SEXP m_tSEXP, SEXP m_cSEXP, SEXP acc_timeSEXP, SEXP acc_cumSEXP, SEXP drop_startSEXP, SEXP drop_hazardSEXP, SEXP cut_timeSEXP, SEXP cut_eventsSEXP, SEXP t0SEXP, SEXP qSEXP, SEXP nMCSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type shape_t(shape_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type rate_t(rate_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type shape_c(shape_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type rate_c(rate_cSEXP); + Rcpp::traits::input_parameter< double >::type fixed_c(fixed_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type prior_t(prior_tSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type prior_c(prior_cSEXP); + Rcpp::traits::input_parameter< int >::type m_t(m_tSEXP); + Rcpp::traits::input_parameter< int >::type m_c(m_cSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type acc_time(acc_timeSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type acc_cum(acc_cumSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type drop_start(drop_startSEXP); + Rcpp::traits::input_parameter< Rcpp::NumericVector >::type drop_hazard(drop_hazardSEXP); + Rcpp::traits::input_parameter< double >::type cut_time(cut_timeSEXP); + Rcpp::traits::input_parameter< int >::type cut_events(cut_eventsSEXP); + Rcpp::traits::input_parameter< double >::type t0(t0SEXP); + Rcpp::traits::input_parameter< double >::type q(qSEXP); + Rcpp::traits::input_parameter< int >::type nMC(nMCSEXP); + rcpp_result_gen = Rcpp::wrap(cpp_pred_tte(shape_t, rate_t, shape_c, rate_c, fixed_c, prior_t, prior_c, m_t, m_c, acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events, t0, q, nMC)); + return rcpp_result_gen; +END_RCPP +} + +static const R_CallMethodDef CallEntries[] = { + {"_BayesianQDM_cpp_pbetadiff_upper", (DL_FUNC) &_BayesianQDM_cpp_pbetadiff_upper, 5}, + {"_BayesianQDM_cpp_psurvdiff_upper", (DL_FUNC) &_BayesianQDM_cpp_psurvdiff_upper, 6}, + {"_BayesianQDM_cpp_ptdiff_mc_upper", (DL_FUNC) &_BayesianQDM_cpp_ptdiff_mc_upper, 8}, + {"_BayesianQDM_cpp_ptdiff_mc_regions", (DL_FUNC) &_BayesianQDM_cpp_ptdiff_mc_regions, 9}, + {"_BayesianQDM_cpp_ptdiff_ni_upper", (DL_FUNC) &_BayesianQDM_cpp_ptdiff_ni_upper, 7}, + {"_BayesianQDM_cpp_post_regions_binary2", (DL_FUNC) &_BayesianQDM_cpp_post_regions_binary2, 9}, + {"_BayesianQDM_cpp_pred_regions_binary2", (DL_FUNC) &_BayesianQDM_cpp_pred_regions_binary2, 9}, + {"_BayesianQDM_cpp_regions_continuous2_mm", (DL_FUNC) &_BayesianQDM_cpp_regions_continuous2_mm, 9}, + {"_BayesianQDM_cpp_regions_continuous2_mc", (DL_FUNC) &_BayesianQDM_cpp_regions_continuous2_mc, 10}, + {"_BayesianQDM_cpp_tte_oc_data", (DL_FUNC) &_BayesianQDM_cpp_tte_oc_data, 11}, + {"_BayesianQDM_cpp_pred_tte", (DL_FUNC) &_BayesianQDM_cpp_pred_tte, 18}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_BayesianQDM(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff --git a/src/pbetadiff.cpp b/src/pbetadiff.cpp new file mode 100644 index 0000000..e912c33 --- /dev/null +++ b/src/pbetadiff.cpp @@ -0,0 +1,162 @@ +// Upper tail probability of the difference of two independent Beta +// variables, P(pi_t - pi_c > q), computed by adaptive Gauss-Kronrod +// quadrature (QUADPACK routine dqags, as used by stats::integrate()). +// +// The probability is the integral of f_c(x) P(pi_t > x + q) over the values +// of x with 0 <= x + q <= 1, plus P(pi_c < -q) when q < 0. The range is split +// at quantiles of both distributions so that concentrated distributions are +// integrated accurately. When the control density is unbounded at 0 +// (a_c < 1) or at 1 (b_c < 1), the integral on that side of the control +// median is computed in the variable s = x^a_c or s = (1 - x)^b_c, which +// removes the singularity. Without this change of variables, QUADPACK can +// return inaccurate results with small error estimates when a split point +// lies close to the singularity. + +#include +#include + +#include +#include +#include + +namespace { + +struct BetaDiffArgs { + double q; + double a_t; + double b_t; + double a_c; + double b_c; + double log_a_c; + double log_b_c; + double lbeta_c; + // Variable of integration: 0 = x, 1 = s = x^a_c, 2 = s = (1 - x)^b_c + int type; +}; + +// Integrand evaluated in place at the abscissae supplied by QUADPACK. +void beta_diff_integrand(double *x, int n, void *ex) { + const BetaDiffArgs *p = static_cast(ex); + for (int i = 0; i < n; ++i) { + double xi; + double weight; + if (p->type == 1) { + // x = s^(1 / a_c) and f_c(x) dx = (1 - x)^(b_c - 1) / (a_c B) ds + xi = std::pow(x[i], 1.0 / p->a_c); + weight = std::exp((p->b_c - 1.0) * std::log1p(-xi) - p->log_a_c - + p->lbeta_c); + } else if (p->type == 2) { + // 1 - x = s^(1 / b_c) and f_c(x) |dx| = x^(a_c - 1) / (b_c B) ds + xi = -std::expm1(std::log(x[i]) / p->b_c); + weight = std::exp((p->a_c - 1.0) * std::log(xi) - p->log_b_c - + p->lbeta_c); + } else { + xi = x[i]; + weight = R::dbeta(xi, p->a_c, p->b_c, 0); + } + x[i] = weight * R::pbeta(xi + p->q, p->a_t, p->b_t, 0, 0); + } +} + +// Integrates over [lo, hi] (lo < hi), which lies on one side of the control +// median, and records the largest error estimate and QUADPACK error code. +double integrate_segment(BetaDiffArgs &args, double lo, double hi, + double median, double &max_abserr, int &max_ier) { + const double mid = 0.5 * (lo + hi); + double a; + double b; + if (mid <= median && args.a_c < 1.0) { + args.type = 1; + a = std::pow(lo, args.a_c); + b = std::pow(hi, args.a_c); + } else if (mid > median && args.b_c < 1.0) { + args.type = 2; + a = std::pow(1.0 - hi, args.b_c); + b = std::pow(1.0 - lo, args.b_c); + } else { + args.type = 0; + a = lo; + b = hi; + } + double epsabs = 1e-13; + double epsrel = 1e-11; + double result = 0.0; + double abserr = 0.0; + int neval = 0; + int ier = 0; + int limit = 200; + int lenw = 4 * limit; + int last = 0; + std::vector iwork(limit); + std::vector work(lenw); + Rdqags(beta_diff_integrand, &args, &a, &b, &epsabs, &epsrel, &result, + &abserr, &neval, &ier, &limit, &lenw, &last, iwork.data(), + work.data()); + max_abserr = std::max(max_abserr, abserr); + max_ier = std::max(max_ier, ier); + return result; +} + +} // namespace + +// [[Rcpp::export]] +Rcpp::NumericVector cpp_pbetadiff_upper(Rcpp::NumericVector q, + Rcpp::NumericVector a_t, + Rcpp::NumericVector b_t, + Rcpp::NumericVector a_c, + Rcpp::NumericVector b_c) { + const R_xlen_t n = q.size(); + Rcpp::NumericVector out(n); + // Quantiles used to split the range of integration + const double probs[3] = {1e-12, 0.5, 1.0 - 1e-12}; + double max_abserr = 0.0; + int max_ier = 0; + for (R_xlen_t i = 0; i < n; ++i) { + BetaDiffArgs args = {q[i], a_t[i], b_t[i], a_c[i], b_c[i], + std::log(a_c[i]), std::log(b_c[i]), + R::lbeta(a_c[i], b_c[i]), 0}; + const double lo = std::max(0.0, -args.q); + const double hi = std::min(1.0, 1.0 - args.q); + const double median = R::qbeta(0.5, args.a_c, args.b_c, 1, 0); + double value = 0.0; + if (args.q < 0.0) { + // pi_c < -q implies pi_t - pi_c > q + value += R::pbeta(-args.q, args.a_c, args.b_c, 1, 0); + } + if (hi > lo) { + std::vector cut; + cut.push_back(lo); + cut.push_back(hi); + for (int k = 0; k < 3; ++k) { + const double xc = R::qbeta(probs[k], args.a_c, args.b_c, 1, 0); + const double xt = R::qbeta(probs[k], args.a_t, args.b_t, 1, 0) - + args.q; + if (xc > lo && xc < hi) { + cut.push_back(xc); + } + if (xt > lo && xt < hi) { + cut.push_back(xt); + } + } + std::sort(cut.begin(), cut.end()); + cut.erase(std::unique(cut.begin(), cut.end()), cut.end()); + for (std::size_t k = 0; k + 1 < cut.size(); ++k) { + value += integrate_segment(args, cut[k], cut[k + 1], median, + max_abserr, max_ier); + } + } + out[i] = std::min(1.0, std::max(0.0, value)); + if ((i + 1) % 1000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + // Warning for extreme parameter values for which QUADPACK reports a + // problem; not triggered by the tests (excluded from test coverage). + // # nocov start + if (max_ier > 0 && max_abserr > 1e-8) { + Rcpp::warning("Numerical integration may be inaccurate " + "(estimated absolute error %g).", max_abserr); + } + // # nocov end + return out; +} diff --git a/src/psurvdiff.cpp b/src/psurvdiff.cpp new file mode 100644 index 0000000..ae268c2 --- /dev/null +++ b/src/psurvdiff.cpp @@ -0,0 +1,189 @@ +// Upper tail probability of the difference of two milestone survival +// probabilities, P(S_t - S_c > q), where S_k = exp(-lambda_k t0) and the +// hazards lambda_t and lambda_c have independent Gamma distributions with +// shapes a_k and rates b_k. The probability is computed by adaptive +// Gauss-Kronrod quadrature (QUADPACK routine dqags, as used by +// stats::integrate()) over the control hazard. +// +// Given lambda_c, the event S_t - S_c > q is S_t > q + exp(-lambda_c t0), +// whose probability is 1 if q + exp(-lambda_c t0) <= 0, 0 if it is at least +// 1, and G_t(-log(q + exp(-lambda_c t0)) / t0) otherwise, where G_t is the +// distribution function of lambda_t. The probability is the integral of this +// conditional probability times the density of lambda_c over the values of +// lambda_c with 0 < q + exp(-lambda_c t0) < 1, plus P(S_c <= -q) when q < 0. +// The range is split at quantiles of the control hazard and at the values of +// lambda_c that correspond to quantiles of the treatment hazard, so that +// concentrated distributions are integrated accurately. When the control +// density is unbounded at 0 (a_c < 1), the integral below the control median +// is computed in the variable u = lambda_c^a_c, which removes the +// singularity. + +#include +#include + +#include +#include +#include +#include + +namespace { + +struct SurvDiffArgs { + double q; + double t0; + double a_t; + double b_t; + double a_c; + double b_c; + // log of b_c^a_c / Gamma(a_c + 1), used with u = lambda_c^a_c + double log_const; + // Variable of integration: 0 = lambda_c, 1 = u = lambda_c^a_c + int type; +}; + +// P(S_t > x) for the treatment hazard +inline double surv_upper(double x, const SurvDiffArgs *p) { + if (x <= 0.0) { + // Not reached: the range of integration excludes x <= 0 (a guard + // against rounding at its end; excluded from test coverage) + return 1.0; // # nocov + } + if (x >= 1.0) { + return 0.0; + } + return R::pgamma(-std::log(x) / p->t0, p->a_t, 1.0 / p->b_t, 1, 0); +} + +// Integrand evaluated in place at the abscissae supplied by QUADPACK. +void surv_diff_integrand(double *x, int n, void *ex) { + const SurvDiffArgs *p = static_cast(ex); + for (int i = 0; i < n; ++i) { + double lambda; + double weight; + if (p->type == 1) { + // lambda = u^(1 / a_c) and f_c(lambda) d lambda = + // b_c^a_c exp(-b_c lambda) / Gamma(a_c + 1) du + lambda = std::pow(x[i], 1.0 / p->a_c); + weight = std::exp(p->log_const - p->b_c * lambda); + } else { + lambda = x[i]; + weight = R::dgamma(lambda, p->a_c, 1.0 / p->b_c, 0); + } + x[i] = weight * surv_upper(p->q + std::exp(-lambda * p->t0), p); + } +} + +// Integrates over [lo, hi] (lo < hi), which lies on one side of the control +// median, and records the largest error estimate and QUADPACK error code. +double integrate_segment(SurvDiffArgs &args, double lo, double hi, + double median, double &max_abserr, int &max_ier) { + double a; + double b; + if (0.5 * (lo + hi) <= median && args.a_c < 1.0) { + args.type = 1; + a = std::pow(lo, args.a_c); + b = std::pow(hi, args.a_c); + } else { + args.type = 0; + a = lo; + b = hi; + } + double epsabs = 1e-13; + double epsrel = 1e-11; + double result = 0.0; + double abserr = 0.0; + int neval = 0; + int ier = 0; + int limit = 200; + int lenw = 4 * limit; + int last = 0; + std::vector iwork(limit); + std::vector work(lenw); + Rdqags(surv_diff_integrand, &args, &a, &b, &epsabs, &epsrel, &result, + &abserr, &neval, &ier, &limit, &lenw, &last, iwork.data(), + work.data()); + max_abserr = std::max(max_abserr, abserr); + max_ier = std::max(max_ier, ier); + return result; +} + +} // namespace + +// q, t0, a_t, b_t, a_c, b_c: vectors of the same length. +// Returns P(S_t - S_c > q) for each element. +// [[Rcpp::export]] +Rcpp::NumericVector cpp_psurvdiff_upper(Rcpp::NumericVector q, + Rcpp::NumericVector t0, + Rcpp::NumericVector a_t, + Rcpp::NumericVector b_t, + Rcpp::NumericVector a_c, + Rcpp::NumericVector b_c) { + const R_xlen_t n = q.size(); + Rcpp::NumericVector out(n); + // Quantiles used to split the range of integration + const double probs[3] = {1e-12, 0.5, 1.0 - 1e-12}; + double max_abserr = 0.0; + int max_ier = 0; + for (R_xlen_t i = 0; i < n; ++i) { + SurvDiffArgs args = {q[i], t0[i], a_t[i], b_t[i], a_c[i], b_c[i], + a_c[i] * std::log(b_c[i]) - R::lgammafn(a_c[i] + 1.0), + 0}; + double value = 0.0; + if (args.q <= -1.0) { + value = 1.0; + } else if (args.q < 1.0) { + const double scale_c = 1.0 / args.b_c; + // Range of lambda_c with 0 < q + exp(-lambda_c t0) < 1 + const double lo = args.q > 0.0 ? -std::log1p(-args.q) / args.t0 : 0.0; + double hi = std::numeric_limits::infinity(); + if (args.q < 0.0) { + hi = -std::log(-args.q) / args.t0; + // S_c <= -q, that is lambda_c >= hi, implies S_t - S_c > q + value += R::pgamma(hi, args.a_c, scale_c, 0, 0); + } + // The control density beyond this quantile is negligible + hi = std::min(hi, R::qgamma(1e-16, args.a_c, scale_c, 0, 0)); + if (hi > lo) { + const double median = R::qgamma(0.5, args.a_c, scale_c, 1, 0); + std::vector cut; + cut.push_back(lo); + cut.push_back(hi); + for (int k = 0; k < 3; ++k) { + const double xc = R::qgamma(probs[k], args.a_c, scale_c, 1, 0); + if (xc > lo && xc < hi) { + cut.push_back(xc); + } + // Control hazard at which the conditional probability is at the + // quantile of the treatment hazard + const double st = std::exp( + -R::qgamma(probs[k], args.a_t, 1.0 / args.b_t, 1, 0) * args.t0); + if (st - args.q > 0.0 && st - args.q < 1.0) { + const double xt = -std::log(st - args.q) / args.t0; + if (xt > lo && xt < hi) { + cut.push_back(xt); + } + } + } + std::sort(cut.begin(), cut.end()); + cut.erase(std::unique(cut.begin(), cut.end()), cut.end()); + for (std::size_t k = 0; k + 1 < cut.size(); ++k) { + value += integrate_segment(args, cut[k], cut[k + 1], median, + max_abserr, max_ier); + } + } + } + out[i] = std::min(1.0, std::max(0.0, value)); + if ((i + 1) % 1000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + // Warning for extreme parameter values for which QUADPACK reports a + // problem; not triggered by the tests (excluded from test coverage). + // # nocov start + if (max_ier > 0 && max_abserr > 1e-8) { + Rcpp::warning("Numerical integration may be inaccurate " + "(estimated absolute error %g).", max_abserr); + } + // # nocov end + return out; +} diff --git a/src/ptdiff_mc.cpp b/src/ptdiff_mc.cpp new file mode 100644 index 0000000..f402644 --- /dev/null +++ b/src/ptdiff_mc.cpp @@ -0,0 +1,33 @@ +// Monte Carlo estimate of the upper tail probability of the difference of two +// independent location-scale t variables, P(T_t - T_c > q), using the random +// number generator of R. + +#include + +// [[Rcpp::export]] +Rcpp::NumericVector cpp_ptdiff_mc_upper(Rcpp::NumericVector q, + Rcpp::NumericVector mu_t, + Rcpp::NumericVector scale_t, + Rcpp::NumericVector df_t, + Rcpp::NumericVector mu_c, + Rcpp::NumericVector scale_c, + Rcpp::NumericVector df_c, + int nMC) { + const R_xlen_t n = q.size(); + Rcpp::NumericVector out(n); + for (R_xlen_t i = 0; i < n; ++i) { + // T_t - T_c > q <=> s_t X_t - s_c X_c > q - (mu_t - mu_c) + const double threshold = q[i] - (mu_t[i] - mu_c[i]); + long count = 0; + for (int j = 0; j < nMC; ++j) { + const double d = scale_t[i] * R::rt(df_t[i]) - + scale_c[i] * R::rt(df_c[i]); + if (d > threshold) { + ++count; + } + } + out[i] = static_cast(count) / nMC; + Rcpp::checkUserInterrupt(); + } + return out; +} diff --git a/src/ptdiff_mc_regions.cpp b/src/ptdiff_mc_regions.cpp new file mode 100644 index 0000000..55962e4 --- /dev/null +++ b/src/ptdiff_mc_regions.cpp @@ -0,0 +1,46 @@ +// Monte Carlo estimates of the probabilities of the Go and NoGo regions of +// one continuous endpoint from the same draws of the difference of two +// independent location-scale t variables: +// go = P(T_t - T_c > q_go), nogo = P(T_t - T_c <= q_nogo). +// Because both probabilities use the same draws, go + nogo = 1 exactly when +// q_go = q_nogo (posterior predictive criterion) and go + nogo <= 1 when +// q_go > q_nogo (posterior criterion), as for the exact probabilities. + +#include + +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_ptdiff_mc_regions(Rcpp::NumericVector q_go, + Rcpp::NumericVector q_nogo, + Rcpp::NumericVector mu_t, + Rcpp::NumericVector scale_t, + Rcpp::NumericVector df_t, + Rcpp::NumericVector mu_c, + Rcpp::NumericVector scale_c, + Rcpp::NumericVector df_c, + int nMC) { + const int n = static_cast(q_go.size()); + Rcpp::NumericMatrix out(n, 2); + for (int i = 0; i < n; ++i) { + // T_t - T_c compared with q <=> s_t X_t - s_c X_c compared with + // q - (mu_t - mu_c) + const double shift = mu_t[i] - mu_c[i]; + const double thr_go = q_go[i] - shift; + const double thr_nogo = q_nogo[i] - shift; + long count_go = 0; + long count_nogo = 0; + for (int j = 0; j < nMC; ++j) { + const double d = scale_t[i] * R::rt(df_t[i]) - + scale_c[i] * R::rt(df_c[i]); + if (d > thr_go) { + ++count_go; + } + if (d <= thr_nogo) { + ++count_nogo; + } + } + out(i, 0) = static_cast(count_go) / nMC; + out(i, 1) = static_cast(count_nogo) / nMC; + Rcpp::checkUserInterrupt(); + } + return out; +} diff --git a/src/ptdiff_ni.cpp b/src/ptdiff_ni.cpp new file mode 100644 index 0000000..8d4e40f --- /dev/null +++ b/src/ptdiff_ni.cpp @@ -0,0 +1,183 @@ +// Upper tail probability of the difference of two independent location-scale +// t variables, P(T_t - T_c > q), computed by adaptive Gauss-Kronrod quadrature +// (QUADPACK routine dqags, as used by stats::integrate()). +// +// With T_k = mu_k + s_k X_k, the probability is written as an integral over +// the standardised variable of the group with the smaller scale: +// s_c <= s_t: P = int f_c(u) P(X_t > a + b u) du, +// a = (mu_c + q - mu_t) / s_t, b = s_c / s_t; +// s_c > s_t: P = int f_t(u) P(X_c < a + b u) du, +// a = (mu_t - mu_c - q) / s_c, b = s_t / s_c; +// so that b <= 1 and the second factor changes no faster than the density. +// The real line is split at -1, 0 and 1, at the midpoint u_half = -a / b of +// the change of the second factor, at u_half - 1 / b and u_half + 1 / b, and +// at the mirror images of these three points (where |b u| is comparable to +// |a|). Segments outside (-1, 1) whose ends differ by more than a factor of 2 +// are integrated in log(|u|), and the two tails beyond the outermost points c +// are integrated in w = c / u, which runs over (0, 1]. In these variables +// heavy tails and features far from the origin are integrated accurately. + +#include +#include + +#include +#include +#include + +namespace { + +struct TDiffArgs { + double a; + double b; + double df_int; // degrees of freedom of the variable of integration + double df_oth; // degrees of freedom of the other variable + int lower; // 1: P(X < a + b u); 0: P(X > a + b u) + // Variable of integration: 0 = u, 1 = s with u = exp(s), + // 2 = s with u = -exp(s), 3 = w with u = c / w + int type; + double c; +}; + +// Integrand evaluated in place at the abscissae supplied by QUADPACK. The +// density and the Jacobian are combined on the log scale, so that extreme +// values of the variable give 0 instead of 0 * Inf or NaN. +void t_diff_integrand(double *x, int n, void *ex) { + const TDiffArgs *p = static_cast(ex); + for (int i = 0; i < n; ++i) { + double u; + double log_jac; + if (p->type == 1) { + u = std::exp(x[i]); + log_jac = x[i]; + } else if (p->type == 2) { + u = -std::exp(x[i]); + log_jac = x[i]; + } else if (p->type == 3) { + u = p->c / x[i]; + log_jac = std::log(std::fabs(p->c)) - 2.0 * std::log(x[i]); + } else { + u = x[i]; + log_jac = 0.0; + } + const double log_dens = R::dt(u, p->df_int, 1) + log_jac; + x[i] = std::isfinite(log_dens) ? + std::exp(log_dens) * R::pt(p->a + p->b * u, p->df_oth, p->lower, 0) : + 0.0; + } +} + +// Integral of the integrand in the variable given by args.type over [lo, hi]. +double integrate_piece(TDiffArgs &args, double lo, double hi, + double &max_abserr, int &max_ier) { + double a = lo; + double b = hi; + double epsabs = 1e-13; + double epsrel = 1e-11; + double result = 0.0; + double abserr = 0.0; + int neval = 0; + int ier = 0; + int limit = 200; + int lenw = 4 * limit; + int last = 0; + std::vector iwork(limit); + std::vector work(lenw); + Rdqags(t_diff_integrand, &args, &a, &b, &epsabs, &epsrel, &result, &abserr, + &neval, &ier, &limit, &lenw, &last, iwork.data(), work.data()); + max_abserr = std::max(max_abserr, abserr); + max_ier = std::max(max_ier, ier); + return result; +} + +// Integral over the whole real line, split as described at the top. +double integrate_line(TDiffArgs &args, double &max_abserr, int &max_ier) { + std::vector cut; + cut.push_back(-1.0); + cut.push_back(0.0); + cut.push_back(1.0); + const double u_half = -args.a / args.b; + const double centres[2] = {u_half, -u_half}; + const double offsets[3] = {0.0, -1.0 / args.b, 1.0 / args.b}; + for (int k = 0; k < 2; ++k) { + for (int j = 0; j < 3; ++j) { + const double point = centres[k] + offsets[j]; + if (std::isfinite(point)) { + cut.push_back(point); + } + } + } + std::sort(cut.begin(), cut.end()); + cut.erase(std::unique(cut.begin(), cut.end()), cut.end()); + double value = 0.0; + // Tails beyond the outermost points, in w = c / u + args.type = 3; + args.c = cut.back(); + value += integrate_piece(args, 0.0, 1.0, max_abserr, max_ier); + args.c = cut.front(); + value += integrate_piece(args, 0.0, 1.0, max_abserr, max_ier); + for (std::size_t k = 0; k + 1 < cut.size(); ++k) { + const double lo = cut[k]; + const double hi = cut[k + 1]; + if (lo >= 1.0 && hi > 2.0 * lo) { + args.type = 1; + value += integrate_piece(args, std::log(lo), std::log(hi), max_abserr, + max_ier); + } else if (hi <= -1.0 && lo < 2.0 * hi) { + args.type = 2; + value += integrate_piece(args, std::log(-hi), std::log(-lo), + max_abserr, max_ier); + } else { + args.type = 0; + value += integrate_piece(args, lo, hi, max_abserr, max_ier); + } + } + return value; +} + +} // namespace + +// [[Rcpp::export]] +Rcpp::NumericVector cpp_ptdiff_ni_upper(Rcpp::NumericVector q, + Rcpp::NumericVector mu_t, + Rcpp::NumericVector scale_t, + Rcpp::NumericVector df_t, + Rcpp::NumericVector mu_c, + Rcpp::NumericVector scale_c, + Rcpp::NumericVector df_c) { + const R_xlen_t n = q.size(); + Rcpp::NumericVector out(n); + double max_abserr = 0.0; + int max_ier = 0; + for (R_xlen_t i = 0; i < n; ++i) { + TDiffArgs args; + if (scale_c[i] <= scale_t[i]) { + args.a = (mu_c[i] + q[i] - mu_t[i]) / scale_t[i]; + args.b = scale_c[i] / scale_t[i]; + args.df_int = df_c[i]; + args.df_oth = df_t[i]; + args.lower = 0; + } else { + args.a = (mu_t[i] - mu_c[i] - q[i]) / scale_c[i]; + args.b = scale_t[i] / scale_c[i]; + args.df_int = df_t[i]; + args.df_oth = df_c[i]; + args.lower = 1; + } + args.type = 0; + args.c = 0.0; + const double value = integrate_line(args, max_abserr, max_ier); + out[i] = std::min(1.0, std::max(0.0, value)); + if ((i + 1) % 1000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + // Warning for extreme parameter values for which QUADPACK reports a + // problem; not triggered by the tests (excluded from test coverage). + // # nocov start + if (max_ier > 0 && max_abserr > 1e-8) { + Rcpp::warning("Numerical integration may be inaccurate " + "(estimated absolute error %g).", max_abserr); + } + // # nocov end + return out; +} diff --git a/src/regions_binary2_post.cpp b/src/regions_binary2_post.cpp new file mode 100644 index 0000000..b3dd570 --- /dev/null +++ b/src/regions_binary2_post.cpp @@ -0,0 +1,163 @@ +// Posterior probabilities of unions of the nine regions of two binary +// endpoints (Yamaguchi et al., submitted, Table 1) by Monte Carlo simulation, +// for many pairs of treatment and control posterior distributions at once. +// +// The joint response probabilities of each group have a Dirichlet posterior +// distribution with parameters (a_00, a_01, a_10, a_11). In each of nMC +// iterations, one draw is made from every treatment and every control +// posterior distribution (as normalized Gamma variables, using the random +// number generator of R), and the marginal response rates +// pi_1 = p_10 + p_11 and pi_2 = p_01 + p_11 are computed. Every requested +// pair of treatment and control distributions is then classified into one of +// the nine regions of theta_k = pi_tk - pi_ck (k = 1, 2), so all pairs share +// the same draws. The region of a pair is 3 c_1 + c_2 (0-based), where c_k is +// 0 if theta_k > TV_k, 1 if MAV_k < theta_k <= TV_k and 2 if +// theta_k <= MAV_k. +// +// The draws are stored for blocks of iterations and every pair is then +// classified for the whole block, so that its counts stay in local variables; +// the draws and the counts are the same as when the pairs are classified +// after each iteration. +// +// With a fixed control (no control distributions), the marginal response +// rates of the control group are the fixed values, and only the treatment +// distributions are drawn. + +#include + +#include +#include + +namespace { + +// Marginal response rates of one Dirichlet draw with parameters a[0..3] in +// the cell order 00, 01, 10, 11. +inline void draw_margins(const double *a, double &pi1, double &pi2) { + double g[4]; + double total = 0.0; + for (int k = 0; k < 4; ++k) { + g[k] = R::rgamma(a[k], 1.0); + total += g[k]; + } + pi1 = (g[2] + g[3]) / total; + pi2 = (g[1] + g[3]) / total; +} + +// Band of theta: 0 if theta > tv, 1 if mav < theta <= tv and 2 if +// theta <= mav (tv > mav, as required by criterion_posterior()), computed +// without branches. +inline int band(double theta, double tv, double mav) { + return 2 - static_cast(theta > mav) - static_cast(theta > tv); +} + +} // namespace + +// alpha_t, alpha_c: Dirichlet parameters, one row per distribution. +// pair_t, pair_c: 0-based row indices of the pairs to evaluate. +// tv, mav: thresholds of the two endpoints. +// masks: one integer per union of regions; bit r (0 to 8) is set if region +// r + 1 belongs to the union. +// value_c: marginal response rates of a fixed control, used when alpha_c has +// no rows (pair_c is then not used). +// Returns the estimated probabilities, one row per pair and one column per +// union. +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_post_regions_binary2(Rcpp::NumericMatrix alpha_t, + Rcpp::NumericMatrix alpha_c, + Rcpp::IntegerVector pair_t, + Rcpp::IntegerVector pair_c, + Rcpp::NumericVector tv, + Rcpp::NumericVector mav, + Rcpp::IntegerVector masks, + int nMC, + Rcpp::NumericVector value_c) { + const int n_t = alpha_t.nrow(); + const int n_c = alpha_c.nrow(); + const bool fixed = n_c == 0; + const double vc1 = fixed ? value_c[0] : 0.0; + const double vc2 = fixed ? value_c[1] : 0.0; + const int n_pair = static_cast(pair_t.size()); + const int n_mask = static_cast(masks.size()); + // Parameters stored row by row for fast access + std::vector a_t(4 * static_cast(n_t)); + std::vector a_c(4 * static_cast(n_c)); + for (int i = 0; i < n_t; ++i) { + for (int k = 0; k < 4; ++k) { + a_t[4 * static_cast(i) + k] = alpha_t(i, k); + } + } + for (int j = 0; j < n_c; ++j) { + for (int k = 0; k < 4; ++k) { + a_c[4 * static_cast(j) + k] = alpha_c(j, k); + } + } + // For each region, the unions that contain it + std::vector > in_mask(9); + for (int r = 0; r < 9; ++r) { + for (int m = 0; m < n_mask; ++m) { + if ((masks[m] >> r) & 1) { + in_mask[r].push_back(m); + } + } + } + // Margins of the draws of a block of iterations, stored by distribution + // (row i holds the draws of distribution i in the iterations of the block) + const int block = 64; + std::vector pt1(static_cast(n_t) * block); + std::vector pt2(static_cast(n_t) * block); + std::vector pc1(static_cast(n_c) * block); + std::vector pc2(static_cast(n_c) * block); + // Counts by pair (row) and union (column) + std::vector count(static_cast(n_pair) * n_mask, 0); + const double tv1 = tv[0]; + const double tv2 = tv[1]; + const double mav1 = mav[0]; + const double mav2 = mav[1]; + for (int u0 = 0; u0 < nMC; u0 += block) { + const int nb = std::min(block, nMC - u0); + // Same order of draws as one iteration at a time: all treatment, then + // all control distributions + for (int b = 0; b < nb; ++b) { + for (int i = 0; i < n_t; ++i) { + const std::size_t k = static_cast(i) * block + b; + draw_margins(&a_t[4 * static_cast(i)], pt1[k], pt2[k]); + } + for (int j = 0; j < n_c; ++j) { + const std::size_t k = static_cast(j) * block + b; + draw_margins(&a_c[4 * static_cast(j)], pc1[k], pc2[k]); + } + } + for (int p = 0; p < n_pair; ++p) { + const std::size_t i = static_cast(pair_t[p]) * block; + int hist[9] = {0, 0, 0, 0, 0, 0, 0, 0, 0}; + if (fixed) { + for (int b = 0; b < nb; ++b) { + ++hist[3 * band(pt1[i + b] - vc1, tv1, mav1) + + band(pt2[i + b] - vc2, tv2, mav2)]; + } + } else { + const std::size_t j = static_cast(pair_c[p]) * block; + for (int b = 0; b < nb; ++b) { + ++hist[3 * band(pt1[i + b] - pc1[j + b], tv1, mav1) + + band(pt2[i + b] - pc2[j + b], tv2, mav2)]; + } + } + int *cnt = &count[static_cast(p) * n_mask]; + for (int r = 0; r < 9; ++r) { + const std::vector &ms = in_mask[r]; + for (std::size_t q = 0; q < ms.size(); ++q) { + cnt[ms[q]] += hist[r]; + } + } + } + Rcpp::checkUserInterrupt(); + } + Rcpp::NumericMatrix out(n_pair, n_mask); + for (int m = 0; m < n_mask; ++m) { + for (int p = 0; p < n_pair; ++p) { + out(p, m) = static_cast( + count[static_cast(p) * n_mask + m]) / nMC; + } + } + return out; +} diff --git a/src/regions_binary2_pred.cpp b/src/regions_binary2_pred.cpp new file mode 100644 index 0000000..eaf5521 --- /dev/null +++ b/src/regions_binary2_pred.cpp @@ -0,0 +1,213 @@ +// Posterior predictive probabilities of unions of the four regions of two +// binary endpoints (Yamaguchi et al., submitted, Table 2), computed exactly, +// for many pairs of treatment and control posterior distributions at once. +// +// Given Dirichlet parameters a, the future counts of the four cells among m +// subjects follow the Dirichlet-multinomial distribution. The future effects +// depend only on the numbers of responders S_1 = X_10 + X_11 and +// S_2 = X_01 + X_11, so the joint distribution of (S_1, S_2) is computed +// once for every distribution by summing the Dirichlet-multinomial +// probabilities over X_11. The future effect of endpoint k is +// S_tk / m_t - S_ck / m_c; it exceeds the null value q_k if and only if +// S_ck <= K_k(S_tk), where K_k(s) is the largest integer with +// (m_c s - m_t K_k(s)) / (m_t m_c) > q_k (this comparison of the exact +// difference with q_k is the same as in pbetabinomdiff(), so that a future +// effect equal to q_k is not counted as larger). The probabilities of the +// regions of a pair are then sums over (S_t1, S_t2) of the treatment +// probabilities times values of the bivariate distribution function of the +// control counts. +// +// Regions (0-based): 0 = both effects above the null values, 1 = endpoint 1 +// above and endpoint 2 not, 2 = endpoint 2 above and endpoint 1 not, +// 3 = neither. +// +// With a fixed control (no control distributions), the future effect of +// endpoint k is S_tk / m_t - v_k for the fixed response rate v_k. It exceeds +// the null value q_k if S_tk / m_t - v_k - q_k > 1e-10, so that a future +// effect that differs from q_k only by rounding errors is not counted as +// larger. + +#include + +#include +#include +#include + +namespace { + +// Joint probabilities of (S_1, S_2) for m future subjects, stored as +// out[s1 * (m + 1) + s2]. +void margin_probs(const double *a, int m, std::vector &out) { + const int w = m + 1; + std::fill(out.begin(), out.end(), 0.0); + // lg[k][c] = log Gamma(a_k + c) - log Gamma(a_k) - log Gamma(c + 1) + std::vector lg(4 * static_cast(w)); + double a_sum = 0.0; + for (int k = 0; k < 4; ++k) { + a_sum += a[k]; + const double base = R::lgammafn(a[k]); + for (int c = 0; c <= m; ++c) { + lg[k * static_cast(w) + c] = + R::lgammafn(a[k] + c) - base - R::lgammafn(c + 1.0); + } + } + const double lconst = R::lgammafn(m + 1.0) + R::lgammafn(a_sum) - + R::lgammafn(a_sum + m); + for (int s1 = 0; s1 <= m; ++s1) { + for (int s2 = 0; s2 <= m; ++s2) { + const int lo = std::max(0, s1 + s2 - m); + const int hi = std::min(s1, s2); + double total = 0.0; + for (int c11 = lo; c11 <= hi; ++c11) { + const int c10 = s1 - c11; + const int c01 = s2 - c11; + const int c00 = m - c10 - c01 - c11; + total += std::exp(lconst + lg[c00] + lg[w + c01] + lg[2 * w + c10] + + lg[3 * w + c11]); + } + out[static_cast(s1) * w + s2] = total; + } + } +} + +// K(s) for s = 0, ..., m_t: the largest integer k in [-1, m_c] with +// (m_c s - m_t k) / (m_t m_c) > q. +std::vector cut_points(int m_t, int m_c, double q) { + // The differences lie in [-1, 1], so values of q outside [-2, 2] give the + // same cut points as -2 or 2 (and would lose precision below) + q = std::min(std::max(q, -2.0), 2.0); + std::vector out(m_t + 1); + const double den = static_cast(m_t) * m_c; + for (int s = 0; s <= m_t; ++s) { + const double num = static_cast(m_c) * s; + const double k_est = std::floor((num - q * den) / m_t); + double k_max = -1.0; + for (int shift = -1; shift <= 1; ++shift) { + const double cand = k_est + shift; + if ((num - m_t * cand) / den > q && cand > k_max) { + k_max = cand; + } + } + k_max = std::min(std::max(k_max, -1.0), static_cast(m_c)); + out[s] = static_cast(k_max); + } + return out; +} + +} // namespace + +// alpha_t, alpha_c: Dirichlet parameters, one row per distribution. +// pair_t, pair_c: 0-based row indices of the pairs to evaluate. +// m_t, m_c: numbers of future subjects; q: null values of the two endpoints. +// masks: one integer per union of regions; bit r (0 to 3) is set if region +// r + 1 belongs to the union. +// value_c: marginal response rates of a fixed control, used when alpha_c has +// no rows (pair_c and m_c are then not used). +// Returns the probabilities, one row per pair and one column per union. +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_pred_regions_binary2(Rcpp::NumericMatrix alpha_t, + Rcpp::NumericMatrix alpha_c, + Rcpp::IntegerVector pair_t, + Rcpp::IntegerVector pair_c, + int m_t, int m_c, + Rcpp::NumericVector q, + Rcpp::IntegerVector masks, + Rcpp::NumericVector value_c) { + const int n_t = alpha_t.nrow(); + const int n_c = alpha_c.nrow(); + const bool fixed = n_c == 0; + const int n_pair = static_cast(pair_t.size()); + const int n_mask = static_cast(masks.size()); + const int wt = m_t + 1; + const int wc = m_c + 2; // control distribution function, index shift 1 + // Treatment probabilities of (S_t1, S_t2) + std::vector prob_t(static_cast(n_t) * wt * wt); + std::vector buf_t(static_cast(wt) * wt); + double a[4]; + for (int i = 0; i < n_t; ++i) { + for (int k = 0; k < 4; ++k) { + a[k] = alpha_t(i, k); + } + margin_probs(a, m_t, buf_t); + std::copy(buf_t.begin(), buf_t.end(), + prob_t.begin() + static_cast(i) * wt * wt); + } + // Control distribution functions F(x, y) = P(S_c1 <= x, S_c2 <= y) for + // x, y = -1, ..., m_c, stored as cdf_c[(x + 1) * wc + (y + 1)] + std::vector cdf_c(static_cast(n_c) * wc * wc, 0.0); + std::vector buf_c(static_cast(m_c + 1) * (m_c + 1)); + for (int j = 0; j < n_c; ++j) { + for (int k = 0; k < 4; ++k) { + a[k] = alpha_c(j, k); + } + margin_probs(a, m_c, buf_c); + double *f = &cdf_c[static_cast(j) * wc * wc]; + for (int x = 0; x <= m_c; ++x) { + double row = 0.0; + for (int y = 0; y <= m_c; ++y) { + row += buf_c[static_cast(x) * (m_c + 1) + y]; + f[(x + 1) * wc + (y + 1)] = f[x * wc + (y + 1)] + row; + } + } + } + const std::vector k1 = cut_points(m_t, m_c, q[0]); + const std::vector k2 = cut_points(m_t, m_c, q[1]); + // Fixed control: whether S_tk / m_t - v_k exceeds q_k + std::vector up1(m_t + 1, 0); + std::vector up2(m_t + 1, 0); + if (fixed) { + for (int s = 0; s <= m_t; ++s) { + const double rate = static_cast(s) / m_t; + up1[s] = (rate - value_c[0]) - q[0] > 1e-10; + up2[s] = (rate - value_c[1]) - q[1] > 1e-10; + } + } + Rcpp::NumericMatrix out(n_pair, n_mask); + for (int p = 0; p < n_pair; ++p) { + const double *pt = &prob_t[static_cast(pair_t[p]) * wt * wt]; + double both = 0.0; + double above1 = 0.0; + double above2 = 0.0; + if (fixed) { + for (int s1 = 0; s1 <= m_t; ++s1) { + for (int s2 = 0; s2 <= m_t; ++s2) { + const double w = pt[s1 * wt + s2]; + both += w * up1[s1] * up2[s2]; + above1 += w * up1[s1]; + above2 += w * up2[s2]; + } + } + } else { + const double *f = + &cdf_c[static_cast(pair_c[p]) * wc * wc]; + for (int s1 = 0; s1 <= m_t; ++s1) { + const int x = k1[s1] + 1; + for (int s2 = 0; s2 <= m_t; ++s2) { + const double w = pt[s1 * wt + s2]; + const int y = k2[s2] + 1; + both += w * f[x * wc + y]; + above1 += w * f[x * wc + (m_c + 1)]; + above2 += w * f[(m_c + 1) * wc + y]; + } + } + } + double region[4]; + region[0] = both; + region[1] = above1 - both; + region[2] = above2 - both; + region[3] = 1.0 - above1 - above2 + both; + for (int m = 0; m < n_mask; ++m) { + double total = 0.0; + for (int r = 0; r < 4; ++r) { + if ((masks[m] >> r) & 1) { + total += region[r]; + } + } + out(p, m) = std::min(1.0, std::max(0.0, total)); + } + if ((p + 1) % 10000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + return out; +} diff --git a/src/regions_continuous2.cpp b/src/regions_continuous2.cpp new file mode 100644 index 0000000..3c3d785 --- /dev/null +++ b/src/regions_continuous2.cpp @@ -0,0 +1,415 @@ +// Region probabilities of two continuous endpoints (Yamaguchi et al., +// submitted, Appendix A.2) for many pairs of distributions of the treatment +// and control group means at once. +// +// The mean of each group has a bivariate t distribution t_nu(loc, V) +// (posterior distribution of the mean, or posterior predictive distribution +// of the mean of future subjects). The effect theta = mean_t - mean_c is +// classified into the nine regions of Table 1 of the article: region +// 3 c_1 + c_2 (0-based), where c_k is 0 if theta_k > TV_k, 1 if +// MAV_k < theta_k <= TV_k and 2 if theta_k <= MAV_k. The four regions of a +// predictive criterion are the regions 0, 2, 6 and 8 with TV_k = MAV_k = +// null value. +// +// Two methods are provided: +// - moment matching: theta is approximated by a bivariate t distribution +// with the moments of Yamaguchi et al. (submitted, Moment_matching +// article, Theorem 3), and the probabilities of the regions are obtained +// from its distribution function, computed for real degrees of freedom by +// Gauss-Legendre quadrature (see bvt_cdf()); +// - Monte Carlo simulation: nMC draws from each distribution, independently +// for each pair. +// For a fixed control (a control scale matrix of zeros), theta has the +// bivariate t distribution of the treatment mean shifted by the fixed +// values, and the moment-matching function computes the exact probabilities +// from its distribution function. + +#include + +#include +#include +#include + +namespace { + +// Positive nodes and weights of the 48-point Gauss-Legendre rule on [-1, 1] +const double kGLx[24] = { + 0.032380170962869367, + 0.097004699209462697, + 0.16122235606889171, + 0.22476379039468905, + 0.28736248735545555, + 0.3487558862921607, + 0.40868648199071672, + 0.46690290475095841, + 0.523160974722233, + 0.57722472608397268, + 0.6288673967765136, + 0.67787237963266389, + 0.72403413092381463, + 0.76715903251574036, + 0.80706620402944262, + 0.84358826162439349, + 0.87657202027424785, + 0.90587913671556963, + 0.93138669070655433, + 0.9529877031604308, + 0.97059159254624727, + 0.98412458372282685, + 0.99353017226635076, + 0.99877100725242607}; +const double kGLw[24] = { + 0.064737696812683654, + 0.064466164435949824, + 0.063924238584647866, + 0.063114192286253729, + 0.062039423159892422, + 0.060704439165893603, + 0.059114839698395344, + 0.057277292100402916, + 0.055199503699984033, + 0.052890189485193438, + 0.050359035553854202, + 0.047616658492490242, + 0.044674560856694231, + 0.041545082943464547, + 0.038241351065830501, + 0.034777222564770394, + 0.031167227832798097, + 0.027426509708357034, + 0.023570760839324047, + 0.019616160457356056, + 0.015579315722943226, + 0.011477234579234614, + 0.007327553901276135, + 0.0031533460523098414}; + +const double kHalfPi = 1.5707963267948966; + +// Integrand of bvt_cdf() at phi: density of X at u = tan(phi) times +// d u / d phi times the conditional distribution function of Y at k. +double bvt_integrand(double phi, double k, double rho, double nu, double s) { + const double u = std::tan(phi); + const double c = std::cos(phi); + const double scale = s * std::sqrt(nu + u * u); + const double num = k - rho * u; + double cond; + if (scale > 0.0) { + cond = R::pt(num / scale, nu + 1.0, 1, 0); + } else { + // # nocov start + // Degenerate distribution (|rho| = 1): not reached for positive + // definite scale matrices + cond = num > 0.0 ? 1.0 : 0.0; + // # nocov end + } + return R::dt(u, nu, 0) / (c * c) * cond; +} + +// Integral over phi in (a, b) of the integrand of bvt_cdf() with the +// 48-point Gauss-Legendre rule. With graded = true, the variable is +// phi = a + (b - a) t^4 with t in (0, 1): near phi = -pi / 2 the integrand +// behaves like (phi + pi / 2)^(nu - 1), whose fractional powers for small +// nu are integrated inaccurately in phi, and t^(4 nu - 1) is smooth enough. +double bvt_piece(double a, double b, double k, double rho, double nu, + bool graded = false) { + const double s = std::sqrt((1.0 - rho * rho) / (nu + 1.0)); + double total = 0.0; + for (int i = 0; i < 24; ++i) { + for (int sign = -1; sign <= 1; sign += 2) { + if (graded) { + const double t = 0.5 + 0.5 * sign * kGLx[i]; + const double t3 = t * t * t; + total += kGLw[i] * 4.0 * t3 * + bvt_integrand(a + (b - a) * t3 * t, k, rho, nu, s); + } else { + total += kGLw[i] * + bvt_integrand(0.5 * (b + a) + sign * 0.5 * (b - a) * kGLx[i], k, + rho, nu, s); + } + } + } + return 0.5 * (b - a) * total; +} + +// P(X <= h, Y <= k) for the standard bivariate t distribution with +// correlation rho and nu (real, positive) degrees of freedom, for finite h +// and k. Conditionally on X = u, Y has a t distribution with nu + 1 degrees +// of freedom, location rho u and scale sqrt((nu + u^2) (1 - rho^2) / +// (nu + 1)), so the probability is the integral over u < h of the density +// of X times the conditional distribution function at k. With u = tan(phi) +// the range becomes (-pi / 2, atan(h)); it is split at 0 and at the point +// where rho u = k, and each part is integrated with the 48-point +// Gauss-Legendre rule (error below 1e-10 for nu > 4 and |rho| <= 0.99; the +// error grows to about 1e-8 at |rho| = 0.999 and 1e-6 at |rho| = 0.9999, +// where the conditional distribution function changes within a narrow +// range of u). For nu <= 4 (a fixed control with few degrees of freedom), +// the part that starts at -pi / 2 is integrated in a graded variable (see +// bvt_piece()). +double bvt_cdf(double h, double k, double rho, double nu) { + const double lo = -kHalfPi; + const double hi = std::atan(h); + double cuts[4]; + int n_cut = 0; + cuts[n_cut++] = lo; + if (rho != 0.0) { + const double c = std::atan(k / rho); + if (c > lo && c < hi) { + cuts[n_cut++] = c; + } + } + if (0.0 < hi) { + cuts[n_cut++] = 0.0; + } + std::sort(cuts + 1, cuts + n_cut); + cuts[n_cut++] = hi; + double total = 0.0; + for (int i = 0; i + 1 < n_cut; ++i) { + if (cuts[i + 1] > cuts[i]) { + total += bvt_piece(cuts[i], cuts[i + 1], k, rho, nu, + i == 0 && nu <= 4.0); + } + } + return total; +} + +// Coefficients of the distribution function F(x_i, y_j) on the grid +// x = (-Inf, MAV_1, TV_1, Inf), y = (-Inf, MAV_2, TV_2, Inf) for the union +// of the regions in a mask (bit r set: region r, 0-based). +void mask_coefficients(int mask, double coef[4][4]) { + for (int i = 0; i < 4; ++i) { + for (int j = 0; j < 4; ++j) { + coef[i][j] = 0.0; + } + } + for (int r = 0; r < 9; ++r) { + if (!((mask >> r) & 1)) { + continue; + } + // Band from the bottom: 0 (<= MAV), 1 (MAV, TV], 2 (> TV) + const int bx = 2 - r / 3; + const int by = 2 - r % 3; + coef[bx + 1][by + 1] += 1.0; + coef[bx][by + 1] -= 1.0; + coef[bx + 1][by] -= 1.0; + coef[bx][by] += 1.0; + } +} + +// Moment matching (Yamaguchi, Homma, Takeda and Maruo, submitted, Theorem 3 +// with dimension 2): the difference of independent bivariate t variables +// with n1 and n2 degrees of freedom and scale matrices v1 and v2 (elements +// V11, V12, V22) is approximated by a bivariate t distribution with nu +// degrees of freedom, standard deviations sd1 and sd2 of the scaled +// variables and correlation rho. +void moment_match(double n1, double n2, const double v1[3], + const double v2[3], double &nu, double &sd1, double &sd2, + double &rho) { + const double b1 = n1 / (n1 - 2.0); + const double b2 = n2 / (n2 - 2.0); + const double s11 = b1 * v1[0] + b2 * v2[0]; + const double s12 = b1 * v1[1] + b2 * v2[1]; + const double s22 = b1 * v1[2] + b2 * v2[2]; + const double det = s11 * s22 - s12 * s12; + // A = inverse of the summed covariance matrix + const double a11 = s22 / det; + const double a12 = -s12 / det; + const double a22 = s11 / det; + // P = A V1 and Q = A V2 (2 x 2, not symmetric) + const double p11 = a11 * v1[0] + a12 * v1[1]; + const double p12 = a11 * v1[1] + a12 * v1[2]; + const double p21 = a12 * v1[0] + a22 * v1[1]; + const double p22 = a12 * v1[1] + a22 * v1[2]; + const double q11 = a11 * v2[0] + a12 * v2[1]; + const double q12 = a11 * v2[1] + a12 * v2[2]; + const double q21 = a12 * v2[0] + a22 * v2[1]; + const double q22 = a12 * v2[1] + a22 * v2[2]; + const double t1 = p11 + p22; + const double t2 = q11 + q22; + const double t11 = p11 * p11 + 2.0 * p12 * p21 + p22 * p22; + const double t22 = q11 * q11 + 2.0 * q12 * q21 + q22 * q22; + const double t12 = p11 * q11 + p12 * q21 + p21 * q12 + p22 * q22; + const double qm = + (n1 * n1 / ((n1 - 2.0) * (n1 - 4.0)) * (t1 * t1 + 2.0 * t11) + + n2 * n2 / ((n2 - 2.0) * (n2 - 4.0)) * (t2 * t2 + 2.0 * t22) + + 2.0 * n1 * n2 / ((n1 - 2.0) * (n2 - 2.0)) * (t1 * t2 + 2.0 * t12)) / + 8.0; + // qm > 1 for finite degrees of freedom; very large degrees of freedom + // are capped (the distribution is then normal to double precision) + nu = 1e10; + if (qm > 1.0) { + nu = std::min((2.0 - 4.0 * qm) / (1.0 - qm), 1e10); + } + const double f = (nu - 2.0) / nu; + sd1 = std::sqrt(s11 * f); + sd2 = std::sqrt(s22 * f); + rho = s12 / std::sqrt(s11 * s22); +} + +} // namespace + +// loc_t, loc_c: locations (one row per pair, two columns). +// scale_t, scale_c: scale matrices (one row per pair; columns V11, V12, V22). +// df_t, df_c: degrees of freedom (one per pair, all greater than 4). +// tv, mav: the thresholds TV and MAV of the two endpoints. +// masks: one integer per union of regions (bit r: region r + 1). +// Returns the probabilities of the unions by moment matching, one row per +// pair and one column per union. A row of scale_c with all elements 0 is a +// fixed control at loc_c: theta then has the bivariate t distribution of the +// treatment mean shifted by loc_c, the probabilities are exact, df_c is not +// used and df_t only needs to be positive. +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_regions_continuous2_mm(Rcpp::NumericMatrix loc_t, + Rcpp::NumericMatrix scale_t, + Rcpp::NumericVector df_t, + Rcpp::NumericMatrix loc_c, + Rcpp::NumericMatrix scale_c, + Rcpp::NumericVector df_c, + Rcpp::NumericVector tv, + Rcpp::NumericVector mav, + Rcpp::IntegerVector masks) { + const int n = loc_t.nrow(); + const int n_mask = static_cast(masks.size()); + std::vector coef(static_cast(n_mask) * 16); + bool needed[4][4] = {{false}}; + for (int m = 0; m < n_mask; ++m) { + double c[4][4]; + mask_coefficients(masks[m], c); + for (int i = 0; i < 4; ++i) { + for (int j = 0; j < 4; ++j) { + coef[static_cast(m) * 16 + i * 4 + j] = c[i][j]; + if (c[i][j] != 0.0) { + needed[i][j] = true; + } + } + } + } + // With TV = MAV (predictive criteria) the middle band is empty and the + // second grid line equals the first + const bool same_x = tv[0] == mav[0]; + const bool same_y = tv[1] == mav[1]; + Rcpp::NumericMatrix out(n, n_mask); + for (int p = 0; p < n; ++p) { + const double v1[3] = {scale_t(p, 0), scale_t(p, 1), scale_t(p, 2)}; + const double v2[3] = {scale_c(p, 0), scale_c(p, 1), scale_c(p, 2)}; + double nu; + double sd1; + double sd2; + double rho; + if (v2[0] == 0.0 && v2[1] == 0.0 && v2[2] == 0.0) { + // Fixed control: theta has the bivariate t distribution of the + // treatment mean, so the probabilities are exact + nu = df_t[p]; + sd1 = std::sqrt(v1[0]); + sd2 = std::sqrt(v1[2]); + rho = v1[1] / (sd1 * sd2); + } else { + moment_match(df_t[p], df_c[p], v1, v2, nu, sd1, sd2, rho); + } + rho = std::max(-1.0, std::min(1.0, rho)); + const double d1 = loc_t(p, 0) - loc_c(p, 0); + const double d2 = loc_t(p, 1) - loc_c(p, 1); + const double x[3] = {0.0, (mav[0] - d1) / sd1, (tv[0] - d1) / sd1}; + const double y[3] = {0.0, (mav[1] - d2) / sd2, (tv[1] - d2) / sd2}; + double g[4][4]; + for (int i = 0; i < 4; ++i) { + g[i][0] = 0.0; + g[0][i] = 0.0; + } + g[3][3] = 1.0; + for (int i = 1; i <= 2; ++i) { + g[i][3] = R::pt(x[i], nu, 1, 0); + g[3][i] = R::pt(y[i], nu, 1, 0); + } + bool done[3][3] = {{false}}; + for (int i = 1; i <= 2; ++i) { + for (int j = 1; j <= 2; ++j) { + if (!needed[i][j]) { + g[i][j] = 0.0; + continue; + } + const int si = (same_x && i == 2) ? 1 : i; + const int sj = (same_y && j == 2) ? 1 : j; + if (!done[si][sj]) { + g[si][sj] = bvt_cdf(x[si], y[sj], rho, nu); + done[si][sj] = true; + } + g[i][j] = g[si][sj]; + } + } + for (int m = 0; m < n_mask; ++m) { + double total = 0.0; + const double *c = &coef[static_cast(m) * 16]; + for (int i = 0; i < 4; ++i) { + for (int j = 0; j < 4; ++j) { + if (c[i * 4 + j] != 0.0) { + total += c[i * 4 + j] * g[i][j]; + } + } + } + out(p, m) = std::min(1.0, std::max(0.0, total)); + } + if ((p + 1) % 1000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + return out; +} + +// Same arguments as cpp_regions_continuous2_mm(); the probabilities are +// estimated from nMC draws of each distribution, drawn with the random +// number generator of R separately for each pair (treatment then control in +// each iteration). +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_regions_continuous2_mc(Rcpp::NumericMatrix loc_t, + Rcpp::NumericMatrix scale_t, + Rcpp::NumericVector df_t, + Rcpp::NumericMatrix loc_c, + Rcpp::NumericMatrix scale_c, + Rcpp::NumericVector df_c, + Rcpp::NumericVector tv, + Rcpp::NumericVector mav, + Rcpp::IntegerVector masks, + int nMC) { + const int n = loc_t.nrow(); + const int n_mask = static_cast(masks.size()); + Rcpp::NumericMatrix out(n, n_mask); + for (int p = 0; p < n; ++p) { + // Cholesky factors of the scale matrices + const double lt11 = std::sqrt(scale_t(p, 0)); + const double lt21 = scale_t(p, 1) / lt11; + const double lt22 = std::sqrt(scale_t(p, 2) - lt21 * lt21); + const double lc11 = std::sqrt(scale_c(p, 0)); + const double lc21 = scale_c(p, 1) / lc11; + const double lc22 = std::sqrt(scale_c(p, 2) - lc21 * lc21); + const double nt = df_t[p]; + const double nc = df_c[p]; + long count[9] = {0, 0, 0, 0, 0, 0, 0, 0, 0}; + for (int u = 0; u < nMC; ++u) { + const double zt1 = R::norm_rand(); + const double zt2 = R::norm_rand(); + const double wt = std::sqrt(R::rchisq(nt) / nt); + const double zc1 = R::norm_rand(); + const double zc2 = R::norm_rand(); + const double wc = std::sqrt(R::rchisq(nc) / nc); + const double th1 = loc_t(p, 0) + lt11 * zt1 / wt - + (loc_c(p, 0) + lc11 * zc1 / wc); + const double th2 = loc_t(p, 1) + (lt21 * zt1 + lt22 * zt2) / wt - + (loc_c(p, 1) + (lc21 * zc1 + lc22 * zc2) / wc); + const int c1 = th1 > tv[0] ? 0 : (th1 > mav[0] ? 1 : 2); + const int c2 = th2 > tv[1] ? 0 : (th2 > mav[1] ? 1 : 2); + ++count[3 * c1 + c2]; + } + for (int m = 0; m < n_mask; ++m) { + long total = 0; + for (int r = 0; r < 9; ++r) { + if ((masks[m] >> r) & 1) { + total += count[r]; + } + } + out(p, m) = static_cast(total) / nMC; + } + Rcpp::checkUserInterrupt(); + } + return out; +} diff --git a/src/tte_simulation.cpp b/src/tte_simulation.cpp new file mode 100644 index 0000000..2b1161f --- /dev/null +++ b/src/tte_simulation.cpp @@ -0,0 +1,276 @@ +// Simulation of studies with a time-to-event endpoint, for the operating +// characteristics (studies simulated under scenarios for the true hazards) +// and for posterior predictive probabilities (future studies simulated with +// hazards drawn from their posterior distributions). +// +// A study enrolls the subjects of both groups at independent times from a +// piecewise uniform distribution on the accrual intervals (with the +// probability of an interval proportional to its rate times its length). +// The event time of a subject is exponential with the hazard of its group, +// and the dropout time is piecewise exponential, independent of the event +// time. The analysis takes place at a fixed calendar time after the start of +// enrollment, or at the calendar time of the k-th event in the whole study +// (all subjects followed until their event or dropout if fewer than k events +// occur). A subject enrolled at e with event time T and dropout time C +// contributes the observed time min(T, C, cut - e) (0 if e > cut) and an +// event if T <= C and e + T <= cut. The summary of a group is its number of +// events and its total observed time. +// +// The random numbers of a subject are drawn in the order: a uniform number +// for the enrollment time, a standard exponential number for the event time +// and a standard exponential number for the dropout time, with the random +// number generator of R. The event time is the standard exponential number +// divided by the hazard, so the same random numbers give the event times +// under all scenarios. + +#include + +#include +#include +#include +#include + +namespace { + +const double kInf = std::numeric_limits::infinity(); + +struct Conduct { + // Accrual: interval boundaries (0 = t_0 < ... < t_K) and cumulative + // probabilities at t_1, ..., t_K (the last one is 1) + std::vector acc_time; + std::vector acc_cum; + // Dropout: start times of the pieces (the first is 0, the last piece has no + // end) and their hazards + std::vector drop_start; + std::vector drop_hazard; + // Analysis at cut_time, or at the cut_events-th event if cut_events > 0 + double cut_time; + int cut_events; +}; + +Conduct make_conduct(const Rcpp::NumericVector &acc_time, + const Rcpp::NumericVector &acc_cum, + const Rcpp::NumericVector &drop_start, + const Rcpp::NumericVector &drop_hazard, double cut_time, + int cut_events) { + Conduct c; + c.acc_time.assign(acc_time.begin(), acc_time.end()); + c.acc_cum.assign(acc_cum.begin(), acc_cum.end()); + c.drop_start.assign(drop_start.begin(), drop_start.end()); + c.drop_hazard.assign(drop_hazard.begin(), drop_hazard.end()); + c.cut_time = cut_time; + c.cut_events = cut_events; + return c; +} + +// Enrollment time for the uniform number u (inverse distribution function of +// the piecewise uniform distribution). Intervals with probability 0 are +// never selected. +double enrollment_time(double u, const Conduct &c) { + const int k_max = static_cast(c.acc_cum.size()); + double prev = 0.0; + int last_pos = 0; + for (int k = 0; k < k_max; ++k) { + const double cum = c.acc_cum[k]; + if (cum > prev) { + last_pos = k; + if (u < cum) { + return c.acc_time[k] + + (u - prev) / (cum - prev) * (c.acc_time[k + 1] - c.acc_time[k]); + } + } + prev = cum; + } + // u at least the last cumulative probability (rounding): end of the last + // interval with positive probability + return c.acc_time[last_pos + 1]; // # nocov +} + +// Dropout time for the standard exponential number x (inverse of the +// cumulative hazard of the piecewise exponential distribution); infinite if +// the cumulative hazard stays below x. +double dropout_time(double x, const Conduct &c) { + const int j_max = static_cast(c.drop_start.size()); + double cum = 0.0; + for (int j = 0; j < j_max; ++j) { + const double h = c.drop_hazard[j]; + const double end = j + 1 < j_max ? c.drop_start[j + 1] : kInf; + if (h > 0.0) { + if (end == kInf || x <= cum + h * (end - c.drop_start[j])) { + return c.drop_start[j] + (x - cum) / h; + } + cum += h * (end - c.drop_start[j]); + } + } + return kInf; +} + +// Random numbers of n subjects: enrollment times, standard exponential +// numbers for the event times and dropout times. +void draw_subjects(int n, const Conduct &c, std::vector &enroll, + std::vector &base, std::vector &drop) { + for (int i = 0; i < n; ++i) { + enroll[i] = enrollment_time(R::unif_rand(), c); + base[i] = R::exp_rand(); + drop[i] = dropout_time(R::exp_rand(), c); + } +} + +// Numbers of events and total observed times of the two groups (the first +// n_t subjects are in the treatment group) for the hazards lam_t and lam_c. +// out: d_t, R_t, d_c, R_c. event_cal and work are work vectors of length n. +void summarize(int n_t, int n, const std::vector &enroll, + const std::vector &base, + const std::vector &drop, double lam_t, double lam_c, + const Conduct &c, std::vector &event_cal, + std::vector &work, double out[4]) { + // Calendar times of the events (infinite if dropout comes first) + int n_event = 0; + for (int i = 0; i < n; ++i) { + const double t = base[i] / (i < n_t ? lam_t : lam_c); + if (t <= drop[i]) { + event_cal[i] = enroll[i] + t; + ++n_event; + } else { + event_cal[i] = kInf; + } + } + double cut = c.cut_time; + if (c.cut_events > 0) { + if (n_event >= c.cut_events) { + std::copy(event_cal.begin(), event_cal.begin() + n, work.begin()); + std::nth_element(work.begin(), work.begin() + (c.cut_events - 1), + work.begin() + n); + cut = work[c.cut_events - 1]; + } else { + cut = kInf; + } + } + out[0] = 0.0; + out[1] = 0.0; + out[2] = 0.0; + out[3] = 0.0; + for (int i = 0; i < n; ++i) { + const double follow = cut - enroll[i]; + if (!(follow > 0.0)) { + continue; + } + const double t = base[i] / (i < n_t ? lam_t : lam_c); + const int g = i < n_t ? 0 : 2; + out[g + 1] += std::min(std::min(t, drop[i]), follow); + // A subject without an event (event_cal infinite) is not counted when + // the analysis time is infinite (fewer events than cut_events) + if (event_cal[i] < kInf && event_cal[i] <= cut) { + out[g] += 1.0; + } + } +} + +} // namespace + +// Summaries of nsim simulated studies under each scenario. +// n_t, n_c: numbers of subjects; hazard_t, hazard_c: hazards of the +// scenarios (hazard_c is not used if n_c = 0). +// acc_time, acc_cum, drop_start, drop_hazard, cut_time, cut_events: conduct +// of the study (see Conduct). +// Returns a matrix with nsim rows per scenario (scenario s in rows +// s * nsim + 1 to (s + 1) * nsim) and the columns d_t, R_t, d_c, R_c. The +// same random numbers are used for all scenarios. +// [[Rcpp::export]] +Rcpp::NumericMatrix cpp_tte_oc_data(int nsim, int n_t, int n_c, + Rcpp::NumericVector hazard_t, + Rcpp::NumericVector hazard_c, + Rcpp::NumericVector acc_time, + Rcpp::NumericVector acc_cum, + Rcpp::NumericVector drop_start, + Rcpp::NumericVector drop_hazard, + double cut_time, int cut_events) { + const Conduct c = make_conduct(acc_time, acc_cum, drop_start, drop_hazard, + cut_time, cut_events); + const int n = n_t + n_c; + const int n_scen = static_cast(hazard_t.size()); + std::vector enroll(n); + std::vector base(n); + std::vector drop(n); + std::vector event_cal(n); + std::vector work(n); + Rcpp::NumericMatrix out(nsim * n_scen, 4); + double res[4]; + for (int i = 0; i < nsim; ++i) { + draw_subjects(n, c, enroll, base, drop); + for (int s = 0; s < n_scen; ++s) { + summarize(n_t, n, enroll, base, drop, hazard_t[s], + n_c > 0 ? hazard_c[s] : 1.0, c, event_cal, work, res); + for (int k = 0; k < 4; ++k) { + out(s * nsim + i, k) = res[k]; + } + } + if ((i + 1) % 1000 == 0) { + Rcpp::checkUserInterrupt(); + } + } + return out; +} + +// Posterior predictive probabilities P(future effect > q) by simulation of +// nMC future studies for each posterior distribution. +// shape_t, rate_t: Gamma posterior distributions of the treatment hazard. +// shape_c, rate_c: those of the control hazard (same length as shape_t), or +// empty vectors for a fixed control with milestone survival fixed_c (the +// future study then has no control group). +// prior_t, prior_c: shapes and rates of the Gamma priors used to estimate +// the milestone survival in the future study. +// m_t, m_c: numbers of subjects of the future study; conduct as in +// cpp_tte_oc_data(); t0: milestone time. +// In each simulation, the hazards are drawn from their posterior +// distributions (treatment, then control), the future study is simulated, +// and the milestone survival of each group is estimated by +// exp(-t0 (a + d) / (b + R)) with the prior (a, b) and the future summary +// (d, R). +// [[Rcpp::export]] +Rcpp::NumericVector cpp_pred_tte(Rcpp::NumericVector shape_t, + Rcpp::NumericVector rate_t, + Rcpp::NumericVector shape_c, + Rcpp::NumericVector rate_c, double fixed_c, + Rcpp::NumericVector prior_t, + Rcpp::NumericVector prior_c, int m_t, + int m_c, Rcpp::NumericVector acc_time, + Rcpp::NumericVector acc_cum, + Rcpp::NumericVector drop_start, + Rcpp::NumericVector drop_hazard, + double cut_time, int cut_events, double t0, + double q, int nMC) { + const Conduct c = make_conduct(acc_time, acc_cum, drop_start, drop_hazard, + cut_time, cut_events); + const bool fixed = shape_c.size() == 0; + const int n = m_t + (fixed ? 0 : m_c); + const R_xlen_t n_dist = shape_t.size(); + std::vector enroll(n); + std::vector base(n); + std::vector drop(n); + std::vector event_cal(n); + std::vector work(n); + Rcpp::NumericVector out(n_dist); + double res[4]; + for (R_xlen_t i = 0; i < n_dist; ++i) { + long count = 0; + for (int b = 0; b < nMC; ++b) { + const double lam_t = R::rgamma(shape_t[i], 1.0 / rate_t[i]); + const double lam_c = + fixed ? 1.0 : R::rgamma(shape_c[i], 1.0 / rate_c[i]); + draw_subjects(n, c, enroll, base, drop); + summarize(m_t, n, enroll, base, drop, lam_t, lam_c, c, event_cal, work, + res); + const double est_t = + std::exp(-t0 * (prior_t[0] + res[0]) / (prior_t[1] + res[1])); + const double est_c = fixed ? fixed_c : + std::exp(-t0 * (prior_c[0] + res[2]) / (prior_c[1] + res[3])); + if (est_t - est_c > q) { + ++count; + } + } + out[i] = static_cast(count) / nMC; + Rcpp::checkUserInterrupt(); + } + return out; +} diff --git a/tests/testthat/helper-calibration.R b/tests/testthat/helper-calibration.R new file mode 100644 index 0000000..4703ff2 --- /dev/null +++ b/tests/testthat/helper-calibration.R @@ -0,0 +1,358 @@ +# Exact references for qdm_calibrate(): Python_reference/ref_binary_qdm.py +# (rational arithmetic; the smallest distance between a probability of an +# outcome and a grid value is about 9e-5, and between a probability of +# meeting a criterion and its target about 3e-3). The curves are the +# probabilities that the criteria are met at gamma = 0.01, ..., 0.99. +ref_cal <- list( + D1 = list( + gamma_go = 0.7, gamma_nogo = 0.41, + prob_go = 0.04539569696408934, + prob_nogo = 0.1820194948817842, + curve_go = c(0.9095952581639182, 0.8351111911970428, + 0.7555154491502801, 0.7326075499361495, + 0.7235162610462224, 0.692488340917831, + 0.6399247874548518, 0.5820187088857995, + 0.5779353878310263, 0.5779353878310263, + 0.5779353878310263, 0.5576463131234777, + 0.51053955065456, 0.44881548888315265, + 0.41763529273058597, 0.41763529273058597, + 0.41763529273058597, 0.41652260019391374, + 0.41652260019391374, 0.41652260019391374, + 0.4074313113039867, 0.4074313113039867, + 0.3767067387791402, 0.32414318531616115, + 0.2662371067471088, 0.2662371067471088, + 0.2662371067471088, 0.2662371067471088, + 0.2662371067471088, 0.2662371067471088, + 0.26609807242881733, 0.26609807242881733, + 0.26609807242881733, 0.26609807242881733, + 0.26362333239562147, 0.26362333239562147, + 0.24992820696802612, 0.21645702449573354, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14854199690661835, 0.14854199690661835, + 0.14823291564643162, 0.14451375200964325, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.07148966780888895, + 0.07148966780888895, 0.04539569696408934, + 0.03368078309878694, 0.029696746610759207, + 0.029232732854534975, 0.029232732854534975, + 0.029232732854534975, 0.029232732854534975, + 0.029232732854534975, 0.029232732854534975, + 0.029232732854534975, 0.029232732854534975, + 0.029232732854534975, 0.029232732854534975, + 0.013607283081933553, 0.010478962970312823, + 0.010478962970312823, 0.010478962970312823, + 0.009983074485407709, 0.009983074485407709, + 0.009983074485407709, 0.009983074485407709, + 0.00821548966950257, 0.0050006947855751, + 0.00317499392345005, 0.0027876570426695756, + 0.0027876570426695756, 0.0027876570426695756, + 0.000842309435619432, 0.000618857999075094, + 0.00019999396088181583), + curve_nogo = c(0.9360312437209708, 0.8943008066738906, + 0.824908404748071, 0.7894363741868631, + 0.7894363741868631, 0.7754867625215374, + 0.7272729569375629, 0.6434575664356205, + 0.6428586680471624, 0.6428586680471624, + 0.6428586680471624, 0.6351691028828969, + 0.6351691028828969, 0.6004806757505677, + 0.4743758221734216, 0.4743758221734216, + 0.4743758221734216, 0.4743758221734216, + 0.4743758221734216, 0.4742001669821098, + 0.4742001669821098, 0.4742001669821098, + 0.47107162118493706, 0.47107162118493706, + 0.4522823483296004, 0.31250133729144036, + 0.31250133729144036, 0.31250133729144036, + 0.31250133729144036, 0.31250133729144036, + 0.31250133729144036, 0.31250133729144036, + 0.31250133729144036, 0.31250133729144036, + 0.31250133729144036, 0.31250133729144036, + 0.31250133729144036, 0.3124664371909982, + 0.3115538301228717, 0.27568449524892386, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.1820194948817842, + 0.1820194948817842, 0.10652210989787712, + 0.09533801891255769, 0.09315300280024655, + 0.09315300280024655, 0.092972328889183, + 0.092972328889183, 0.092972328889183, + 0.092972328889183, 0.0929681165691327, + 0.0929681165691327, 0.0929681165691327, + 0.0929681165691327, 0.0929681165691327, + 0.0929681165691327, 0.0929681165691327, + 0.056372802045602396, 0.04499540247596093, + 0.04179868226405913, 0.04179868226405913, + 0.04179868226405913, 0.041368453217656635, + 0.041368453217656635, 0.041368453217656635, + 0.041368453217656635, 0.041346697310887505, + 0.041346697310887505, 0.041346697310887505, + 0.019776015886914054, 0.019776015886914054, + 0.016580561319679932, 0.016580561319679932, + 0.01595627100187675, 0.015956037626780276, + 0.015956037626780276, 0.015904416509333545, + 0.008258294030383372, 0.005946695387662566, + 0.005946695387662566, 0.005330185061081506, + 0.005328981541067139, 0.0032437514376666052, + 0.0015560507274942057, 0.0014802327415182229, + 0.0004087239987645357), + oc = data.frame( + Go = c(0.04539569696408934, 0.39951932424943226), + NoGo = c(0.7337628932528911, 0.1820194948817842), + Gray = c(0.22084140978301947, 0.41846118086878353), + Miss = c(0.0, 0.0) + ) + ), + D3 = list( + gamma_go = 0.39, gamma_nogo = 0.56, + prob_go = 0.06644763953101097, + prob_nogo = 0.05730992128, + curve_go = c(0.9460485735951875, 0.8188773542124149, + 0.8188773542124149, 0.8188773542124149, + 0.8188773542124149, 0.6069253219077941, + 0.6069253219077941, 0.6069253219077941, + 0.6069253219077941, 0.6069253219077941, + 0.6069253219077941, 0.6069253219077941, + 0.3684792855650957, 0.3684792855650957, + 0.3684792855650957, 0.3684792855650957, + 0.3684792855650957, 0.3684792855650957, + 0.3684792855650957, 0.3684792855650957, + 0.3684792855650957, 0.3684792855650957, + 0.3684792855650957, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.1777224564909369, 0.1777224564909369, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.06644763953101097, 0.06644763953101097, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.01875843226247128, + 0.01875843226247128, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0038555549910526286, 0.0038555549910526286, + 0.0005438044862929281, 0.0005438044862929281, + 0.0005438044862929281, 0.0005438044862929281, + 0.0005438044862929281, 0.0005438044862929281, + 0.0005438044862929281, 0.0005438044862929281, + 0.0005438044862929281, 4.704191057897302e-05, + 4.704191057897302e-05, 4.704191057897302e-05, + 4.704191057897302e-05, 4.704191057897302e-05, + 1.8816764231589208e-06, 1.8816764231589208e-06, + 1.8816764231589208e-06), + curve_nogo = c(0.980408958976, 0.980408958976, + 0.91655667712, 0.91655667712, + 0.91655667712, 0.91655667712, + 0.91655667712, 0.77466271744, + 0.77466271744, 0.77466271744, + 0.77466271744, 0.77466271744, + 0.77466271744, 0.77466271744, + 0.56182177792, 0.56182177792, + 0.56182177792, 0.56182177792, + 0.56182177792, 0.56182177792, + 0.56182177792, 0.56182177792, + 0.56182177792, 0.56182177792, + 0.56182177792, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.334791442432, 0.334791442432, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.158212292608, + 0.158212292608, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.05730992128, + 0.05730992128, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.01526726656, 0.01526726656, + 0.00281018368, 0.00281018368, + 0.00281018368, 0.00281018368, + 0.00281018368, 0.00281018368, + 0.00281018368, 0.00281018368, + 0.00281018368, 0.000318767104, + 0.000318767104, 0.000318767104, + 0.000318767104, 1.6777216e-05, + 1.6777216e-05), + oc = data.frame( + Go = c(0.06644763953101097, 0.665208557568), + NoGo = c(0.6315207144349043, 0.05730992128), + Gray = c(0.30203164603408467, 0.277481521152), + Miss = c(0.0, 0.0) + ) + ), + D5 = list( + gamma_go = 0.8, gamma_nogo = 0.46, + prob_go = 0.09182105764481728, + prob_nogo = 0.12048530877083947, + curve_go = c(0.9936791760551595, 0.9887909515032317, + 0.9798444380610416, 0.9714401437935783, + 0.944861550588807, 0.944861550588807, + 0.944861550588807, 0.9345753549355929, + 0.9317126563916205, 0.8728283514045517, + 0.8728283514045517, 0.8728283514045517, + 0.8728283514045517, 0.8640951064374595, + 0.8640951064374595, 0.832578838007728, + 0.8323350941117238, 0.7527131282954047, + 0.7527131282954047, 0.7527131282954047, + 0.7527131282954047, 0.7527131282954047, + 0.7478215515424739, 0.7478215515424739, + 0.7478215515424739, 0.7213713341484944, + 0.7213713231533782, 0.5900143119153444, + 0.5900143119153444, 0.5899777503309437, + 0.5899777503309437, 0.5899777503309437, + 0.5899777503309437, 0.5899777503309437, + 0.5899777503309437, 0.5899752764297812, + 0.5883503171230866, 0.5883503171230866, + 0.5882376000013704, 0.5718094922936588, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.40998567708953937, + 0.40998567708953937, 0.4099855121627952, + 0.2781609336050496, 0.24728670677785117, + 0.24704296288184696, 0.24704296288184696, + 0.24704296288184696, 0.24704296288184696, + 0.24704296288184696, 0.24704296288184696, + 0.24704296288184696, 0.24704296288184696, + 0.24704296288184696, 0.24704296288184696, + 0.24704296288184696, 0.2105606574743696, + 0.16623746728750743, 0.1359048935625405, + 0.1271716485954483, 0.1271716485954483, + 0.12717053533992517, 0.12717053533992517, + 0.12643930365191258, 0.12643930365191258, + 0.12643930365191258, 0.12643930365191258, + 0.12643930365191258, 0.09182105764481728, + 0.06542464506440712, 0.06524930731951521, + 0.05513844941119291, 0.05513844941119291, + 0.05513399638910042, 0.05513399638910042, + 0.0538340289437447, 0.0538340289437447, + 0.028559856206421687, 0.02824424826561626, + 0.020155561938958417, 0.020155561938958417, + 0.018627244069717278, 0.018627244069717278, + 0.006320823944840479, 0.006320823944840479, + 0.005086480466454774, 0.0017525193506920857, + 0.0010521614950701466), + curve_nogo = c(0.9565126094004167, 0.9482174353272205, + 0.8831998104072866, 0.8769094011065444, + 0.8769094011065444, 0.7560145747512932, + 0.7560145747512932, 0.7526433779024815, + 0.7526433779024815, 0.7484946184087029, + 0.7242027810800944, 0.5840754413879621, + 0.5840754413879621, 0.584021011598685, + 0.584021011598685, 0.5828214146935686, + 0.5828214146935686, 0.581339714874362, + 0.5678442496918017, 0.5085494277910066, + 0.3985987646637045, 0.3985987646637045, + 0.3985987646637045, 0.3985987646637045, + 0.3985987646637045, 0.3985900170189992, + 0.3985900170189992, 0.3982901177927201, + 0.3982901177927201, 0.3927861229375173, + 0.3883410234798973, 0.3401873376133784, + 0.23645127718457593, 0.23645127718457593, + 0.23645127718457593, 0.23645127718457593, + 0.23645127718457593, 0.23645127718457593, + 0.23645127718457593, 0.23645127718457593, + 0.23645127718457593, 0.23645127718457593, + 0.23645127718457593, 0.23645044407555638, + 0.23530353065864862, 0.12048530877083947, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.12044087925583517, + 0.12044087925583517, 0.0663256993043717, + 0.05481927710246143, 0.052340518191378936, + 0.052340518191378936, 0.05233496413124863, + 0.05214455192408728, 0.05214455192408728, + 0.05214455192408728, 0.05214455192408728, + 0.05214455192408728, 0.05214455192408728, + 0.05214451621941502, 0.05214451621941502, + 0.022539400835089284, 0.02253643886742233, + 0.019392544173173883, 0.019392544173173883, + 0.019392544173173883, 0.019008658450400378, + 0.019008658450400378, 0.019008658450400378, + 0.019008658450400378, 0.019008658450400378, + 0.008734145982730568, 0.008733907951582126, + 0.00623369804737794, 0.00623369804737794, + 0.005784392344912404, 0.005784392344912404, + 0.005784392344912404, 0.005784392344912404, + 0.002929653182028718, 0.001811780121552814, + 0.001462458488858542, 0.001462458488858542, + 0.001462458488858542, 0.0004994168687168717, + 0.0003098918586551501, 0.00013041961720086529, + 5.724662212067328e-05), + oc = data.frame( + Go = c(0.09182105764481728, 0.4914505722089934), + NoGo = c(0.5900144878372048, 0.12048530877083947), + Gray = c(0.3181644545179779, 0.38806411902016713), + Miss = c(0.0, 0.0) + ) + ) +) + +cal_args <- list( + D1 = list(scenario_go = data.frame(pi_t = 0.4, pi_c = 0.4), + scenario_nogo = data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.05, target_nogo = 0.2), + D3 = list(scenario_go = data.frame(pi_t = 1 / 3), + scenario_nogo = data.frame(pi_t = 0.6), + target_go = 0.1, target_nogo = 0.1), + D5 = list(scenario_go = data.frame(pi_t = 0.4, pi_c = 0.4), + scenario_nogo = data.frame(pi_t = 0.7, pi_c = 0.4), + target_go = 0.1, target_nogo = 0.2) +) + +run_cal <- function(name, ...) { + a <- cal_args[[name]] + qdm_calibrate(ref_design(name), a$scenario_go, a$scenario_nogo, + a$target_go, a$target_nogo, ...) +} diff --git a/tests/testthat/helper-designs-binary2.R b/tests/testthat/helper-designs-binary2.R new file mode 100644 index 0000000..86b5b4a --- /dev/null +++ b/tests/testthat/helper-designs-binary2.R @@ -0,0 +1,87 @@ +# Designs shared by the tests of two binary endpoints. B1 to B4 are the +# designs of Python_reference/ref_binary2_qdm.py (exact references: rational +# arithmetic for predictive probabilities, Beta differences for criteria on +# one endpoint at a time). +dir_q <- function() prior_dirichlet(rep(0.25, 4)) + +ref_design_bin2 <- function(name, nMC = 20000L, enumerate = TRUE) { + switch( + name, + B1 = design_binary2(3, 2, dir_q(), dir_q(), + criterion_predictive(c(0.1, 0), m_t = 4, m_c = 3, + gamma_go = 0.4, + gamma_nogo = 0.3), + nMC = nMC, enumerate = enumerate), + B2 = design_binary2(3, 2, dir_q(), dir_q(), + criterion_predictive(c(0.1, 0), m_t = 4, m_c = 3, + gamma_go = c(0.6, 0.5), + gamma_nogo = c(0.5, 0.6), + rule = "and"), + nMC = nMC, enumerate = enumerate), + B3 = design_binary2(4, 4, dir_q(), dir_q(), + criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), + gamma_go = 0.7, gamma_nogo = 0.7, + go_regions = 1:3, + nogo_regions = 7:9), + nMC = nMC, enumerate = enumerate), + B4 = design_binary2(4, 4, dir_q(), dir_q(), + criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), + gamma_go = c(0.5, 0.4), + gamma_nogo = c(0.6, 0.5), + rule = "and"), + nMC = nMC, enumerate = enumerate), + # Case study 1 of Yamaguchi et al. (submitted), Table 3, rho = 0 + B5 = design_binary2(10, 10, dir_q(), dir_q(), + criterion_posterior(c(0.15, 0.15), c(0.10, 0.10), + gamma_go = 0.263, + gamma_nogo = 0.347), + nMC = nMC, enumerate = enumerate), + # Case study 3 (Supplemental Section S1.1): external data, regions + # G = {1, 2} and N = {9} + B6 = design_binary2(8, 8, dir_q(), dir_q(), + criterion_posterior(c(0.15, 0.25), c(0.10, 0.15), + gamma_go = 0.453, + gamma_nogo = 0.229, + go_regions = 1:2), + external_t = borrow(data_binary2(c(2, 1, 1, 2)), 0.7), + external_c = borrow(data_binary2(c(14, 2, 3, 1)), + 0.5), + nMC = nMC, enumerate = enumerate), + # Hypothetical control and external control only + B7 = design_binary2(3, 0, dir_q(), dir_q(), + criterion_predictive(c(0.1, 0), m_t = 4, m_c = 3, + gamma_go = 0.4, + gamma_nogo = 0.3), + hypothetical_c = hypothetical(data_binary2(c(2, 1, 1, + 0))), + nMC = nMC, enumerate = enumerate), + B8 = design_binary2(3, 0, dir_q(), dir_q(), + criterion_predictive(c(0.1, 0), m_t = 4, m_c = 3, + gamma_go = 0.4, + gamma_nogo = 0.3), + external_c = borrow(data_binary2(c(14, 2, 3, 1)), + 0.5), + nMC = nMC, enumerate = enumerate), + # Fixed control (Python_reference/ref_fixed_tte_qdm.py) + BF1 = design_binary2(3, 0, dir_q(), + criterion = criterion_predictive(c(0.1, 0), m_t = 4, + gamma_go = 0.4, + gamma_nogo = 0.3), + fixed_c = c(0.25, 0.5), nMC = nMC, + enumerate = enumerate), + BF2 = design_binary2(10, 0, dir_q(), + criterion = criterion_posterior(c(0.25, 0.2), + c(0.05, 0), + gamma_go = 0.5, + gamma_nogo = 0.3), + fixed_c = c(0.35, 0.3), nMC = nMC, + enumerate = enumerate) + ) +} + +scen_bin2 <- data.frame(pi_t1 = c(0.3, 0.6, 0.7), pi_t2 = c(0.4, 0.5, 0.8), + rho_t = c(0.2, 0, 0.5), pi_c1 = c(0.3, 0.3, 0.2), + pi_c2 = c(0.3, 0.3, 0.3), rho_c = c(0, 0, -0.2)) +scen_bin2_d <- data.frame(pi_t1 = c(0.3, 0.6, 0.8), pi_t2 = c(0.3, 0.5, 0.7), + rho_t = c(0, 0.3, 0.2), pi_c1 = c(0.3, 0.3, 0.2), + pi_c2 = c(0.3, 0.3, 0.3), rho_c = c(0, 0.3, 0.1)) diff --git a/tests/testthat/helper-designs-continuous.R b/tests/testthat/helper-designs-continuous.R new file mode 100644 index 0000000..0048971 --- /dev/null +++ b/tests/testthat/helper-designs-continuous.R @@ -0,0 +1,74 @@ +# Designs shared by the tests of the continuous endpoint. C1 to C6 are the +# designs of Python_reference/ref_continuous_qdm.py, whose results (closed +# forms, two numerical integrations and noncentral t distributions) are used +# as references; C7 and C8 (fixed control) are those of +# Python_reference/ref_fixed_tte_qdm.py. +crit_cont <- function(gamma_go = 0.6, gamma_nogo = 0.7, tv = 30, mav = 15) { + criterion_posterior(theta_tv = tv, theta_mav = mav, gamma_go = gamma_go, + gamma_nogo = gamma_nogo) +} + +ref_design_cont <- function(name, method = "NI", nMC = 10000L) { + vague <- prior_vague() + switch( + name, + # Concurrent control, vague priors (the setting of Kang et al., 2026, + # Section 6, without external data) + C1 = design_continuous(12, 12, vague, vague, crit_cont(), + method = method, nMC = nMC), + # Normal-Inverse-chi-squared priors and external data for both groups + C2 = design_continuous(10, 8, prior_nix(5, 2, 4, 20), + prior_nix(-5, 1, 3, 25), crit_cont(), + external_t = borrow(data_continuous(6, 20, 30), 0.5), + external_c = borrow(data_continuous(30, -12, 20), + 0.4), + method = method, nMC = nMC), + # Hypothetical control + C3 = design_continuous(12, 0, vague, criterion = crit_cont(), + hypothetical_c = hypothetical(mean = -10, r = 1.5), + method = method, nMC = nMC), + # External control only, with the vague prior for the control group + C4 = design_continuous(12, 0, prior_nix(0, 1, 2, 25), vague, crit_cont(), + external_c = borrow(data_continuous(30, -12, 20), + 0.4), + method = method, nMC = nMC), + # Predictive criterion with a concurrent control + C5 = design_continuous(12, 12, vague, vague, + criterion_predictive(10, m_t = 40, m_c = 30, + gamma_go = 0.8, + gamma_nogo = 0.7), + method = method, nMC = nMC), + # Predictive criterion with a hypothetical control + C6 = design_continuous(15, 0, vague, + criterion = criterion_predictive(5, m_t = 30, + m_c = 20, + gamma_go = 0.7, + gamma_nogo = 0.6), + hypothetical_c = hypothetical(mean = 0, r = 2), + method = method, nMC = nMC), + # Fixed control, posterior criterion + C7 = design_continuous(12, 0, vague, criterion = crit_cont(), + fixed_c = -10, method = method, nMC = nMC), + # Fixed control, predictive criterion + C8 = design_continuous(15, 0, vague, + criterion = criterion_predictive(5, m_t = 30, + gamma_go = 0.7, + gamma_nogo = 0.6), + fixed_c = 0, method = method, nMC = nMC) + ) +} + +# Observed data of the reference cases (Python_reference/ref_continuous_qdm.py) +ref_data_cont <- list( + C1 = list(t = data_continuous(12, 18, 25), c = data_continuous(12, -12, 25)), + C2 = list(t = data_continuous(10, 22, 24), c = data_continuous(8, -8, 18)), + C3 = list(t = data_continuous(12, 25, 20), c = NULL), + C4 = list(t = data_continuous(12, 20, 22), c = NULL), + C5 = list(t = data_continuous(12, 18, 25), c = data_continuous(12, -12, 25)), + C6 = list(t = data_continuous(15, 9, 12), c = NULL), + C7 = list(t = data_continuous(12, 25, 20), c = NULL), + C8 = list(t = data_continuous(15, 9, 12), c = NULL) +) + +scen_cont_c <- data.frame(mu_t = c(0, 20, 40), sd_t = 25, mu_c = 0, sd_c = 25) +scen_cont_u <- data.frame(mu_t = c(0, 20, 40), sd_t = 20) diff --git a/tests/testthat/helper-designs-continuous2.R b/tests/testthat/helper-designs-continuous2.R new file mode 100644 index 0000000..c1c9dd0 --- /dev/null +++ b/tests/testthat/helper-designs-continuous2.R @@ -0,0 +1,115 @@ +# Designs shared by the tests of two continuous endpoints. They are the +# designs K1 to K6 of Python_reference/ref_continuous2_qdm.py (closed-form +# posteriors, moment matching with adaptive quadrature, Monte Carlo +# simulation with 2e7 draws and simulation of 1e5 studies per scenario). +cov2 <- function(s1, s2, r) { + matrix(c(s1 ^ 2, r * s1 * s2, r * s1 * s2, s2 ^ 2), 2L, 2L) +} + +lambda_cs2 <- matrix(c(80 ^ 2, 15, 15, 6 ^ 2), 2L, 2L) +lambda_cs4 <- matrix(c(25, 1, 1, 9), 2L, 2L) + +crit_cont2 <- function(gamma_go = 0.5, gamma_nogo = 0.3, ...) { + criterion_posterior(theta_tv = c(10, 2), theta_mav = c(5, 1), + gamma_go = gamma_go, gamma_nogo = gamma_nogo, ...) +} + +ref_design_cont2 <- function(name, method = "MM", nMC = 10000L) { + vague <- prior_vague() + switch( + name, + # Concurrent control, vague priors + K1 = design_continuous2(12, 12, vague, vague, crit_cont2(), + method = method, nMC = nMC), + # Case study 2 of Yamaguchi et al. (submitted) + K2 = design_continuous2(30, 30, prior_niw(c(0, 1), 0.1, 4, lambda_cs2), + prior_niw(c(-10, -1), 0.1, 4, lambda_cs2), + crit_cont2(0.296, 0.244), method = method, + nMC = nMC), + # NIW priors and external data for both groups, predictive criterion + K3 = design_continuous2( + 12, 12, prior_niw(c(1.984, 1.191), 0.1, 4, lambda_cs4), + prior_niw(c(-0.5, -1.5), 0.1, 4, lambda_cs4), + criterion_predictive(c(1.984, 1.191), m_t = 50, m_c = 50, + gamma_go = 0.6, gamma_nogo = 0.5), + external_t = borrow(data_continuous2(8, c(2, 1), + matrix(c(25, 3, 3, 9), 2L)), 0.5), + external_c = borrow(data_continuous2(20, c(-0.5, -1.5), + matrix(c(24, 2, 2, 10), 2L)), 0.4), + method = method, nMC = nMC + ), + # Hypothetical control, vague treatment prior + K4 = design_continuous2(15, 0, vague, + criterion = crit_cont2(0.4, 0.3, go_regions = 1:2), + hypothetical_c = hypothetical(mean = c(-10, -1), + r = 1.5), + method = method, nMC = nMC), + # External control only, vague control prior, marginal rule "and" + K5 = design_continuous2( + 12, 0, prior_niw(c(0, 1), 0.1, 4, lambda_cs2), vague, + crit_cont2(c(0.6, 0.5), c(0.5, 0.6), rule = "and"), + external_c = borrow(data_continuous2(20, c(-10, -1), cov2(70, 5, 0.3)), + 0.5), + method = method, nMC = nMC + ), + # Predictive criterion with a hypothetical control + K6 = design_continuous2(15, 0, vague, + criterion = criterion_predictive( + c(5, 1), m_t = 40, m_c = 30, gamma_go = 0.7, + gamma_nogo = 0.6 + ), + hypothetical_c = hypothetical(mean = c(0, 0), + r = 2), + method = method, nMC = nMC), + # Fixed control (Python_reference/ref_fixed_tte_qdm.py), posterior + # criterion + KF1 = design_continuous2(10, 0, vague, criterion = crit_cont2(), + fixed_c = c(-10, -1), method = method, + nMC = nMC), + # Fixed control, predictive criterion, 2 degrees of freedom + KF2 = design_continuous2(4, 0, vague, + criterion = criterion_predictive( + c(0, 0), m_t = 20, gamma_go = 0.5, + gamma_nogo = 0.2 + ), + fixed_c = c(1, 0.5), method = method, nMC = nMC) + ) +} + +# Observed data of the reference cases +ref_data_cont2 <- list( + K1 = list(t = data_continuous2(12, c(18, 2.5), cov2(60, 5, 0.4)), + c = data_continuous2(12, c(-10, -1), cov2(70, 6, 0.2))), + K2 = list(t = data_continuous2(30, c(5, 2), cov2(80, 6, 0.4)), + c = data_continuous2(30, c(-10, -1), cov2(75, 6.5, 0.3))), + K3 = list(t = data_continuous2(12, c(2.5, 1), cov2(5, 3, 0.3)), + c = data_continuous2(12, c(-0.8, -1.2), cov2(4.5, 3.2, 0.1))), + K4 = list(t = data_continuous2(15, c(4, 1.5), cov2(30, 3, 0.5)), c = NULL), + K5 = list(t = data_continuous2(12, c(3, 1), cov2(75, 5.5, 0.4)), c = NULL), + K6 = list(t = data_continuous2(15, c(7, 2), cov2(10, 2, -0.3)), c = NULL), + KF1 = list(t = data_continuous2(10, c(5, 2), + matrix(c(6400, 190, 190, 36), 2L)), + c = NULL), + KF2 = list(t = data_continuous2(4, c(2, 1), matrix(c(4, 1, 1, 2), 2L)), + c = NULL) +) + +# Scenarios of the operating characteristics (SCEN of the Python reference) +scen_cont2 <- function(name) { + conc <- data.frame(mu_t1 = c(-10, 0, 10), mu_t2 = c(-1, 1, 2), sd_t1 = 70, + sd_t2 = 6, rho_t = c(0, 0.4, 0.8), mu_c1 = -10, + mu_c2 = -1, sd_c1 = 70, sd_c2 = 6, rho_c = c(0, 0.4, 0.8)) + switch( + name, + K1 = conc, K2 = conc, + K3 = data.frame(mu_t1 = c(-0.5, 2, 4), mu_t2 = c(-1.5, 0.5, 1.5), + sd_t1 = 5, sd_t2 = 3, rho_t = 0.3, mu_c1 = -0.5, + mu_c2 = -1.5, sd_c1 = 5, sd_c2 = 3, rho_c = 0.3), + K4 = data.frame(mu_t1 = c(-10, 0, 10), mu_t2 = c(-1, 1, 3), sd_t1 = 30, + sd_t2 = 3, rho_t = 0.5), + K5 = data.frame(mu_t1 = c(-10, 5, 20), mu_t2 = c(-1, 1.5, 3), + sd_t1 = 75, sd_t2 = 5.5, rho_t = 0.4), + K6 = data.frame(mu_t1 = c(0, 5, 10), mu_t2 = c(0, 1, 2), sd_t1 = 10, + sd_t2 = 2, rho_t = -0.3) + ) +} diff --git a/tests/testthat/helper-designs-tte.R b/tests/testthat/helper-designs-tte.R new file mode 100644 index 0000000..6ab80df --- /dev/null +++ b/tests/testthat/helper-designs-tte.R @@ -0,0 +1,75 @@ +# Designs shared by the tests of the time-to-event endpoint. They are the +# designs T1 to T6 of Python_reference/ref_fixed_tte_qdm.py, whose results +# (Gamma distribution functions, an independent numerical integration of +# the distribution of the difference of milestone survival probabilities, +# beta prime distributions of the total observed time with complete +# follow-up) are used as references. +crit_tte <- function(gamma_go = 0.6, gamma_nogo = 0.8, tv = 0.15, mav = 0) { + criterion_posterior(theta_tv = tv, theta_mav = mav, gamma_go = gamma_go, + gamma_nogo = gamma_nogo) +} + +# Complete follow-up: enrollment within one time unit, no dropout and an +# analysis long after the last event, so every subject has an event and the +# total observed time of n subjects is Gamma(n, hazard) +conduct_complete <- conduct_tte(accrual_time = c(0, 1), cut_time = 1e6) +# Enrollment with increasing rates over 15 time units, a small dropout hazard +# and an analysis at time 15.44 +conduct_example <- conduct_tte(accrual_time = c(0, 5, 10, 15), + accrual_rate = c(0.4, 2, 4.5), + dropout_hazard = 0.00226, cut_time = 15.44) + +ref_design_tte <- function(name, nMC = 10000L) { + g <- prior_gamma(0.1, 1) + switch( + name, + # Fixed control, posterior criterion + T1 = design_tte(30, 0, g, criterion = crit_tte(), milestone = 3, + conduct = conduct_complete, fixed_c = 0.72), + # Concurrent control, posterior criterion + T2 = design_tte(20, 20, g, g, crit_tte(), milestone = 3, + conduct = conduct_example), + # Fixed control, predictive criterion, complete follow-up of the future + # study + T3 = design_tte(30, 0, g, + criterion = criterion_predictive(0.05, m_t = 10, + gamma_go = 0.8, + gamma_nogo = 0.3), + milestone = 3, conduct = conduct_complete, + fixed_c = 0.55, nMC = nMC), + # Concurrent control, predictive criterion + T4 = design_tte(20, 20, g, g, + criterion_predictive(0.05, m_t = 10, m_c = 8, + gamma_go = 0.8, gamma_nogo = 0.3), + milestone = 3, conduct = conduct_complete, nMC = nMC), + # Hypothetical control + T5 = design_tte(30, 0, g, g, crit_tte(), milestone = 3, + conduct = conduct_example, + hypothetical_c = hypothetical(data_tte(8, 60))), + # External control only, external treatment data + T6 = design_tte(30, 0, g, g, crit_tte(), milestone = 3, + conduct = conduct_example, + external_t = borrow(data_tte(4, 30), 0.5), + external_c = borrow(data_tte(20, 100), 0.5)) + ) +} + +# Observed data of the reference cases +ref_data_tte <- list( + T1 = list(t = data_tte(6, 150), c = NULL), + T2 = list(t = data_tte(5, 40), c = data_tte(9, 35)), + T3 = list(t = data_tte(6, 70), c = NULL), + T4 = list(t = data_tte(6, 70), c = data_tte(9, 60)), + T5 = list(t = data_tte(6, 150), c = NULL), + T6 = list(t = data_tte(6, 150), c = NULL) +) + +# Reference probabilities of the Go and NoGo regions +ref_prob_tte <- list( + T1 = c(go = 0.686259165773, nogo = 0.00106102273767), + T2 = c(go = 0.665455253873, nogo = 0.0899531660407), + T3 = c(go = 0.917785289262, nogo = 1 - 0.917785289262), + T4 = c(go = 0.69356649484, nogo = 1 - 0.69356649484), + T5 = c(go = 0.713482708146, nogo = 0.0137418340154), + T6 = c(go = 0.920053158435, nogo = 0.00182044277956) +) diff --git a/tests/testthat/helper-designs.R b/tests/testthat/helper-designs.R new file mode 100644 index 0000000..faf0884 --- /dev/null +++ b/tests/testthat/helper-designs.R @@ -0,0 +1,40 @@ +# Designs shared by the tests of the binary endpoint. D1 to D7 are the +# designs of Python_reference/ref_binary_qdm.py, whose exact results +# (rational arithmetic) are used as references; D8 and D9 (fixed control) are +# those of Python_reference/ref_fixed_tte_qdm.py. +crit_post <- function(gamma_go = 0.5, gamma_nogo = 0.8, tv = 0.2, mav = 0.1) { + criterion_posterior(theta_tv = tv, theta_mav = mav, gamma_go = gamma_go, + gamma_nogo = gamma_nogo) +} + +ref_design <- function(name) { + unif <- prior_beta(1, 1) + switch( + name, + D1 = design_binary(12, 12, unif, unif, crit_post()), + D2 = design_binary(10, 8, unif, prior_beta(2, 3), crit_post(), + external_t = borrow(data_binary(10, 6), 0.5), + external_c = borrow(data_binary(20, 8), 0.5)), + D3 = design_binary(12, 0, unif, unif, crit_post(), + hypothetical_c = hypothetical(data_binary(12, 4))), + D4 = design_binary(12, 0, unif, unif, crit_post(), + external_c = borrow(data_binary(20, 6), 0.5)), + D5 = design_binary(10, 10, unif, unif, + criterion_predictive(0.05, m_t = 30, m_c = 20, + gamma_go = 0.9, + gamma_nogo = 0.7)), + D6 = design_binary(8, 8, unif, unif, crit_post(0.2, 0.3)), + D7 = design_binary(6, 6, unif, unif, crit_post(tv = 0, mav = -0.1)), + D8 = design_binary(20, 0, unif, + criterion = crit_post(0.8, 0.8, tv = 0.2, mav = 0.05), + fixed_c = 0.2), + D9 = design_binary(10, 0, unif, + criterion = criterion_predictive(0, m_t = 10, + gamma_go = 0.6, + gamma_nogo = 0.6), + fixed_c = 0.3) + ) +} + +scen_c <- data.frame(pi_t = c(0.2, 0.4, 0.6, 0.8), pi_c = 0.4) +scen_u <- data.frame(pi_t = c(0.2, 0.4, 0.6, 0.8)) diff --git a/tests/testthat/helper-plots.R b/tests/testthat/helper-plots.R new file mode 100644 index 0000000..ab607ff --- /dev/null +++ b/tests/testthat/helper-plots.R @@ -0,0 +1,17 @@ +# Parts of a ggplot object. With ggplot2 4.0 and later the plot, its theme +# elements and their settings are S7 objects whose properties are stored as +# attributes; with earlier versions they are lists. +plot_theme <- function(p) { + th <- attr(p, "theme") + if (is.null(th)) p$theme else th +} + +plot_data <- function(p) { + d <- attr(p, "data") + if (is.null(d)) p$data else d +} + +element_size <- function(el) { + size <- attr(el, "size") + if (is.null(size)) el$size else size +} diff --git a/tests/testthat/test-borrow.R b/tests/testthat/test-borrow.R new file mode 100644 index 0000000..b3effdd --- /dev/null +++ b/tests/testthat/test-borrow.R @@ -0,0 +1,24 @@ +test_that("borrow() stores the external data and the weight", { + d <- data_binary(20, 8) + b <- borrow(d, a0 = 0.5) + expect_s3_class(b, "qdm_borrow", exact = TRUE) + expect_identical(b$data, d) + expect_identical(b$a0, 0.5) + expect_identical(borrow(d, 0)$a0, 0) + expect_identical(borrow(d, 1)$a0, 1) +}) + +test_that("borrow() rejects invalid input", { + expect_error(borrow(list(n = 20, y = 8), 0.5), "created by a data_") + expect_error(borrow(data_binary(20, 8), 1.2), "'a0' must be at least 0") +}) + +test_that("borrow() accepts every kind of data", { + for (d in list(data_continuous(20, 1, 2), data_binary2(c(1, 2, 3, 4)), + data_continuous2(20, c(0, 1), diag(2)))) { + expect_identical(borrow(d, 0.3)$data, d) + } + expect_error(borrow(data_binary(20, 8), -0.1), "'a0' must be at least 0") + expect_error(borrow(data_binary(20, 8), c(0.1, 0.2)), + "'a0' must have length 1.") +}) diff --git a/tests/testthat/test-boundary_binary.R b/tests/testthat/test-boundary_binary.R new file mode 100644 index 0000000..1166344 --- /dev/null +++ b/tests/testthat/test-boundary_binary.R @@ -0,0 +1,59 @@ +test_that("boundary_binary() matches the fixed-control references", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, designs D8 and D9 + b <- boundary_binary(ref_design("D8"), 20) + expect_identical(b$grid$y_t, 0:20) + expect_identical(b$grid$n_t, rep(20L, 21L)) + expect_equal(b$p_go[12L], 0.915075681321, tolerance = 1e-10) + expect_equal(b$p_nogo[12L], 0.00168707910052, tolerance = 1e-10) + expect_equal(b$p_go, stats::pbeta(0.4, 1 + 0:20, 21 - 0:20, + lower.tail = FALSE)) + ref_d9 <- c(0.0350877192982, 0.125902992776, 0.267801857585, + 0.438080495356, 0.608359133127, 0.755060728745, + 0.865086925458, 0.93653250774, 0.975827577995, + 0.993292053664, 0.998968008256) + b9 <- boundary_binary(ref_design("D9"), 10) + expect_equal(b9$p_go, ref_d9, tolerance = 1e-10) + expect_equal(b9$p_go + b9$p_nogo, rep(1, 11L)) +}) + +test_that("boundary_binary() stacks several sample sizes without a control", { + b <- boundary_binary(ref_design("D8"), c(12, 10, 10)) + expect_identical(b$grid$n_t, rep(c(10L, 12L), c(11L, 13L))) + expect_identical(b$grid$y_t, c(0:10, 0:12)) + expect_identical(b$axes$x, "n_t") + expect_identical(b$axes$y, "y_t") + expect_null(b$axes$caption) + expect_equal(b$p_go[11L + 1:13], + stats::pbeta(0.4, 1 + 0:12, 13 - 0:12, lower.tail = FALSE)) +}) + +test_that("boundary_binary() covers all outcomes with a concurrent control", { + des <- ref_design("D1") + b <- boundary_binary(des, 12) + expect_identical(nrow(b$grid), 13L * 13L) + expect_identical(names(b$grid), c("n_t", "y_t", "n_c", "y_c")) + expect_identical(b$axes$x, "y_c") + expect_identical(b$axes$y, "y_t") + expect_identical(b$axes$xlab, "Responders in the control group (n = 12)") + expect_identical(b$axes$ylab, + "Responders in the treatment group (n = 12)") + row <- which(b$grid$y_t == 9 & b$grid$y_c == 4) + dec <- decide_binary(des, data_binary(12, 9), data_binary(12, 4)) + expect_equal(b$p_go[row], dec$prob_go) + expect_equal(b$p_nogo[row], dec$prob_nogo) + expect_equal(b$p_go[row], pbetadiff(0.2, 10, 4, 5, 9, lower.tail = FALSE)) + expect_error(boundary_binary(des, c(10, 12)), + "'n_t' must be a single number for a design with a concurrent") +}) + +test_that("boundary_binary() uses hypothetical and external controls", { + for (name in c("D3", "D4")) { + des <- ref_design(name) + b <- boundary_binary(des, 12) + dec <- decide_binary(des, data_binary(12, 7), NULL) + expect_equal(b$p_go[8L], dec$prob_go, info = name) + expect_equal(b$p_nogo[8L], dec$prob_nogo, info = name) + } + expect_error(boundary_binary(ref_design("D3"), 0), + "'n_t' must be at least 1.") +}) diff --git a/tests/testthat/test-boundary_continuous.R b/tests/testthat/test-boundary_continuous.R new file mode 100644 index 0000000..7d0dd63 --- /dev/null +++ b/tests/testthat/test-boundary_continuous.R @@ -0,0 +1,68 @@ +test_that("boundary_continuous() matches the fixed-control references", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, designs C7 and C8 + b <- boundary_continuous(ref_design_cont("C7"), 12, c(30, 25, 10), 20, + NULL) + expect_identical(b$grid$mean_t, c(10, 25, 30)) + expect_identical(names(b$grid), c("n_t", "mean_t", "sd_t")) + expect_equal(b$p_go[2L], 0.797515237746, tolerance = 1e-10) + expect_equal(b$p_nogo[2L], 0.00264736615439, tolerance = 1e-10) + # With the vague prior, the mean has a t distribution with 11 degrees of + # freedom, location ybar and scale s / sqrt(n); Go: mean + 10 > 30 + m <- c(10, 25, 30) + expect_equal(b$p_go, stats::pt((m - 20) / (20 / sqrt(12)), 11)) + expect_equal(b$p_nogo, stats::pt((5 - m) / (20 / sqrt(12)), 11)) + b8 <- boundary_continuous(ref_design_cont("C8"), 15, 9, 12, NULL) + expect_equal(b8$p_go, 0.845153264581, tolerance = 1e-10) + expect_equal(b8$p_nogo, 1 - 0.845153264581, tolerance = 1e-10) +}) + +test_that("boundary_continuous() matches a concurrent-control reference", { + # Reference: Python_reference/ref_continuous_qdm.py, design C2 + des <- ref_design_cont("C2") + b <- boundary_continuous(des, 10, c(22, 40), 24, data_continuous(8, -8, 18)) + expect_equal(b$p_go[1L], 0.472868606954, tolerance = 1e-9) + expect_equal(b$p_nogo[1L], 0.0337620028253, tolerance = 1e-9) + expect_equal(b$grid$diff, c(30, 48)) + expect_identical(b$axes$y, "diff") + expect_identical(b$axes$ylab, "Observed difference in means") + expect_match(b$axes$caption, "^Control data: ") +}) + +test_that("boundary_continuous() chooses the horizontal axis", { + des <- ref_design_cont("C3") + b <- boundary_continuous(des, 12, c(0, 25), c(15, 20, 30), NULL) + expect_identical(nrow(b$grid), 6L) + expect_identical(b$grid$sd_t, rep(c(15, 20, 30), each = 2L)) + expect_identical(b$axes$x, "sd_t") + expect_identical(b$axes$xlab, "Observed treatment standard deviation") + expect_identical(b$axes$y, "mean_t") + expect_null(b$axes$caption) + dec <- decide_continuous(des, data_continuous(12, 25, 20), NULL) + expect_equal(b$p_go[4L], dec$prob_go) + expect_equal(b$p_nogo[4L], dec$prob_nogo) + b2 <- boundary_continuous(des, c(20, 12), 25, 20, NULL) + expect_identical(b2$grid$n_t, c(12L, 20L)) + expect_identical(b2$axes$x, "n_t") + expect_identical(b2$axes$xlab, "Treatment group size") + expect_equal(b2$p_go[1L], dec$prob_go) + dec20 <- decide_continuous(des, data_continuous(20, 25, 20), NULL) + expect_equal(b2$p_go[2L], dec20$prob_go) +}) + +test_that("boundary_continuous() validates its arguments", { + des <- ref_design_cont("C3") + expect_error(boundary_continuous(des, 12, 25, NULL, NULL), + "'mean_t' and 'sd_t' must be given for a continuous endpoint.") + expect_error(boundary_continuous(des, c(10, 12), 25, c(15, 20), NULL), + "Only one of 'n_t' and 'sd_t' may have more than one value.") + expect_error(boundary_continuous(des, 12, 25, 0, NULL), + "'sd_t' must be greater than 0.") + expect_error(boundary_continuous(des, 1, 25, 20, NULL), + "'n_t' must be at least 2.") + expect_error(boundary_continuous(ref_design_cont("C1"), 12, 25, 20, + data_binary(12, 3)), + "'data_c' must be created by data_continuous\\(\\).") + expect_error(boundary_continuous(ref_design_cont("C1", "MM"), 4, 25, 20, + data_continuous(12, 0, 25)), + "\\(here 3 and 11\\)") +}) diff --git a/tests/testthat/test-boundary_continuous2.R b/tests/testthat/test-boundary_continuous2.R new file mode 100644 index 0000000..5dc1fa7 --- /dev/null +++ b/tests/testthat/test-boundary_continuous2.R @@ -0,0 +1,70 @@ +test_that("boundary_continuous2() matches the fixed-control references", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, designs KF1 and KF2 + cov_kf1 <- matrix(c(6400, 190, 190, 36), 2L) + b <- boundary_continuous2(ref_design_cont2("KF1"), 10, list(c(5, 0), 2), + cov_kf1, NULL) + expect_identical(names(b$grid), c("n_t", "mean_t1", "mean_t2")) + expect_identical(b$grid$mean_t1, c(0, 5)) + expect_equal(b$p_go[2L], 0.448613893688, tolerance = 1e-9) + expect_equal(b$p_nogo[2L], 0.104726297391, tolerance = 1e-9) + dec <- decide_continuous2(ref_design_cont2("KF1"), + data_continuous2(10, c(0, 2), cov_kf1), NULL) + expect_equal(b$p_go[1L], dec$prob_go) + expect_equal(b$p_nogo[1L], dec$prob_nogo) + expect_identical(b$axes$x, "mean_t1") + expect_identical(b$axes$y, "mean_t2") + expect_null(b$axes$caption) + b2 <- boundary_continuous2(ref_design_cont2("KF2"), 4, list(2, 1), + matrix(c(4, 1, 1, 2), 2L), NULL) + expect_equal(b2$p_go, 0.545279559813, tolerance = 1e-9) + expect_equal(b2$p_nogo, 0.13754578381, tolerance = 1e-9) +}) + +test_that("boundary_continuous2() matches a concurrent-control reference", { + # Reference: Python_reference/ref_continuous2_qdm.py, design K1 + des <- ref_design_cont2("K1") + b <- boundary_continuous2(des, 12, list(18, c(2.5, 0)), cov2(60, 5, 0.4), + ref_data_cont2$K1$c) + expect_equal(b$p_go[2L], 0.560892392845125, tolerance = 1e-9) + expect_equal(b$p_nogo[2L], 0.0606158356586099, tolerance = 1e-9) + expect_equal(b$grid$diff1, c(28, 28)) + expect_equal(b$grid$diff2, c(1, 3.5)) + expect_identical(b$axes$x, "diff1") + expect_identical(b$axes$y, "diff2") + expect_match(b$axes$caption, "^Control data: ") +}) + +test_that("boundary_continuous2() returns two probabilities for a marginal rule", { + # Reference: Python_reference/ref_continuous2_qdm.py, design K5 (rule + # "and"; Go sets R1 to R3 and R1, R4, R7; NoGo sets R7 to R9 and R3, R6, + # R9) + ref <- c(0.320405184954998, 0.0837818501873882, 0.132197515292659, + 0.0286780743996835, 0.0109233687877224, 0.0206147670294312, + 0.150916740645318, 0.0694518911782248, 0.183030607524575) + b <- boundary_continuous2(ref_design_cont2("K5"), 12, list(3, 1), + cov2(75, 5.5, 0.4), NULL) + expect_length(b$p_go, 2L) + expect_equal(b$p_go[[1L]], sum(ref[1:3]), tolerance = 1e-9) + expect_equal(b$p_go[[2L]], sum(ref[c(1, 4, 7)]), tolerance = 1e-9) + expect_equal(b$p_nogo[[1L]], sum(ref[7:9]), tolerance = 1e-9) + expect_equal(b$p_nogo[[2L]], sum(ref[c(3, 6, 9)]), tolerance = 1e-9) +}) + +test_that("boundary_continuous2() validates its arguments", { + des <- ref_design_cont2("K4") + cv <- cov2(30, 3, 0.5) + expect_error(boundary_continuous2(des, 15, c(1, 2), cv, NULL), + "'mean_t' must be a list of two") + expect_error(boundary_continuous2(des, 15, list(1, 2), NULL, NULL), + "'cov_t' must be given.") + expect_error(boundary_continuous2(des, c(10, 15), list(1, 2), cv, NULL), + "'n_t' must have length 1.") + expect_error(boundary_continuous2(des, 15, list(1, 2), diag(-1, 2), NULL), + "'cov_t' must be positive definite.") + expect_error(boundary_continuous2(ref_design_cont2("K1"), 12, list(1, 2), + cv, ref_data_cont$C1$c), + "'data_c' must be created by data_continuous2\\(\\).") + expect_error(boundary_continuous2(ref_design_cont2("K1"), 5, list(1, 2), + cv, ref_data_cont2$K1$c), + "\\(here 3 and 10\\)") +}) diff --git a/tests/testthat/test-boundary_tte.R b/tests/testthat/test-boundary_tte.R new file mode 100644 index 0000000..828276e --- /dev/null +++ b/tests/testthat/test-boundary_tte.R @@ -0,0 +1,60 @@ +test_that("boundary_tte() matches the fixed-control reference", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design T1 + b <- boundary_tte(ref_design_tte("T1"), 30, c(6, 3), c(150, 100), NULL) + expect_identical(names(b$grid), c("events_t", "exposure_t")) + expect_equal(b$grid$events_t, c(3, 6, 3, 6)) + expect_equal(b$grid$exposure_t, c(100, 100, 150, 150)) + expect_equal(b$p_go[4L], 0.686259165773, tolerance = 1e-10) + expect_equal(b$p_nogo[4L], 0.00106102273767, tolerance = 1e-10) + # Go: exp(-3 hazard) > 0.72 + 0.15; NoGo: exp(-3 hazard) < 0.72 + expect_equal(b$p_go, stats::pgamma(-log(0.87) / 3, 0.1 + b$grid$events_t, + 1 + b$grid$exposure_t)) + expect_equal(b$p_nogo, stats::pgamma(-log(0.72) / 3, 0.1 + b$grid$events_t, + 1 + b$grid$exposure_t, + lower.tail = FALSE)) + expect_identical(b$axes$x, "exposure_t") + expect_identical(b$axes$y, "events_t") + expect_null(b$axes$caption) + b0 <- boundary_tte(ref_design_tte("T1"), 30, NULL, 150, NULL) + expect_equal(b0$grid$events_t, 0:30) + b12 <- boundary_tte(ref_design_tte("T1"), 12, NULL, 150, NULL) + expect_equal(b12$grid$events_t, 0:12) +}) + +test_that("boundary_tte() matches the references for random controls", { + b <- boundary_tte(ref_design_tte("T2"), 20, 5, c(40, 60), data_tte(9, 35)) + expect_equal(c(b$p_go[1L], b$p_nogo[1L]), unname(ref_prob_tte$T2), + tolerance = 1e-10) + expect_match(b$axes$caption, "^Control data: ") + for (name in c("T5", "T6")) { + b <- boundary_tte(ref_design_tte(name), 30, 6, 150, NULL) + expect_equal(c(b$p_go, b$p_nogo), unname(ref_prob_tte[[name]]), + tolerance = 1e-10, info = name) + } +}) + +test_that("boundary_tte() estimates predictive probabilities", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design T3 (Monte Carlo + # estimate with 10000 simulated future studies) + set.seed(11) + b <- boundary_tte(ref_design_tte("T3"), 30, c(6, 20), 70, NULL) + ref <- 0.917785289262 + expect_lt(abs(b$p_go[1L] - ref), 4.5 * sqrt(ref * (1 - ref) / 1e4) + 0.002) + expect_equal(b$p_go + b$p_nogo, c(1, 1)) + expect_lt(b$p_go[2L], b$p_go[1L]) +}) + +test_that("boundary_tte() validates its arguments", { + des <- ref_design_tte("T1") + expect_error(boundary_tte(des, 30, 1:3, NULL, NULL), + "'exposure_t' must be given for a time-to-event endpoint.") + expect_error(boundary_tte(des, 30, -1, 100, NULL), + "'events_t' must be at least 0.") + expect_error(boundary_tte(des, 30, 1, 0, NULL), + "'exposure_t' must be greater than 0.") + expect_error(boundary_tte(des, c(10, 20), NULL, 100, NULL), + "'n_t' must have length 1.") + expect_error(boundary_tte(ref_design_tte("T2"), 20, 1, 100, + data_binary(10, 2)), + "'data_c' must be created by data_tte\\(\\).") +}) diff --git a/tests/testthat/test-cellprob_binary2.R b/tests/testthat/test-cellprob_binary2.R new file mode 100644 index 0000000..c6612da --- /dev/null +++ b/tests/testthat/test-cellprob_binary2.R @@ -0,0 +1,58 @@ +test_that("cellprob_binary2() matches the closed-form probabilities", { + # Reference values computed in Python from p11 = pi1 pi2 + rho sd1 sd2 + expect_equal(cellprob_binary2(0.3, 0.4, 0.3), + c("00" = 0.48734983296193085, "01" = 0.2126501670380691, + "10" = 0.11265016703806907, "11" = 0.18734983296193092), + tolerance = 1e-12) + expect_equal(cellprob_binary2(0.3, 0.4, -0.2), + c("00" = 0.37510011135871263, "01" = 0.3248998886412873, + "10" = 0.2248998886412873, "11" = 0.0751001113587127), + tolerance = 1e-12) +}) + +test_that("cellprob_binary2() gives independence for rho = 0", { + p <- cellprob_binary2(0.25, 0.35, 0) + expect_equal(unname(p["11"]), 0.25 * 0.35, tolerance = 1e-14) + expect_equal(unname(p["10"] + p["11"]), 0.25, tolerance = 1e-14) + expect_equal(unname(p["01"] + p["11"]), 0.35, tolerance = 1e-14) + expect_equal(sum(p), 1, tolerance = 1e-14) +}) + +test_that("cellprob_binary2() rejects infeasible correlations", { + # For pi1 = 0.1 and pi2 = 0.9 the largest feasible correlation is 1/9 + expect_silent(cellprob_binary2(0.1, 0.9, 1 / 9)) + expect_error(cellprob_binary2(0.1, 0.9, 0.5), "is infeasible") + expect_error(cellprob_binary2(0, 0.5, 0), "'pi1' must be greater than 0") +}) + +test_that("cellprob_binary2() recovers the margins and the correlation", { + for (pi1 in c(0.05, 0.3, 0.5, 0.8)) { + for (pi2 in c(0.1, 0.45, 0.9)) { + sd_prod <- sqrt(pi1 * (1 - pi1) * pi2 * (1 - pi2)) + rho_min <- (max(0, pi1 + pi2 - 1) - pi1 * pi2) / sd_prod + rho_max <- (min(pi1, pi2) - pi1 * pi2) / sd_prod + for (rho in seq(rho_min, rho_max, length.out = 5)) { + p <- cellprob_binary2(pi1, pi2, rho) + info <- paste(pi1, pi2, rho) + expect_true(all(p >= 0), info = info) + expect_equal(sum(p), 1, tolerance = 1e-14, info = info) + expect_equal(unname(p["10"] + p["11"]), pi1, tolerance = 1e-12, + info = info) + expect_equal(unname(p["01"] + p["11"]), pi2, tolerance = 1e-12, + info = info) + expect_equal(unname((p["11"] - pi1 * pi2) / sd_prod), rho, + tolerance = 1e-10, info = info) + } + } + } +}) + +test_that("cellprob_binary2() applies the tolerance to the feasible range", { + rho_max <- 1 / 9 + expect_silent(cellprob_binary2(0.1, 0.9, rho_max + 1e-11)) + expect_error(cellprob_binary2(0.1, 0.9, rho_max + 1e-6), "is infeasible") + expect_silent(cellprob_binary2(0.1, 0.9, rho_max + 1e-6, tol = 1e-5)) + expect_error(cellprob_binary2(0.1, 0.9, -1.1), "is infeasible") + expect_error(cellprob_binary2(0.3, 0.4, 0, tol = -1), + "'tol' must be at least 0.") +}) diff --git a/tests/testthat/test-cellprob_scenarios.R b/tests/testthat/test-cellprob_scenarios.R new file mode 100644 index 0000000..623b69e --- /dev/null +++ b/tests/testthat/test-cellprob_scenarios.R @@ -0,0 +1,6 @@ +test_that("cellprob_scenarios() gives NA for infeasible correlations", { + out <- cellprob_scenarios(c(0.3, 0.35), c(0.4, 0.15), c(0.3, 0.6)) + expect_equal(out[1L, ], cellprob_binary2(0.3, 0.4, 0.3)) + expect_true(all(is.na(out[2L, ]))) + expect_identical(colnames(out), c("00", "01", "10", "11")) +}) diff --git a/tests/testthat/test-check_color.R b/tests/testthat/test-check_color.R new file mode 100644 index 0000000..c9102ff --- /dev/null +++ b/tests/testthat/test-check_color.R @@ -0,0 +1,16 @@ +test_that("check_color() accepts color names and hexadecimal codes", { + expect_invisible(check_color("red", "col_go")) + expect_identical(check_color("#658D1B", "col_go"), "#658D1B") + expect_identical(check_color("#658D1B80", "col_go"), "#658D1B80") + expect_identical(check_color("gray80", "col_gray"), "gray80") +}) + +test_that("check_color() rejects anything else", { + msg <- "'col_go' must be a single color name or hexadecimal color code." + expect_error(check_color("nocolor", "col_go"), msg, fixed = TRUE) + expect_error(check_color("#12345", "col_go"), msg, fixed = TRUE) + expect_error(check_color(c("red", "blue"), "col_go"), msg, fixed = TRUE) + expect_error(check_color(NA_character_, "col_go"), msg, fixed = TRUE) + expect_error(check_color(2, "col_go"), msg, fixed = TRUE) + expect_error(check_color(character(0), "col_go"), msg, fixed = TRUE) +}) diff --git a/tests/testthat/test-check_conduct.R b/tests/testthat/test-check_conduct.R new file mode 100644 index 0000000..b0a388f --- /dev/null +++ b/tests/testthat/test-check_conduct.R @@ -0,0 +1,15 @@ +test_that("check_conduct() accepts the conduct of a study", { + co <- conduct_tte(accrual_time = c(0, 12), cut_events = 20) + expect_identical(check_conduct(co, "conduct", 20L), co) + expect_null(check_conduct(NULL, "conduct", 20L, allow_null = TRUE)) +}) + +test_that("check_conduct() rejects other objects and too many events", { + co <- conduct_tte(accrual_time = c(0, 12), cut_events = 20) + expect_error(check_conduct(NULL, "conduct_future", 20L), + "'conduct_future' must be created by conduct_tte\\(\\).") + expect_error(check_conduct(list(), "conduct", 20L), + "'conduct' must be created by conduct_tte\\(\\).") + expect_error(check_conduct(co, "conduct", 19L), + "The analysis of 'conduct' is at event 20, but the study has only 19 subjects.") +}) diff --git a/tests/testthat/test-check_design.R b/tests/testthat/test-check_design.R new file mode 100644 index 0000000..f6477a6 --- /dev/null +++ b/tests/testthat/test-check_design.R @@ -0,0 +1,7 @@ +test_that("check_design() accepts designs only", { + des <- ref_design("D1") + expect_identical(check_design(des), des) + expect_invisible(check_design(des)) + expect_error(check_design(crit_post()), + "'design' must be created by a design_\\*\\(\\) function") +}) diff --git a/tests/testthat/test-check_df_mm.R b/tests/testthat/test-check_df_mm.R new file mode 100644 index 0000000..55f7c0d --- /dev/null +++ b/tests/testthat/test-check_df_mm.R @@ -0,0 +1,11 @@ +test_that("check_df_mm() requires more than 4 degrees of freedom for MM", { + expect_null(check_df_mm(4.5, 30, "MM")) + expect_null(check_df_mm(2, 1, "NI")) + expect_null(check_df_mm(2, 1, "MC")) + expect_error(check_df_mm(4, 30, "MM"), + "more than 4 degrees of freedom \\(here 4 and 30\\)") + expect_error(check_df_mm(11, 3.5, "MM"), "\\(here 11 and 3.5\\)") + expect_error(check_df_mm(4, 30, "MM"), "Use method = \"NI\" or \"MC\".") + expect_error(check_df_mm(4, 30, "MM", "method = \"MC\""), + "\\(here 4 and 30\\). Use method = \"MC\".") +}) diff --git a/tests/testthat/test-check_external_binary.R b/tests/testthat/test-check_external_binary.R new file mode 100644 index 0000000..0f10717 --- /dev/null +++ b/tests/testthat/test-check_external_binary.R @@ -0,0 +1,10 @@ +test_that("check_external_binary() accepts NULL and binary external data", { + ext <- borrow(data_binary(20, 6), 0.5) + expect_null(check_external_binary(NULL, "e")) + expect_identical(check_external_binary(ext, "e"), ext) + expect_error(check_external_binary(data_binary(20, 6), "ext"), + "'ext' must be NULL or created by borrow\\(\\) with data_binary") + expect_error(check_external_binary(borrow(data_binary2(c(1, 2, 3, 4)), + 0.5), "ext"), + "'ext' must be NULL") +}) diff --git a/tests/testthat/test-check_external_binary2.R b/tests/testthat/test-check_external_binary2.R new file mode 100644 index 0000000..37b90b1 --- /dev/null +++ b/tests/testthat/test-check_external_binary2.R @@ -0,0 +1,9 @@ +test_that("check_external_binary2() accepts NULL and data_binary2()", { + expect_null(check_external_binary2(NULL, "external_t")) + ext <- borrow(data_binary2(c(1, 2, 3, 4)), 0.5) + expect_identical(check_external_binary2(ext, "external_t"), ext) + expect_error(check_external_binary2(borrow(data_binary(10, 3), 0.5), + "external_c"), + paste("'external_c' must be NULL or created by borrow\\(\\)", + "with data_binary2\\(\\).")) +}) diff --git a/tests/testthat/test-check_external_continuous.R b/tests/testthat/test-check_external_continuous.R new file mode 100644 index 0000000..2967867 --- /dev/null +++ b/tests/testthat/test-check_external_continuous.R @@ -0,0 +1,14 @@ +test_that("check_external_continuous() accepts NULL and continuous data", { + expect_null(check_external_continuous(NULL, "external_t")) + ext <- borrow(data_continuous(20, 1, 2), 0.5) + expect_identical(check_external_continuous(ext, "external_t"), ext) +}) + +test_that("check_external_continuous() rejects other objects", { + msg <- paste("'external_c' must be NULL or created by borrow\\(\\) with", + "data_continuous\\(\\).") + expect_error(check_external_continuous(borrow(data_binary(20, 8), 0.5), + "external_c"), msg) + expect_error(check_external_continuous(data_continuous(20, 1, 2), + "external_c"), msg) +}) diff --git a/tests/testthat/test-check_external_continuous2.R b/tests/testthat/test-check_external_continuous2.R new file mode 100644 index 0000000..20871fc --- /dev/null +++ b/tests/testthat/test-check_external_continuous2.R @@ -0,0 +1,13 @@ +test_that("check_external_continuous2() accepts two continuous endpoints", { + expect_null(check_external_continuous2(NULL, "e")) + ext <- borrow(data_continuous2(10, c(1, 2), diag(2)), 0.5) + expect_identical(check_external_continuous2(ext, "e"), ext) + expect_error(check_external_continuous2(borrow(data_binary2(c(1, 2, 3, 4)), + 0.5), "external_c"), + paste("'external_c' must be NULL or created by borrow\\(\\)", + "with data_continuous2\\(\\).")) + expect_error(check_external_continuous2(data_continuous2(10, c(1, 2), + diag(2)), + "external_t"), + "'external_t' must be NULL") +}) diff --git a/tests/testthat/test-check_external_tte.R b/tests/testthat/test-check_external_tte.R new file mode 100644 index 0000000..e37dc7a --- /dev/null +++ b/tests/testthat/test-check_external_tte.R @@ -0,0 +1,10 @@ +test_that("check_external_tte() accepts NULL and time-to-event data", { + ext <- borrow(data_tte(4, 30), 0.5) + expect_null(check_external_tte(NULL, "external_t")) + expect_identical(check_external_tte(ext, "external_t"), ext) + expect_error(check_external_tte(borrow(data_binary(10, 2), 0.5), + "external_c"), + "'external_c' must be NULL or created by borrow\\(\\) with data_tte") + expect_error(check_external_tte(data_tte(4, 30), "external_t"), + "'external_t' must be NULL or created by borrow") +}) diff --git a/tests/testthat/test-check_fixed_c.R b/tests/testthat/test-check_fixed_c.R new file mode 100644 index 0000000..91d0bc4 --- /dev/null +++ b/tests/testthat/test-check_fixed_c.R @@ -0,0 +1,19 @@ +test_that("check_fixed_c() returns NULL or the values", { + expect_null(check_fixed_c(NULL, 1L, probability = TRUE)) + expect_identical(check_fixed_c(0.2, 1L, probability = TRUE), 0.2) + expect_identical(check_fixed_c(c(0L, 1L), 2L, probability = TRUE), c(0, 1)) + expect_identical(check_fixed_c(-10, 1L, probability = FALSE), -10) +}) + +test_that("check_fixed_c() checks the length and the range", { + expect_error(check_fixed_c(c(0.2, 0.3), 1L, probability = TRUE), + "'fixed_c' must have length 1.") + expect_error(check_fixed_c(0.2, 2L, probability = FALSE), + "'fixed_c' must have length 2.") + expect_error(check_fixed_c(1.2, 1L, probability = TRUE), + "'fixed_c' must be at least 0 and at most 1.") + expect_error(check_fixed_c(Inf, 1L, probability = FALSE), + "'fixed_c' must be finite.") + expect_error(check_fixed_c("a", 1L, probability = FALSE), + "'fixed_c' must be numeric.") +}) diff --git a/tests/testthat/test-check_flag.R b/tests/testthat/test-check_flag.R new file mode 100644 index 0000000..22b825d --- /dev/null +++ b/tests/testthat/test-check_flag.R @@ -0,0 +1,7 @@ +test_that("check_flag() accepts TRUE and FALSE only", { + expect_silent(check_flag(TRUE, "f")) + expect_silent(check_flag(FALSE, "f")) + expect_error(check_flag(NA, "f"), "'f' must be TRUE or FALSE.") + expect_error(check_flag(c(TRUE, FALSE), "f"), "'f' must be TRUE or FALSE.") + expect_error(check_flag(1, "f"), "'f' must be TRUE or FALSE.") +}) diff --git a/tests/testthat/test-check_numeric.R b/tests/testthat/test-check_numeric.R new file mode 100644 index 0000000..6532378 --- /dev/null +++ b/tests/testthat/test-check_numeric.R @@ -0,0 +1,40 @@ +test_that("check_numeric() accepts valid input and returns it invisibly", { + expect_invisible(check_numeric(1.5, "x")) + expect_identical(check_numeric(c(1, 2), "x", len = 2L), c(1, 2)) + expect_silent(check_numeric(Inf, "x", allow_inf = TRUE)) + expect_silent(check_numeric(3, "x", integer = TRUE, lower = 1)) +}) + +test_that("check_numeric() rejects invalid input with informative messages", { + expect_error(check_numeric("a", "x"), "'x' must be numeric.") + expect_error(check_numeric(numeric(0), "x"), "'x' must be numeric.") + expect_error(check_numeric(c(1, 2), "x"), "'x' must have length 1.") + expect_error(check_numeric(NA_real_, "x"), "'x' must not contain missing") + expect_error(check_numeric(Inf, "x"), "'x' must be finite.") + expect_error(check_numeric(1.5, "x", integer = TRUE), "whole numbers") + expect_error(check_numeric(0, "x", lower = 0, lower_open = TRUE), + "'x' must be greater than 0.") + expect_error(check_numeric(-1, "x", lower = 0), "'x' must be at least 0.") + expect_error(check_numeric(1, "x", lower = 0, upper = 1, upper_open = TRUE), + "'x' must be at least 0 and less than 1.") +}) + +test_that("check_numeric() describes one-sided and two-sided bounds", { + expect_error(check_numeric(2, "x", upper = 1), "'x' must be at most 1.") + expect_error(check_numeric(1, "x", upper = 1, upper_open = TRUE), + "'x' must be less than 1.") + expect_error(check_numeric(-1, "x", lower = 0, upper = 1), + "'x' must be at least 0 and at most 1.") + expect_error(check_numeric(c(1, 2), "x", len = 3L), + "'x' must have length 3.") + expect_error(check_numeric(c(0, 2), "x", len = NULL, upper = 1), + "'x' must be at most 1.") + expect_silent(check_numeric(c(0, 1), "x", len = NULL, lower = 0, upper = 1)) +}) + +test_that("check_numeric() tolerates rounding error in whole numbers", { + expect_silent(check_numeric(3 + 1e-10, "x", integer = TRUE)) + expect_silent(check_numeric(Inf, "x", integer = TRUE, allow_inf = TRUE)) + expect_error(check_numeric(c(1, 2.5), "x", len = NULL, integer = TRUE), + "whole numbers") +}) diff --git a/tests/testthat/test-check_pd_matrix.R b/tests/testthat/test-check_pd_matrix.R new file mode 100644 index 0000000..2489921 --- /dev/null +++ b/tests/testthat/test-check_pd_matrix.R @@ -0,0 +1,25 @@ +test_that("check_pd_matrix() accepts symmetric positive definite matrices", { + expect_silent(check_pd_matrix(diag(2), "m")) + expect_silent(check_pd_matrix(matrix(c(4, 1.2, 1.2, 2), 2), "m")) +}) + +test_that("check_pd_matrix() rejects other matrices", { + expect_error(check_pd_matrix(diag(3), "m"), "'m' must be a numeric 2 x 2") + expect_error(check_pd_matrix(c(1, 0, 0, 1), "m"), "'m' must be a numeric") + expect_error(check_pd_matrix(matrix(c(1, 0.5, 0, 1), 2), "m"), + "'m' must be symmetric.") + expect_error(check_pd_matrix(matrix(c(1, 2, 2, 1), 2), "m"), + "'m' must be positive definite.") + expect_error(check_pd_matrix(matrix(c(1, NA, NA, 1), 2), "m"), + "'m' must contain finite values only.") +}) + +test_that("check_pd_matrix() supports other dimensions and tolerates rounding", { + expect_silent(check_pd_matrix(diag(3), "m", dim = 3L)) + m <- matrix(c(2, 0.5, 0.5 + 1e-12, 1), 2) + expect_silent(check_pd_matrix(m, "m")) + expect_error(check_pd_matrix(matrix(c("a", "b", "c", "d"), 2), "m"), + "'m' must be a numeric 2 x 2 matrix.") + expect_error(check_pd_matrix(matrix(c(1, 0, 0, 0), 2), "m"), + "'m' must be positive definite.") +}) diff --git a/tests/testthat/test-check_prior_beta.R b/tests/testthat/test-check_prior_beta.R new file mode 100644 index 0000000..7410282 --- /dev/null +++ b/tests/testthat/test-check_prior_beta.R @@ -0,0 +1,8 @@ +test_that("check_prior_beta() accepts Beta priors only", { + pr <- prior_beta(1, 2) + expect_identical(check_prior_beta(pr, "p"), pr) + expect_invisible(check_prior_beta(pr, "p")) + expect_error(check_prior_beta(prior_vague(), "prior_x"), + "'prior_x' must be created by prior_beta().") + expect_error(check_prior_beta(NULL, "prior_x"), "'prior_x' must be") +}) diff --git a/tests/testthat/test-check_prior_continuous.R b/tests/testthat/test-check_prior_continuous.R new file mode 100644 index 0000000..e1114db --- /dev/null +++ b/tests/testthat/test-check_prior_continuous.R @@ -0,0 +1,13 @@ +test_that("check_prior_continuous() accepts NIX and vague priors", { + p <- prior_nix(0, 1, 3, 2) + expect_identical(check_prior_continuous(p, "prior_t"), p) + expect_invisible(check_prior_continuous(prior_vague(), "prior_t")) +}) + +test_that("check_prior_continuous() rejects other objects", { + expect_error(check_prior_continuous(prior_beta(1, 1), "prior_c"), + paste("'prior_c' must be created by prior_nix\\(\\) or", + "prior_vague\\(\\).")) + expect_error(check_prior_continuous(NULL, "prior_c"), + "'prior_c' must be created by prior_nix") +}) diff --git a/tests/testthat/test-check_prior_continuous2.R b/tests/testthat/test-check_prior_continuous2.R new file mode 100644 index 0000000..78b896e --- /dev/null +++ b/tests/testthat/test-check_prior_continuous2.R @@ -0,0 +1,8 @@ +test_that("check_prior_continuous2() accepts NIW and vague priors", { + expect_invisible(check_prior_continuous2(prior_vague(), "p")) + pr <- prior_niw(c(0, 0), 1, 3, diag(2)) + expect_identical(check_prior_continuous2(pr, "p"), pr) + expect_error(check_prior_continuous2(prior_nix(0, 1, 2, 3), "prior_c"), + "'prior_c' must be created by prior_niw\\(\\) or prior_vague") + expect_error(check_prior_continuous2(NULL, "prior_t"), "'prior_t' must be") +}) diff --git a/tests/testthat/test-check_prior_control.R b/tests/testthat/test-check_prior_control.R new file mode 100644 index 0000000..02b9faa --- /dev/null +++ b/tests/testthat/test-check_prior_control.R @@ -0,0 +1,21 @@ +test_that("check_prior_control() requires NULL when the prior is not used", { + pr <- prior_beta(1, 1) + expect_null(check_prior_control(NULL, "fixed", check_prior_beta)) + expect_error(check_prior_control(pr, "fixed", check_prior_beta), + "'prior_c' must be NULL for a fixed control, whose value is") + expect_error(check_prior_control(prior_vague(), "hypothetical", + check_prior_continuous, + unused = c("hypothetical", "fixed")), + "'prior_c' must be NULL for a hypothetical control, whose") +}) + +test_that("check_prior_control() checks the prior otherwise", { + pr <- prior_beta(1, 1) + expect_identical(check_prior_control(pr, "concurrent", check_prior_beta), + pr) + expect_error(check_prior_control(NULL, "external", check_prior_beta), + "'prior_c' must be created by prior_beta().") + expect_error(check_prior_control(prior_vague(), "hypothetical", + check_prior_beta), + "'prior_c' must be created by prior_beta().") +}) diff --git a/tests/testthat/test-check_prior_dirichlet.R b/tests/testthat/test-check_prior_dirichlet.R new file mode 100644 index 0000000..c38c8ee --- /dev/null +++ b/tests/testthat/test-check_prior_dirichlet.R @@ -0,0 +1,6 @@ +test_that("check_prior_dirichlet() accepts only Dirichlet priors", { + p <- prior_dirichlet(rep(1, 4)) + expect_identical(check_prior_dirichlet(p, "prior_t"), p) + expect_error(check_prior_dirichlet(prior_vague(), "prior_c"), + "'prior_c' must be created by prior_dirichlet\\(\\).") +}) diff --git a/tests/testthat/test-check_prior_gamma.R b/tests/testthat/test-check_prior_gamma.R new file mode 100644 index 0000000..09225f8 --- /dev/null +++ b/tests/testthat/test-check_prior_gamma.R @@ -0,0 +1,6 @@ +test_that("check_prior_gamma() accepts only Gamma priors", { + p <- prior_gamma(1, 1) + expect_identical(check_prior_gamma(p, "prior_t"), p) + expect_error(check_prior_gamma(prior_beta(1, 1), "prior_c"), + "'prior_c' must be created by prior_gamma\\(\\).") +}) diff --git a/tests/testthat/test-check_regions.R b/tests/testthat/test-check_regions.R new file mode 100644 index 0000000..d602437 --- /dev/null +++ b/tests/testthat/test-check_regions.R @@ -0,0 +1,12 @@ +test_that("check_regions() returns sorted integer region sets", { + out <- check_regions(c(4, 1), 9, n_regions = 9L) + expect_identical(out, list(go = c(1L, 4L), nogo = 9L)) +}) + +test_that("check_regions() rejects invalid region sets", { + expect_error(check_regions(10, 9, 9L), "'go_regions' must be at least 1") + expect_error(check_regions(1.5, 9, 9L), "whole numbers") + expect_error(check_regions(c(1, 1), 9, 9L), "'go_regions' must not contain") + expect_error(check_regions(1, c(9, 9), 9L), "'nogo_regions' must not") + expect_error(check_regions(c(1, 9), 9, 9L), "must not share any region") +}) diff --git a/tests/testthat/test-check_rule.R b/tests/testthat/test-check_rule.R new file mode 100644 index 0000000..11fedad --- /dev/null +++ b/tests/testthat/test-check_rule.R @@ -0,0 +1,17 @@ +test_that("check_rule() returns the settings of the criteria", { + one <- check_rule("and", 1L, 0.5, 0.6, 1L, 9L, FALSE, 9L) + expect_identical(one, list(rule = "joint", gamma_go = 0.5, + gamma_nogo = 0.6, go = NULL, nogo = NULL)) + joint <- check_rule("joint", 2L, 0.5, 0.6, c(2, 1), 9, TRUE, 9L) + expect_identical(joint$go, 1:2) + expect_identical(joint$nogo, 9L) + marg <- check_rule("or", 2L, 0.5, c(0.6, 0.7), 1L, 9L, FALSE, 9L) + expect_identical(marg, list(rule = "or", gamma_go = c(0.5, 0.5), + gamma_nogo = c(0.6, 0.7), go = NULL, + nogo = NULL)) + expect_error(check_rule("or", 2L, 0.5, 0.5, 1L, 9L, TRUE, 9L), + "'go_regions' and 'nogo_regions' are used only") + expect_error(check_rule("and", 2L, 0.5, c(0.1, 0.2, 0.3), 1L, 9L, FALSE, + 9L), + "With rule = \"and\", 'gamma_go' and 'gamma_nogo' must") +}) diff --git a/tests/testthat/test-check_scenarios.R b/tests/testthat/test-check_scenarios.R new file mode 100644 index 0000000..355a645 --- /dev/null +++ b/tests/testthat/test-check_scenarios.R @@ -0,0 +1,84 @@ +test_that("check_scenarios() returns a plain data frame", { + des <- ref_design("D1") + sc <- check_scenarios(des, scen_c) + expect_identical(sc, scen_c) + # A tibble-like data frame is converted + tb <- structure(scen_c, class = c("tbl_df", "tbl", "data.frame")) + expect_identical(class(check_scenarios(des, tb)), "data.frame") +}) + +test_that("check_scenarios() validates the scenarios", { + des <- ref_design("D1") + expect_error(check_scenarios(des, scen_c[0, ]), + "'scenarios' must be a data frame with at least one row.") + expect_error(check_scenarios(des, scen_c, "sc", one_row = TRUE), + "'sc' must have exactly one row.") + expect_error(check_scenarios(des, data.frame(pi_c = 0.3)), + "must have the column\\(s\\) pi_t, pi_c.") + expect_error(check_scenarios(ref_design("D3"), data.frame(x = 0.3)), + "must have the column\\(s\\) pi_t.") + expect_error(check_scenarios(des, data.frame(pi_t = 0.3, + pi_c = NA_real_)), + "'scenarios\\$pi_c' must not contain missing values.") + expect_error(check_scenarios(des, data.frame(pi_t = -0.1, pi_c = 0.2)), + "'scenarios\\$pi_t' must be at least 0 and at most 1.") + expect_error(check_scenarios(des, data.frame(pi_t = "a", pi_c = 0.2)), + "'scenarios\\$pi_t' must be numeric.") + expect_error(check_scenarios(des, data.frame(pi_t = 0.3, pi_c = 0.2, + Miss = 0)), + "must not have columns named Go, NoGo, Gray or Miss.") +}) + +test_that("check_scenarios() validates the scenarios of continuous designs", { + des <- ref_design_cont("C1") + expect_identical(check_scenarios(des, scen_cont_c), scen_cont_c) + expect_error(check_scenarios(des, data.frame(mu_t = 1, sd_t = 1, mu_c = 0)), + "must have the column\\(s\\) mu_t, sd_t, mu_c, sd_c.") + expect_error(check_scenarios(des, data.frame(mu_t = 1, sd_t = 1, mu_c = 0, + sd_c = -1)), + "'scenarios\\$sd_c' must be greater than 0.") + expect_error(check_scenarios(des, data.frame(mu_t = Inf, sd_t = 1, + mu_c = 0, sd_c = 1)), + "'scenarios\\$mu_t' must be finite.") + u <- data.frame(mu_t = c(-5, 5), sd_t = c(1, 2)) + expect_identical(check_scenarios(ref_design_cont("C3"), u), u) +}) + +test_that("check_scenarios() validates scenarios for two binary endpoints", { + des <- ref_design_bin2("B1") + expect_identical(check_scenarios(des, scen_bin2), scen_bin2) + bad <- scen_bin2[1, ] + bad$pi_t1 <- 1 + expect_error(check_scenarios(des, bad), + "'scenarios\\$pi_t1' must be greater than 0 and less than 1.") + bad <- scen_bin2[1, ] + bad$rho_c <- 1.5 + expect_error(check_scenarios(des, bad), + "'scenarios\\$rho_c' must be at least -1 and at most 1.") + # Infeasible correlations are accepted unless feasibility is required + inf <- scen_bin2[1, ] + inf$rho_t <- -0.9 + expect_identical(check_scenarios(des, inf), inf) + expect_error(check_scenarios(des, inf, "sc", feasible = TRUE), + "'sc\\$rho_t' is outside the feasible range") + inf_c <- scen_bin2[1, ] + inf_c$rho_c <- -0.9 + expect_error(check_scenarios(des, inf_c, "sc", feasible = TRUE), + "'sc\\$rho_c' is outside the feasible range") +}) + +test_that("check_scenarios() validates scenarios of two continuous endpoints", { + des <- ref_design_cont2("K1") + sc <- scen_cont2("K1") + expect_identical(check_scenarios(des, sc), sc) + bad <- sc[1, ] + bad$rho_t <- 1 + expect_error(check_scenarios(des, bad), + "'scenarios\\$rho_t' must be greater than -1 and less than 1.") + bad <- sc[1, ] + bad$sd_c2 <- 0 + expect_error(check_scenarios(des, bad), + "'scenarios\\$sd_c2' must be greater than 0.") + expect_error(check_scenarios(des, sc[, 1:5]), + "must have the column\\(s\\) mu_t1, mu_t2, sd_t1, sd_t2, rho_t") +}) diff --git a/tests/testthat/test-conduct_args.R b/tests/testthat/test-conduct_args.R new file mode 100644 index 0000000..5a6dffc --- /dev/null +++ b/tests/testthat/test-conduct_args.R @@ -0,0 +1,13 @@ +test_that("conduct_args() gives the arguments of the C++ functions", { + co <- conduct_tte(accrual_time = c(0, 5, 10), accrual_rate = c(1, 3), + dropout_time = c(0, 2), dropout_hazard = c(0, 0.1), + cut_time = 12) + expect_identical(conduct_args(co), + list(acc_time = c(0, 5, 10), acc_cum = c(0.25, 1), + drop_start = c(0, 2), drop_hazard = c(0, 0.1), + cut_time = 12, cut_events = 0L)) + co2 <- conduct_tte(accrual_time = c(0, 12), cut_events = 20) + a2 <- conduct_args(co2) + expect_identical(a2$cut_time, Inf) + expect_identical(a2$cut_events, 20L) +}) diff --git a/tests/testthat/test-conduct_tte.R b/tests/testthat/test-conduct_tte.R new file mode 100644 index 0000000..27dc7a5 --- /dev/null +++ b/tests/testthat/test-conduct_tte.R @@ -0,0 +1,52 @@ +test_that("conduct_tte() stores the conduct of a study", { + co <- conduct_tte(accrual_time = c(0, 5, 10, 15), + accrual_rate = c(0.4, 2, 4.5), dropout_hazard = 0.00226, + cut_time = 15.44) + expect_s3_class(co, "qdm_conduct", exact = TRUE) + expect_identical(co$accrual_time, c(0, 5, 10, 15)) + # Interval probabilities proportional to rate times length (2, 10, 22.5) + expect_equal(co$accrual_cum, cumsum(c(2, 10, 22.5)) / 34.5) + expect_identical(co$dropout_time, 0) + expect_identical(co$dropout_hazard, 0.00226) + expect_identical(co$cut_time, 15.44) + expect_null(co$cut_events) + co2 <- conduct_tte(accrual_time = c(0, 12), cut_events = 20) + expect_identical(co2$accrual_rate, 1) + expect_identical(co2$accrual_cum, 1) + expect_identical(co2$cut_events, 20L) + expect_null(co2$cut_time) + # Intervals without enrollment + co3 <- conduct_tte(accrual_time = c(0, 2, 4), accrual_rate = c(1, 0), + cut_time = 10) + expect_identical(co3$accrual_cum, c(1, 1)) +}) + +test_that("conduct_tte() validates its arguments", { + expect_error(conduct_tte(accrual_time = 5, cut_time = 1), + "'accrual_time' must be an increasing vector of at least two") + expect_error(conduct_tte(accrual_time = c(1, 5), cut_time = 1), + "starts at 0") + expect_error(conduct_tte(accrual_time = c(0, 5, 5), cut_time = 1), + "'accrual_time' must be an increasing vector") + expect_error(conduct_tte(accrual_time = c(0, 5), accrual_rate = c(1, 2), + cut_time = 1), + "'accrual_rate' must have length 1.") + expect_error(conduct_tte(accrual_time = c(0, 5), accrual_rate = 0, + cut_time = 1), + "'accrual_rate' must have a positive sum.") + expect_error(conduct_tte(accrual_time = c(0, 5), dropout_time = c(1, 2), + dropout_hazard = c(0, 0), cut_time = 1), + "'dropout_time' must be an increasing vector that starts at 0.") + expect_error(conduct_tte(accrual_time = c(0, 5), dropout_time = c(0, 2), + dropout_hazard = 0.1, cut_time = 1), + "'dropout_hazard' must have length 2.") + expect_error(conduct_tte(accrual_time = c(0, 5)), + "Specify exactly one of 'cut_time' and 'cut_events'.") + expect_error(conduct_tte(accrual_time = c(0, 5), cut_time = 1, + cut_events = 3), + "Specify exactly one of") + expect_error(conduct_tte(accrual_time = c(0, 5), cut_time = 0), + "'cut_time' must be greater than 0.") + expect_error(conduct_tte(accrual_time = c(0, 5), cut_events = 0.5), + "'cut_events' must contain whole numbers only.") +}) diff --git a/tests/testthat/test-control_form.R b/tests/testthat/test-control_form.R new file mode 100644 index 0000000..9214ba5 --- /dev/null +++ b/tests/testthat/test-control_form.R @@ -0,0 +1,22 @@ +test_that("control_form() identifies the form of the control group", { + ext <- borrow(data_binary(20, 6), 0.5) + hyp <- hypothetical(data_binary(12, 4)) + expect_identical(control_form(5, NULL, NULL), "concurrent") + expect_identical(control_form(5, ext, NULL), "concurrent") + expect_identical(control_form(0, ext, NULL), "external") + expect_identical(control_form(0, NULL, hyp), "hypothetical") + expect_identical(control_form(0, NULL, NULL, 0.2), "fixed") +}) + +test_that("control_form() rejects inconsistent combinations", { + ext <- borrow(data_binary(20, 6), 0.5) + hyp <- hypothetical(data_binary(12, 4)) + expect_error(control_form(5, NULL, hyp), "can be used only when 'n_c' is 0") + expect_error(control_form(5, NULL, NULL, 0.2), + "'fixed_c' can be used only when 'n_c' is 0.") + expect_error(control_form(0, NULL, NULL), "specify 'external_c'") + expect_error(control_form(0, ext, hyp), "specify only one of") + expect_error(control_form(0, ext, NULL, 0.2), "specify only one of") + expect_error(control_form(0, NULL, hyp, 0.2), + "only one of 'external_c', 'hypothetical_c' and 'fixed_c'.") +}) diff --git a/tests/testthat/test-control_location.R b/tests/testthat/test-control_location.R new file mode 100644 index 0000000..7bae39a --- /dev/null +++ b/tests/testthat/test-control_location.R @@ -0,0 +1,24 @@ +test_that("control_location() gives the center of the control distribution", { + # Binary: means of Beta(5, 9) (D3) and Beta(4, 8) (D4) + expect_equal(control_location(ref_design("D3")), 5 / 14) + expect_equal(control_location(ref_design("D4")), 1 / 3) + # Continuous: hypothetical control location (C3) and posterior mean given + # external data with mean -12 (C4) + expect_identical(control_location(ref_design_cont("C3")), -10) + expect_equal(control_location(ref_design_cont("C4")), -12) + des <- design_continuous(12, 0, prior_vague(), prior_nix(0, 6, 3, 10), + crit_cont(), + external_c = borrow(data_continuous(30, -12, 20), + 0.4)) + expect_equal(control_location(des), (6 * 0 + 12 * -12) / 18) +}) + +test_that("control_location() gives the fixed value or the mean survival", { + expect_identical(control_location(ref_design("D8")), 0.2) + expect_identical(control_location(ref_design_cont("C7")), -10) + expect_identical(control_location(ref_design_tte("T1")), 0.72) + # Hypothetical control: Gamma(8.1, 61), E[exp(-3 lambda)] = (61 / 64)^8.1 + expect_equal(control_location(ref_design_tte("T5")), (61 / 64)^8.1) + # External control only: Gamma(10.1, 51) + expect_equal(control_location(ref_design_tte("T6")), (51 / 54)^10.1) +}) diff --git a/tests/testthat/test-control_posterior_continuous.R b/tests/testthat/test-control_posterior_continuous.R new file mode 100644 index 0000000..5b7cf0e --- /dev/null +++ b/tests/testthat/test-control_posterior_continuous.R @@ -0,0 +1,33 @@ +test_that("control_posterior_continuous() uses the concurrent control data", { + des <- ref_design_cont("C2") + post_t <- posterior_continuous(des$prior_t, 10, 22, 24, des$external_t) + expect_identical( + control_posterior_continuous(des, post_t, 8, c(-8, -6), c(18, 20)), + posterior_continuous(des$prior_c, 8, c(-8, -6), c(18, 20), + external = des$external_c) + ) +}) + +test_that("control_posterior_continuous() uses the external data only", { + # Python_reference/ref_continuous_qdm.py, design C4 + des <- ref_design_cont("C4") + post_c <- control_posterior_continuous(des, list()) + expect_equal(post_c$mu, -12) + expect_equal(post_c$kappa, 12) + expect_equal(post_c$nu, 11) + expect_equal(sqrt(post_c$sigma2), 20.5382127221, tolerance = 1e-10) +}) + +test_that("control_posterior_continuous() builds the hypothetical control", { + # Kang et al. (2026), Section 4.2.4: + # mu_c ~ t(nu_nt, mu0c, r sigma_nt^2 / kappa_nt) + des <- ref_design_cont("C3") + post_t <- posterior_continuous(des$prior_t, 12, c(25, 30), c(20, 10)) + post_c <- control_posterior_continuous(des, post_t) + expect_identical(post_c, list(mu = -10, kappa = 12, nu = 11, + sigma2 = 1.5 * c(400, 100))) +}) + +test_that("control_posterior_continuous() returns NULL for a fixed control", { + expect_null(control_posterior_continuous(ref_design_cont("C7"), list())) +}) diff --git a/tests/testthat/test-control_posterior_continuous2.R b/tests/testthat/test-control_posterior_continuous2.R new file mode 100644 index 0000000..0d07db4 --- /dev/null +++ b/tests/testthat/test-control_posterior_continuous2.R @@ -0,0 +1,58 @@ +# Reference: Python_reference/ref_continuous2_qdm.py, section A (control +# groups: concurrent with external data, hypothetical, external only). +test_that("control_posterior_continuous2() covers the three control forms", { + ref <- list( + K1 = list( + mu = c(-10, -1), kappa = 12, nu = 11, + Lambda = c(53900, 924, 396) + ), + K2 = list( + mu = c(-10, -1), kappa = 30.1, nu = 34, + Lambda = c(169525, 4256.25, 1261.25) + ), + K3 = list( + mu = c(-0.67910447761194, -1.32089552238806), kappa = 20.1, nu = 24, + Lambda = c(430.585223880597, 31.604776119403, 198.075223880597) + ), + K4 = list( + mu = c(-10, -1), kappa = 15, nu = 14, + Lambda = c(18900, 945, 189) + ), + K5 = list( + mu = c(-10, -1), kappa = 10, nu = 9, + Lambda = c(46550, 997.5, 237.5) + ), + K6 = list( + mu = c(0, 0), kappa = 15, nu = 14, + Lambda = c(2800, -168, 112) + ) + ) + for (name in names(ref)) { + des <- ref_design_cont2(name) + d <- ref_data_cont2[[name]] + pt <- posterior_continuous2(des$prior_t, d$t$n, d$t$mean, d$t$cov, + external = des$external_t) + pc <- if (is.null(d$c)) { + control_posterior_continuous2(des, pt) + } else { + control_posterior_continuous2(des, pt, d$c$n, d$c$mean, d$c$cov) + } + e <- ref[[name]] + expect_equal(pc$mu, matrix(e$mu, 1L), tolerance = 1e-12, info = name) + expect_equal(pc$kappa, e$kappa, tolerance = 1e-12, info = name) + expect_equal(pc$nu, e$nu, tolerance = 1e-12, info = name) + expect_equal(unname(pc$Lambda), matrix(e$Lambda, 1L), + tolerance = 1e-12, info = name) + } + # The hypothetical control follows the rows of the treatment parameters + des <- ref_design_cont2("K4") + pt <- posterior_continuous2(des$prior_t, 15, rbind(c(1, 2), c(3, 4)), + rbind(c(4, 1, 2), c(5, 1, 3))) + pc <- control_posterior_continuous2(des, pt) + expect_equal(pc$mu, rbind(c(-10, -1), c(-10, -1))) + expect_equal(pc$Lambda, 1.5 * pt$Lambda) +}) + +test_that("control_posterior_continuous2() returns NULL for a fixed control", { + expect_null(control_posterior_continuous2(ref_design_cont2("KF1"), list())) +}) diff --git a/tests/testthat/test-criterion_posterior.R b/tests/testthat/test-criterion_posterior.R new file mode 100644 index 0000000..919fcd6 --- /dev/null +++ b/tests/testthat/test-criterion_posterior.R @@ -0,0 +1,76 @@ +test_that("criterion_posterior() for one endpoint ignores the regions", { + cr <- criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) + expect_s3_class(cr, c("qdm_criterion_posterior", "qdm_criterion"), + exact = TRUE) + expect_identical(cr$n_endpoints, 1L) + expect_identical(cr$theta_tv, 0.2) + expect_identical(cr$gamma_nogo, 0.8) + expect_null(cr$go_regions) + expect_null(cr$nogo_regions) +}) + +test_that("criterion_posterior() for two endpoints stores the regions", { + cr <- criterion_posterior(theta_tv = c(0.2, 0.15), theta_mav = c(0.1, 0), + gamma_go = 0.3, gamma_nogo = 0.4, + go_regions = c(4, 1), nogo_regions = c(9, 8)) + expect_identical(cr$n_endpoints, 2L) + expect_identical(cr$go_regions, c(1L, 4L)) + expect_identical(cr$nogo_regions, c(8L, 9L)) + default <- criterion_posterior(c(0.2, 0.15), c(0.1, 0), 0.3, 0.4) + expect_identical(default$go_regions, 1L) + expect_identical(default$nogo_regions, 9L) +}) + +test_that("criterion_posterior() rejects invalid input", { + expect_error(criterion_posterior(c(1, 2, 3), c(0, 0, 0), 0.5, 0.5), + "'theta_tv' must have length 1") + expect_error(criterion_posterior(0.2, c(0.1, 0), 0.5, 0.5), + "'theta_mav' must have length 1.") + expect_error(criterion_posterior(0.1, 0.1, 0.5, 0.5), + "must be greater than that of 'theta_mav'") + expect_error(criterion_posterior(0.2, 0.1, 1, 0.5), + "'gamma_go' must be greater than 0 and less than 1.") + expect_error(criterion_posterior(0.2, 0.1, 0.5, 0), + "'gamma_nogo' must be greater than 0 and less than 1.") + expect_error(criterion_posterior(c(0.2, 0.2), c(0, 0), 0.5, 0.5, + go_regions = 1, nogo_regions = 1), + "must not share any region") +}) + +test_that("criterion_posterior() coerces region numbers to integers", { + cr <- criterion_posterior(c(0.2, 0.15), c(0.1, 0), 0.3, 0.4, + go_regions = c(1, 2, 4), nogo_regions = 9) + expect_type(cr$go_regions, "integer") + expect_identical(cr$go_regions, c(1L, 2L, 4L)) + expect_error(criterion_posterior(c(0.2, 0.15), c(0.1, 0), 0.3, 0.4, + go_regions = 0), + "'go_regions' must be at least 1 and at most 9.") +}) + +test_that("criterion_posterior() supports marginal rules for two endpoints", { + cr <- criterion_posterior(c(0.2, 0.15), c(0.1, 0), gamma_go = c(0.6, 0.5), + gamma_nogo = 0.7, rule = "and") + expect_identical(cr$rule, "and") + expect_identical(cr$gamma_go, c(0.6, 0.5)) + expect_identical(cr$gamma_nogo, c(0.7, 0.7)) + expect_null(cr$go_regions) + expect_identical(criterion_posterior(0.2, 0.1, 0.5, 0.5, rule = "or")$rule, + "joint") + expect_identical(criterion_posterior(c(0.2, 0.1), c(0, 0), 0.5, + 0.5)$rule, "joint") + expect_error(criterion_posterior(c(0.2, 0.15), c(0.1, 0), 0.5, 0.5, + go_regions = 1:2, rule = "or"), + "used only with rule = \"joint\"") + expect_error(criterion_posterior(c(0.2, 0.15), c(0.1, 0), c(0.5, 0.5), + 0.5), + "'gamma_go' must have length 1.") + expect_error(criterion_posterior(c(0.2, 0.15), c(0.1, 0), c(0.5, 0.5, 0.5), + 0.5, rule = "and"), + "must have length 1 or 2 \\(one threshold per endpoint\\)") + expect_error(criterion_posterior(c(0.2, 0.15), c(0.1, 0), c(0.5, 1), + 0.5, rule = "and"), + "'gamma_go' must be greater than 0 and less than 1.") + expect_error(criterion_posterior(0.2, 0.1, 0.5, 0.5, rule = "xor"), + "'arg' should be one of") +}) diff --git a/tests/testthat/test-criterion_predictive.R b/tests/testthat/test-criterion_predictive.R new file mode 100644 index 0000000..da024c4 --- /dev/null +++ b/tests/testthat/test-criterion_predictive.R @@ -0,0 +1,61 @@ +test_that("criterion_predictive() for one endpoint stores the settings", { + cr <- criterion_predictive(theta_null = 0, m_t = 50, gamma_go = 0.9, + gamma_nogo = 0.7) + expect_s3_class(cr, c("qdm_criterion_predictive", "qdm_criterion"), + exact = TRUE) + expect_identical(cr$m_t, 50L) + expect_identical(cr$m_c, 50L) + expect_null(cr$go_regions) +}) + +test_that("criterion_predictive() for two endpoints stores the regions", { + cr <- criterion_predictive(theta_null = c(0, 0), m_t = 40, m_c = 20, + gamma_go = 0.5, gamma_nogo = 0.5) + expect_identical(cr$n_endpoints, 2L) + expect_identical(cr$m_c, 20L) + expect_identical(cr$go_regions, 1L) + expect_identical(cr$nogo_regions, 4L) +}) + +test_that("criterion_predictive() rejects invalid input", { + expect_error(criterion_predictive(0, m_t = 0, gamma_go = 0.5, + gamma_nogo = 0.5), + "'m_t' must be at least 1.") + expect_error(criterion_predictive(0, m_t = 10, m_c = 2.5, gamma_go = 0.5, + gamma_nogo = 0.5), "whole numbers") + expect_error(criterion_predictive(c(0, 0), m_t = 10, gamma_go = 0.5, + gamma_nogo = 0.5, go_regions = 5), + "'go_regions' must be at least 1 and at most 4.") +}) + +test_that("criterion_predictive() validates the null values and thresholds", { + expect_error(criterion_predictive(c(0, 0, 0), m_t = 10, gamma_go = 0.5, + gamma_nogo = 0.5), + "'theta_null' must have length 1") + expect_error(criterion_predictive(NA_real_, m_t = 10, gamma_go = 0.5, + gamma_nogo = 0.5), + "'theta_null' must not contain missing") + expect_error(criterion_predictive(0, m_t = 10, gamma_go = 0, + gamma_nogo = 0.5), + "'gamma_go' must be greater than 0 and less than 1.") + expect_error(criterion_predictive(0, m_t = 10, gamma_go = 0.5, + gamma_nogo = 1), + "'gamma_nogo' must be greater than 0 and less than 1.") + expect_error(criterion_predictive(c(0, 0), m_t = 10, gamma_go = 0.5, + gamma_nogo = 0.5, go_regions = 1, + nogo_regions = c(1, 4)), + "must not share any region") +}) + +test_that("criterion_predictive() supports marginal rules for two endpoints", { + cr <- criterion_predictive(c(0, 0.1), m_t = 30, gamma_go = 0.6, + gamma_nogo = c(0.7, 0.8), rule = "or") + expect_identical(cr$rule, "or") + expect_identical(cr$gamma_go, c(0.6, 0.6)) + expect_identical(cr$gamma_nogo, c(0.7, 0.8)) + expect_null(cr$nogo_regions) + expect_error(criterion_predictive(c(0, 0), m_t = 30, gamma_go = 0.6, + gamma_nogo = 0.7, nogo_regions = 4, + rule = "and"), + "used only with rule = \"joint\"") +}) diff --git a/tests/testthat/test-data_binary.R b/tests/testthat/test-data_binary.R new file mode 100644 index 0000000..0afcc8e --- /dev/null +++ b/tests/testthat/test-data_binary.R @@ -0,0 +1,21 @@ +test_that("data_binary() stores integer counts", { + d <- data_binary(n = 12, y = 7) + expect_s3_class(d, c("qdm_data_binary", "qdm_data"), exact = TRUE) + expect_identical(d$n, 12L) + expect_identical(d$y, 7L) + expect_identical(data_binary(5, 0)$y, 0L) + expect_identical(data_binary(5, 5)$y, 5L) +}) + +test_that("data_binary() rejects invalid counts", { + expect_error(data_binary(0, 0), "'n' must be at least 1.") + expect_error(data_binary(10, 11), "'y' must not exceed 'n'.") + expect_error(data_binary(10, 2.5), "whole numbers") + expect_error(data_binary(10, -1), "'y' must be at least 0.") +}) + +test_that("data_binary() accepts whole numbers stored as doubles only", { + expect_identical(data_binary(12.0, 3.0)$n, 12L) + expect_error(data_binary(c(10, 12), 3), "'n' must have length 1.") + expect_error(data_binary(10.5, 3), "whole numbers") +}) diff --git a/tests/testthat/test-data_binary2.R b/tests/testthat/test-data_binary2.R new file mode 100644 index 0000000..b188890 --- /dev/null +++ b/tests/testthat/test-data_binary2.R @@ -0,0 +1,19 @@ +test_that("data_binary2() stores named integer counts and their total", { + d <- data_binary2(c(4, 2, 3, 6)) + expect_s3_class(d, c("qdm_data_binary2", "qdm_data"), exact = TRUE) + expect_identical(d$counts, c("00" = 4L, "01" = 2L, "10" = 3L, "11" = 6L)) + expect_identical(d$n, 15L) +}) + +test_that("data_binary2() rejects invalid counts", { + expect_error(data_binary2(c(1, 2, 3)), "'counts' must have length 4.") + expect_error(data_binary2(c(0, 0, 0, 0)), "at least one subject") + expect_error(data_binary2(c(1, -1, 0, 0)), "'counts' must be at least 0.") +}) + +test_that("data_binary2() ignores input names and checks whole numbers", { + d <- data_binary2(c(a = 1, b = 0, c = 0, d = 0)) + expect_identical(names(d$counts), c("00", "01", "10", "11")) + expect_identical(d$n, 1L) + expect_error(data_binary2(c(1, 0.5, 0, 0)), "whole numbers") +}) diff --git a/tests/testthat/test-data_continuous.R b/tests/testthat/test-data_continuous.R new file mode 100644 index 0000000..0544714 --- /dev/null +++ b/tests/testthat/test-data_continuous.R @@ -0,0 +1,17 @@ +test_that("data_continuous() stores the summary statistics", { + d <- data_continuous(n = 12, mean = -1.5, sd = 2) + expect_s3_class(d, c("qdm_data_continuous", "qdm_data"), exact = TRUE) + expect_identical(unclass(d), list(n = 12L, mean = -1.5, sd = 2)) +}) + +test_that("data_continuous() rejects invalid summaries", { + expect_error(data_continuous(1, 0, 1), "'n' must be at least 2.") + expect_error(data_continuous(10, 0, 0), "'sd' must be greater than 0.") + expect_error(data_continuous(10, Inf, 1), "'mean' must be finite.") +}) + +test_that("data_continuous() rejects non-numeric and vector input", { + expect_error(data_continuous(10, "1", 1), "'mean' must be numeric.") + expect_error(data_continuous(10, c(1, 2), 1), "'mean' must have length 1.") + expect_error(data_continuous(10.5, 1, 1), "whole numbers") +}) diff --git a/tests/testthat/test-data_continuous2.R b/tests/testthat/test-data_continuous2.R new file mode 100644 index 0000000..cb6d1dc --- /dev/null +++ b/tests/testthat/test-data_continuous2.R @@ -0,0 +1,22 @@ +test_that("data_continuous2() stores the summary statistics", { + S <- matrix(c(4, 1.2, 1.2, 2), 2) + d <- data_continuous2(n = 12, mean = c(3.2, 1.5), cov = S) + expect_s3_class(d, c("qdm_data_continuous2", "qdm_data"), exact = TRUE) + expect_identical(d$n, 12L) + expect_identical(d$mean, c(3.2, 1.5)) + expect_identical(d$cov, S) +}) + +test_that("data_continuous2() rejects invalid summaries", { + expect_error(data_continuous2(2, c(0, 0), diag(2)), "'n' must be at least 3.") + expect_error(data_continuous2(10, 0, diag(2)), "'mean' must have length 2.") + expect_error(data_continuous2(10, c(0, 0), matrix(c(1, 1, 1, 1), 2)), + "'cov' must be positive definite.") +}) + +test_that("data_continuous2() drops dimnames and checks symmetry", { + S <- matrix(c(4, 1, 1, 2), 2, dimnames = list(c("a", "b"), c("a", "b"))) + expect_null(dimnames(data_continuous2(10, c(0, 0), S)$cov)) + expect_error(data_continuous2(10, c(0, 0), matrix(c(4, 1, 0, 2), 2)), + "'cov' must be symmetric.") +}) diff --git a/tests/testthat/test-data_tte.R b/tests/testthat/test-data_tte.R new file mode 100644 index 0000000..052efe2 --- /dev/null +++ b/tests/testthat/test-data_tte.R @@ -0,0 +1,13 @@ +test_that("data_tte() stores the events and the total observed time", { + d <- data_tte(events = 5, exposure = 40.5) + expect_s3_class(d, c("qdm_data_tte", "qdm_data"), exact = TRUE) + expect_identical(d$events, 5L) + expect_identical(d$exposure, 40.5) + expect_identical(data_tte(0, 1)$events, 0L) +}) + +test_that("data_tte() rejects invalid data", { + expect_error(data_tte(-1, 10), "'events' must be at least 0.") + expect_error(data_tte(2.5, 10), "whole numbers") + expect_error(data_tte(2, 0), "'exposure' must be greater than 0.") +}) diff --git a/tests/testthat/test-dbetabinom.R b/tests/testthat/test-dbetabinom.R new file mode 100644 index 0000000..4219f98 --- /dev/null +++ b/tests/testthat/test-dbetabinom.R @@ -0,0 +1,22 @@ +test_that("dbetabinom() equals the direct formula for small m", { + k <- 0:10 + direct <- choose(10, k) * beta(k + 2.5, 10 - k + 1.5) / beta(2.5, 1.5) + expect_equal(dbetabinom(k, 10, 2.5, 1.5), direct, tolerance = 1e-12) +}) + +test_that("dbetabinom() sums to 1 and stays finite for large m", { + p <- dbetabinom(0:5000, 5000, 50.5, 60.5) + expect_true(all(is.finite(p))) + expect_equal(sum(p), 1, tolerance = 1e-10) +}) + +test_that("dbetabinom() sums to 1 and has the Beta-binomial mean", { + for (m in c(1, 7, 40)) { + for (s in list(c(0.5, 0.5), c(2, 9), c(30, 4))) { + p <- dbetabinom(0:m, m, s[1], s[2]) + expect_equal(sum(p), 1, tolerance = 1e-12) + expect_equal(sum((0:m) * p), m * s[1] / (s[1] + s[2]), + tolerance = 1e-10) + } + } +}) diff --git a/tests/testthat/test-decide_binary.R b/tests/testthat/test-decide_binary.R new file mode 100644 index 0000000..346e432 --- /dev/null +++ b/tests/testthat/test-decide_binary.R @@ -0,0 +1,21 @@ +test_that("decide_binary() returns probabilities and posterior parameters", { + res <- decide_binary(ref_design("D4"), data_binary(12, 7), NULL) + expect_named(res, c("prob_go", "prob_nogo", "posterior_t", "posterior_c")) + expect_equal(res$posterior_t, c(a = 8, b = 6)) + # Control: Beta(1, 1) with external data 6/20 at a0 = 0.5 + expect_equal(res$posterior_c, c(a = 4, b = 8)) + expect_equal(res$prob_go, pbetadiff(0.2, 8, 6, 4, 8, lower.tail = FALSE)) + expect_equal(res$prob_nogo, pbetadiff(0.1, 8, 6, 4, 8)) +}) + +test_that("decide_binary() handles a fixed control", { + res <- decide_binary(ref_design("D8"), data_binary(20, 11), NULL) + expect_equal(res$posterior_t, c(a = 12, b = 10)) + expect_identical(res$posterior_c, c(value = 0.2)) + # Reference: Python_reference/ref_fixed_tte_qdm.py + expect_equal(res$prob_go, 0.915075681321, tolerance = 1e-10) + expect_equal(res$prob_nogo, 0.00168707910052, tolerance = 1e-10) + expect_error(decide_binary(ref_design("D8"), data_binary(20, 11), + data_binary(10, 2)), + "'data_c' must be NULL for a design without a concurrent") +}) diff --git a/tests/testthat/test-decide_binary2.R b/tests/testthat/test-decide_binary2.R new file mode 100644 index 0000000..77954fb --- /dev/null +++ b/tests/testthat/test-decide_binary2.R @@ -0,0 +1,63 @@ +test_that("decide_binary2() returns the region probabilities and posteriors", { + # Python_reference/ref_binary2_qdm.py, case A1 + des <- ref_design_bin2("B1") + res <- decide_binary2(des, data_binary2(c(2, 1, 3, 4)), + data_binary2(c(4, 2, 3, 1))) + ref <- c(0.421763759173932, 0.221546787701068, 0.225275968676342, + 0.131413484448658) + expect_equal(res$prob_regions, c(R1 = ref[1], R2 = ref[2], R3 = ref[3], + R4 = ref[4]), tolerance = 1e-12) + expect_equal(res$prob_go, ref[1], tolerance = 1e-12) + expect_equal(res$prob_nogo, ref[4], tolerance = 1e-12) + expect_equal(res$posterior_t, + c("00" = 2.25, "01" = 1.25, "10" = 3.25, "11" = 4.25)) + # Marginal rule: one probability per endpoint + res2 <- decide_binary2(ref_design_bin2("B2"), data_binary2(c(2, 1, 3, 4)), + data_binary2(c(4, 2, 3, 1))) + expect_equal(res2$prob_go, c(ref[1] + ref[2], ref[1] + ref[3]), + tolerance = 1e-12) + expect_equal(res2$prob_nogo, c(ref[3] + ref[4], ref[2] + ref[4]), + tolerance = 1e-12) +}) + +test_that("decide_binary2() uses the fixed control distribution", { + res <- decide_binary2(ref_design_bin2("B7"), data_binary2(c(1, 0, 1, 1)), + NULL) + expect_equal(res$posterior_c, + c("00" = 2.25, "01" = 1.25, "10" = 1.25, "11" = 0.25)) + res8 <- decide_binary2(ref_design_bin2("B8"), data_binary2(c(1, 0, 1, 1)), + NULL) + expect_equal(res8$posterior_c, + c("00" = 7.25, "01" = 1.25, "10" = 1.75, "11" = 0.75)) +}) + +test_that("decide_binary2() validates the data", { + des <- ref_design_bin2("B1") + expect_error(decide_binary2(des, data_binary(3, 1), NULL), + "'data_t' must be created by data_binary2\\(\\).") + expect_error(decide_binary2(des, data_binary2(c(1, 1, 1, 0)), NULL), + "'data_c' must be created by data_binary2\\(\\) for a") + expect_error(decide_binary2(ref_design_bin2("B7"), + data_binary2(c(1, 1, 1, 0)), + data_binary2(c(1, 1, 1, 0))), + "'data_c' must be NULL for a design without a concurrent") +}) + +test_that("decide_binary2() handles a fixed control", { + # Python_reference/ref_fixed_tte_qdm.py: exact predictive probabilities + # (BF1) and 2e7 Dirichlet draws (BF2) + res <- decide_binary2(ref_design_bin2("BF1"), data_binary2(c(1, 0, 1, 1)), + NULL) + ref <- c(0.204310825893, 0.569126674107, 0.0222516741071, 0.204310825893) + expect_equal(unname(res$prob_regions), ref, tolerance = 1e-10) + expect_identical(res$posterior_c, c(value1 = 0.25, value2 = 0.5)) + set.seed(1) + res2 <- decide_binary2(ref_design_bin2("BF2", nMC = 200000L), + data_binary2(c(2, 1, 3, 4)), NULL) + ref2 <- c(0.396356, 0.285621, 0.052806, 0.094900, 0.114267, 0.028623, + 0.008864, 0.012153, 0.006411) + se <- sqrt(ref2 * (1 - ref2) / 200000) + expect_true(all(abs(res2$prob_regions - ref2) <= 4.5 * se + 2e-4)) + expect_equal(res2$prob_go, res2$prob_regions[[1]]) + expect_equal(res2$prob_nogo, res2$prob_regions[[9]]) +}) diff --git a/tests/testthat/test-decide_continuous.R b/tests/testthat/test-decide_continuous.R new file mode 100644 index 0000000..db11093 --- /dev/null +++ b/tests/testthat/test-decide_continuous.R @@ -0,0 +1,47 @@ +test_that("decide_continuous() returns the posterior parameters", { + # Python_reference/ref_continuous_qdm.py, design C2 + res <- decide_continuous(ref_design_cont("C2"), ref_data_cont$C2$t, + ref_data_cont$C2$c) + expect_equal(res$posterior_t, + c(mu = 19.3333333333, kappa = 15, nu = 17, + sigma = 23.6610045699), tolerance = 1e-10) + expect_equal(res$posterior_c, + c(mu = -10.1428571429, kappa = 21, nu = 23, + sigma = 19.6574705664), tolerance = 1e-10) + expect_equal(res$prob_go, 0.472868606954, tolerance = 1e-9) + expect_equal(res$prob_nogo, 0.0337620028253, tolerance = 1e-9) +}) + +test_that("decide_continuous() validates the data", { + des <- ref_design_cont("C1") + expect_error(decide_continuous(des, data_binary(12, 3), NULL), + "'data_t' must be created by data_continuous\\(\\).") + expect_error(decide_continuous(des, data_continuous(12, 1, 1), NULL), + "'data_c' must be created by data_continuous\\(\\) for a") + expect_error(decide_continuous(ref_design_cont("C3"), + data_continuous(12, 1, 1), + data_continuous(12, 1, 1)), + "'data_c' must be NULL for a design without a concurrent") +}) + +test_that("decide_continuous() checks the degrees of freedom for MM", { + # The observed sample sizes may be smaller than those of the design + des <- ref_design_cont("C1", method = "MM") + expect_error(decide_continuous(des, data_continuous(5, 18, 25), + data_continuous(12, -12, 25)), + "\\(here 4 and 11\\)") +}) + +test_that("decide_continuous() handles a fixed control", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design C7 + res <- decide_continuous(ref_design_cont("C7"), ref_data_cont$C7$t, NULL) + expect_equal(res$posterior_t, c(mu = 25, kappa = 12, nu = 11, sigma = 20)) + expect_identical(res$posterior_c, c(value = -10)) + expect_equal(res$prob_go, 0.797515237746, tolerance = 1e-10) + expect_equal(res$prob_nogo, 0.00264736615439, tolerance = 1e-10) + # No check of the degrees of freedom for MM, which is not used + res_mm <- decide_continuous(ref_design_cont("C7", "MM"), + data_continuous(3, 25, 20), NULL) + expect_equal(res_mm$prob_go, stats::pt(-5 / (20 / sqrt(3)), 2, + lower.tail = FALSE)) +}) diff --git a/tests/testthat/test-decide_continuous2.R b/tests/testthat/test-decide_continuous2.R new file mode 100644 index 0000000..4ce893a --- /dev/null +++ b/tests/testthat/test-decide_continuous2.R @@ -0,0 +1,97 @@ +# References: Python_reference/ref_continuous2_qdm.py, sections A and C +# (moment matching; the regions R1 to R9 of the nine-region grid, of which +# the predictive designs K3 and K6 use R1, R3, R7 and R9). +ref_dec_cont2 <- list( + K1 = c(0.560892392845125, 0.0741296786423965, 0.0922152459136311, + 0.034539315250446, 0.00700495838687196, 0.0104135124279007, + 0.128560384036125, 0.0316286768388945, 0.0606158356586099), + K2 = c(0.487770318626615, 0.0761832877719272, 0.0371748442271904, + 0.0670087840509609, 0.0173111723035729, 0.0105685362428432, + 0.182835577836786, 0.0664713667612531, 0.0546761121788512), + K3 = c(0.626051840857435, 0, 0.0991345612327038, 0, 0, 0, 0.213908233621874, + 0, 0.060905364287987), + K4 = c(0.475440903771989, 0.104478331943068, 0.0380887134173634, + 0.0739441049062476, 0.0374467301236908, 0.0200135306654595, + 0.0968179703715022, 0.0784964605938997, 0.0752732542067799), + K5 = c(0.320405184954998, 0.0837818501873882, 0.132197515292659, + 0.0286780743996835, 0.0109233687877224, 0.0206147670294312, + 0.150916740645318, 0.0694518911782248, 0.183030607524575), + K6 = c(0.478623343701189, -6.93889390390723e-18, 0.154954023476356, 0, 0, 0, + 0.322812062562545, 0, 0.0436105702599108) +) + +test_that("decide_continuous2() matches the references", { + ref <- ref_dec_cont2 + decisions <- c(K1 = "Go", K2 = "Go", K3 = "Go", K4 = "Go", K5 = "Gray", + K6 = "Gray") + go <- list(K1 = 1, K2 = 1, K3 = 1, K4 = 1:2, K5 = list(1:3, c(1, 4, 7)), + K6 = 1) + nogo <- list(K1 = 9, K2 = 9, K3 = 9, K4 = 9, K5 = list(7:9, c(3, 6, 9)), + K6 = 9) + for (name in names(ref)) { + des <- ref_design_cont2(name) + d <- ref_data_cont2[[name]] + res <- decide_continuous2(des, d$t, d$c) + cells <- if (des$criterion$type == "posterior") 1:9 else c(1, 3, 7, 9) + expect_equal(unname(res$prob_regions), ref[[name]][cells], + tolerance = 1e-9, info = name) + expect_identical(names(res$prob_regions), + paste0("R", seq_along(cells))) + sum_cells <- function(s) { + if (is.list(s)) { + return(vapply(s, sum_cells, numeric(1))) + } + sum(ref[[name]][s]) + } + expect_equal(res$prob_go, sum_cells(go[[name]]), tolerance = 1e-9, + info = name) + expect_equal(res$prob_nogo, sum_cells(nogo[[name]]), tolerance = 1e-9, + info = name) + expect_identical(names(res$posterior_t), + c("mu1", "mu2", "kappa", "nu", "L11", "L12", "L22")) + dec <- qdm_decide(des, d$t, d$c) + expect_identical(dec$decision, decisions[[name]], info = name) + } +}) + +test_that("decide_continuous2() checks the data and the degrees of freedom", { + des <- ref_design_cont2("K1") + d <- ref_data_cont2$K1 + expect_error(decide_continuous2(des, data_continuous(12, 1, 2), d$c), + "'data_t' must be created by data_continuous2\\(\\).") + expect_error(decide_continuous2(des, d$t, NULL), + "'data_c' must be created by data_continuous2\\(\\) for a") + expect_error(decide_continuous2(ref_design_cont2("K4"), d$t, d$c), + "'data_c' must be NULL for a design without a concurrent") + # Vague prior with 6 subjects: 4 degrees of freedom + small <- data_continuous2(6, c(1, 2), cov2(60, 5, 0.4)) + expect_error(decide_continuous2(des, small, d$c), + "\\(here 4 and 10\\). Use method = \"MC\".") + set.seed(3) + res <- decide_continuous2(ref_design_cont2("K1", "MC", 50000L), d$t, d$c) + expect_equal(sum(res$prob_regions), 1, tolerance = 1e-12) + expect_equal(res$prob_go, res$prob_regions[["R1"]]) + expect_equal(res$prob_nogo, res$prob_regions[["R9"]]) + ref <- ref_dec_cont2$K1 + se <- sqrt(ref * (1 - ref) / 50000) + expect_true(all(abs(res$prob_regions - ref) <= 4.5 * se + 0.002)) +}) + +test_that("decide_continuous2() handles a fixed control", { + # Python_reference/ref_fixed_tte_qdm.py: exact probabilities of the + # bivariate t distribution of the treatment mean + res <- decide_continuous2(ref_design_cont2("KF1"), ref_data_cont2$KF1$t, + NULL) + ref <- c(0.448613893688, 0.0645842074429, 0.0583932223851, 0.04589185081, + 0.0113918100151, 0.0115909475048, 0.189182932775, + 0.0656248379891, 0.104726297391) + expect_equal(unname(res$prob_regions), ref, tolerance = 1e-9) + expect_identical(res$posterior_c, c(value1 = -10, value2 = -1)) + # Two degrees of freedom (no check for MM) and the method MC, which is not + # used + res2 <- decide_continuous2(ref_design_cont2("KF2", "MC", 10L), + ref_data_cont2$KF2$t, NULL) + expect_equal(unname(res2$prob_regions), + c(0.545279559813, 0.187846642247, 0.12932801413, + 0.13754578381), tolerance = 1e-9) +}) diff --git a/tests/testthat/test-decide_tte.R b/tests/testthat/test-decide_tte.R new file mode 100644 index 0000000..a3d34e1 --- /dev/null +++ b/tests/testthat/test-decide_tte.R @@ -0,0 +1,26 @@ +test_that("decide_tte() matches the references", { + for (name in c("T1", "T2", "T5", "T6")) { + d <- ref_data_tte[[name]] + res <- decide_tte(ref_design_tte(name), d$t, d$c) + expect_equal(c(res$prob_go, res$prob_nogo), unname(ref_prob_tte[[name]]), + tolerance = 1e-10, info = name) + } + res <- decide_tte(ref_design_tte("T6"), ref_data_tte$T6$t, NULL) + expect_equal(res$posterior_t, c(shape = 8.1, rate = 166)) + expect_equal(res$posterior_c, c(shape = 10.1, rate = 51)) + expect_identical(decide_tte(ref_design_tte("T1"), ref_data_tte$T1$t, + NULL)$posterior_c, c(value = 0.72)) + res2 <- decide_tte(ref_design_tte("T2"), ref_data_tte$T2$t, + ref_data_tte$T2$c) + expect_equal(res2$posterior_c, c(shape = 9.1, rate = 36)) +}) + +test_that("decide_tte() validates the data", { + expect_error(decide_tte(ref_design_tte("T2"), data_binary(10, 2), NULL), + "'data_t' must be created by data_tte\\(\\).") + expect_error(decide_tte(ref_design_tte("T2"), data_tte(5, 40), NULL), + "'data_c' must be created by data_tte\\(\\) for a design") + expect_error(decide_tte(ref_design_tte("T1"), data_tte(5, 40), + data_tte(5, 40)), + "'data_c' must be NULL for a design without a concurrent") +}) diff --git a/tests/testthat/test-decision_colors.R b/tests/testthat/test-decision_colors.R new file mode 100644 index 0000000..bf31712 --- /dev/null +++ b/tests/testthat/test-decision_colors.R @@ -0,0 +1,14 @@ +test_that("decision_colors() names the colors by decision", { + expect_identical( + decision_colors(col_go = "#658D1B", col_nogo = "red", col_gray = "gray", + col_miss = "#E69F00"), + c(Go = "#658D1B", NoGo = "red", Gray = "gray", Miss = "#E69F00") + ) + expect_identical(decision_colors(col_nogo = "blue", col_go = "black"), + c(NoGo = "blue", Go = "black")) +}) + +test_that("decision_colors() names the invalid argument", { + expect_error(decision_colors(col_go = "red", col_gray = "grey500"), + "'col_gray' must be a single color name", fixed = TRUE) +}) diff --git a/tests/testthat/test-decision_label.R b/tests/testthat/test-decision_label.R new file mode 100644 index 0000000..ea0c27d --- /dev/null +++ b/tests/testthat/test-decision_label.R @@ -0,0 +1,6 @@ +test_that("decision_label() maps the criteria met to decisions", { + expect_identical(decision_label(c(TRUE, FALSE, FALSE, TRUE), + c(FALSE, TRUE, FALSE, TRUE)), + c("Go", "NoGo", "Gray", "Miss")) + expect_identical(decision_label(TRUE, FALSE), "Go") +}) diff --git a/tests/testthat/test-design_binary.R b/tests/testthat/test-design_binary.R new file mode 100644 index 0000000..904526b --- /dev/null +++ b/tests/testthat/test-design_binary.R @@ -0,0 +1,95 @@ +test_that("design_binary() stores a design with a concurrent control", { + pr <- prior_beta(0.5, 0.5) + cr <- crit_post() + ext <- borrow(data_binary(20, 8), 0.5) + des <- design_binary(12, 10, pr, prior_beta(1, 1), cr, external_c = ext) + expect_s3_class(des, c("qdm_design_binary", "qdm_design"), exact = TRUE) + expect_identical(des$endpoint, "binary") + expect_identical(des$n_t, 12L) + expect_identical(des$n_c, 10L) + expect_identical(des$prior_t, pr) + expect_identical(des$criterion, cr) + expect_identical(des$external_c, ext) + expect_null(des$external_t) + expect_null(des$hypothetical_c) + expect_identical(des$control, "concurrent") +}) + +test_that("design_binary() recognises the three forms of the control group", { + expect_identical(ref_design("D1")$control, "concurrent") + expect_identical(ref_design("D3")$control, "hypothetical") + expect_identical(ref_design("D4")$control, "external") + expect_identical(ref_design("D5")$criterion$type, "predictive") +}) + +test_that("design_binary() rejects invalid specifications", { + pr <- prior_beta(1, 1) + cr <- crit_post() + expect_error(design_binary(0, 10, pr, pr, cr), + "'n_t' must be at least 1.") + expect_error(design_binary(10, 2.5, pr, pr, cr), + "'n_c' must contain whole numbers only.") + expect_error(design_binary(10, 10, prior_nix(0, 1, 3, 1), pr, cr), + "'prior_t' must be created by prior_beta().") + expect_error(design_binary(10, 10, pr, list(a = 1, b = 1), cr), + "'prior_c' must be created by prior_beta().") + expect_error(design_binary(10, 10, pr, pr, list()), + "'criterion' must be created by criterion_posterior()") + expect_error(design_binary(10, 10, pr, pr, + crit_post(tv = c(0.2, 0.2), mav = c(0, 0))), + "for one endpoint.") + expect_error(design_binary(10, 10, pr, pr, cr, + external_t = data_binary(10, 5)), + "'external_t' must be NULL or created by borrow\\(\\)") + expect_error(design_binary(10, 10, pr, pr, cr, + external_c = borrow(data_continuous(10, 1, 1), + 0.5)), + "'external_c' must be NULL or created by borrow\\(\\)") + expect_error(design_binary(10, 0, pr, pr, cr, + hypothetical_c = hypothetical(mean = 0, r = 1)), + "'hypothetical_c' must be NULL or created by hypothetical\\(\\)") + expect_error(design_binary(10, 0, pr, pr, cr, + hypothetical_c = data_binary(10, 3)), + "'hypothetical_c' must be NULL or created by hypothetical\\(\\)") +}) + +test_that("design_binary() checks the combination of control arguments", { + pr <- prior_beta(1, 1) + cr <- crit_post() + hyp <- hypothetical(data_binary(12, 4)) + ext <- borrow(data_binary(20, 6), 0.5) + expect_error(design_binary(10, 10, pr, pr, cr, hypothetical_c = hyp), + "'hypothetical_c' can be used only when 'n_c' is 0.") + expect_error(design_binary(10, 0, pr, pr, cr), + "When 'n_c' is 0, specify 'external_c'") + expect_error(design_binary(10, 0, pr, pr, cr, external_c = ext, + hypothetical_c = hyp), + "specify only one of 'external_c', 'hypothetical_c' and") +}) + +test_that("design_binary() stores a fixed control", { + des <- ref_design("D8") + expect_identical(des$control, "fixed") + expect_identical(des$fixed_c, 0.2) + expect_null(des$prior_c) + expect_null(ref_design("D1")$fixed_c) +}) + +test_that("design_binary() checks the fixed control", { + pr <- prior_beta(1, 1) + cr <- crit_post() + expect_error(design_binary(10, 0, pr, pr, cr, fixed_c = 0.2), + "'prior_c' must be NULL for a fixed control") + expect_error(design_binary(10, 0, pr, criterion = cr), + "When 'n_c' is 0, specify 'external_c'") + expect_error(design_binary(10, 0, pr, criterion = cr, fixed_c = 1.5), + "'fixed_c' must be at least 0 and at most 1.") + expect_error(design_binary(10, 10, pr, pr, cr, fixed_c = 0.2), + "'fixed_c' can be used only when 'n_c' is 0.") + expect_error(design_binary(10, 0, pr, pr, cr, + external_c = borrow(data_binary(20, 6), 0.5), + fixed_c = 0.2), + "specify only one of") + expect_error(design_binary(10, 10, pr, criterion = cr), + "'prior_c' must be created by prior_beta().") +}) diff --git a/tests/testthat/test-design_binary2.R b/tests/testthat/test-design_binary2.R new file mode 100644 index 0000000..226897a --- /dev/null +++ b/tests/testthat/test-design_binary2.R @@ -0,0 +1,55 @@ +test_that("design_binary2() stores the specification", { + des <- ref_design_bin2("B6") + expect_s3_class(des, c("qdm_design_binary2", "qdm_design"), exact = TRUE) + expect_identical(des$endpoint, "binary2") + expect_identical(des$n_t, 8L) + expect_identical(des$control, "concurrent") + expect_identical(des$nMC, 20000L) + expect_true(des$enumerate) + expect_equal(des$external_c$a0, 0.5) + expect_identical(ref_design_bin2("B7")$control, "hypothetical") + expect_identical(ref_design_bin2("B8")$control, "external") + expect_false(ref_design_bin2("B1", enumerate = FALSE)$enumerate) +}) + +test_that("design_binary2() validates its arguments", { + q <- dir_q() + cr <- criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), 0.3, 0.4) + expect_error(design_binary2(0, 5, q, q, cr), "'n_t' must be at least 1.") + expect_error(design_binary2(5, 5, prior_beta(1, 1), q, cr), + "'prior_t' must be created by prior_dirichlet\\(\\).") + expect_error(design_binary2(5, 5, q, NULL, cr), + "'prior_c' must be created by prior_dirichlet\\(\\).") + expect_error(design_binary2(5, 5, q, q, crit_post()), + "for two endpoints.") + expect_error(design_binary2(5, 5, q, q, cr, + external_t = borrow(data_binary(5, 2), 0.5)), + "'external_t' must be NULL or created by borrow\\(\\) with") + expect_error(design_binary2(5, 0, q, q, cr, + hypothetical_c = hypothetical(mean = 0, + r = 1)), + "'hypothetical_c' must be NULL or created by hypothetical") + expect_error(design_binary2(5, 0, q, q, cr), + "When 'n_c' is 0, specify 'external_c'") + expect_error(design_binary2(5, 5, q, q, cr, nMC = 0), + "'nMC' must be at least 1 and at most 2147483647.") + expect_error(design_binary2(5, 5, q, q, cr, nMC = 3e9), + "'nMC' must be at least 1 and at most 2147483647.") + expect_error(design_binary2(5, 5, q, q, cr, enumerate = NA), + "'enumerate' must be TRUE or FALSE.") +}) + +test_that("design_binary2() stores and checks a fixed control", { + des <- ref_design_bin2("BF1") + expect_identical(des$control, "fixed") + expect_identical(des$fixed_c, c(0.25, 0.5)) + expect_null(des$prior_c) + q <- dir_q() + cr <- criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), 0.3, 0.4) + expect_error(design_binary2(5, 0, q, q, cr, fixed_c = c(0.2, 0.3)), + "'prior_c' must be NULL for a fixed control") + expect_error(design_binary2(5, 0, q, criterion = cr, fixed_c = 0.2), + "'fixed_c' must have length 2.") + expect_error(design_binary2(5, 0, q, criterion = cr, fixed_c = c(0.2, 2)), + "'fixed_c' must be at least 0 and at most 1.") +}) diff --git a/tests/testthat/test-design_continuous.R b/tests/testthat/test-design_continuous.R new file mode 100644 index 0000000..1da62c0 --- /dev/null +++ b/tests/testthat/test-design_continuous.R @@ -0,0 +1,134 @@ +test_that("design_continuous() stores the specification", { + des <- ref_design_cont("C2") + expect_s3_class(des, c("qdm_design_continuous", "qdm_design"), + exact = TRUE) + expect_identical(des$endpoint, "continuous") + expect_identical(des$n_t, 10L) + expect_identical(des$n_c, 8L) + expect_identical(des$control, "concurrent") + expect_identical(des$method, "NI") + expect_identical(des$nMC, 10000L) + expect_s3_class(des$prior_c, "qdm_prior_nix") + expect_equal(des$external_c$a0, 0.4) + expect_null(des$hypothetical_c) + expect_identical(ref_design_cont("C3")$control, "hypothetical") + expect_null(ref_design_cont("C3")$prior_c) + expect_identical(ref_design_cont("C4")$control, "external") + mc <- ref_design_cont("C1", method = "MC", nMC = 500) + expect_identical(mc$method, "MC") + expect_identical(mc$nMC, 500L) + expect_identical(ref_design_cont("C1", method = "MM")$method, "MM") +}) + +test_that("design_continuous() validates the sample sizes and priors", { + vague <- prior_vague() + expect_error(design_continuous(1, 12, vague, vague, crit_cont()), + "'n_t' must be at least 2.") + expect_error(design_continuous(12, 1, vague, vague, crit_cont()), + "'n_c' must be 0 or a whole number of at least 2.") + # Within the tolerance of whole numbers, 1 + 1e-9 is 1 + expect_error(design_continuous(12, 1 + 1e-9, vague, vague, crit_cont()), + "'n_c' must be 0 or a whole number of at least 2.") + expect_error(design_continuous(12, 2.5, vague, vague, crit_cont()), + "'n_c' must contain whole numbers only.") + expect_error(design_continuous(12, 12, prior_beta(1, 1), vague, + crit_cont()), + "'prior_t' must be created by prior_nix\\(\\) or prior_vague") + expect_error(design_continuous(12, 12, vague, criterion = crit_cont()), + "'prior_c' must be created by prior_nix\\(\\) or prior_vague") + expect_error(design_continuous(12, 0, vague, vague, crit_cont(), + hypothetical_c = hypothetical(mean = 0, + r = 1)), + "'prior_c' must be NULL for a hypothetical control") +}) + +test_that("design_continuous() validates the other arguments", { + vague <- prior_vague() + expect_error(design_continuous(12, 12, vague, vague, + criterion_posterior(c(1, 1), c(0, 0), 0.5, + 0.5)), + "'criterion' must be created by criterion_posterior\\(\\) or") + expect_error(design_continuous(12, 12, vague, vague, crit_cont(), + external_t = borrow(data_binary(10, 3), + 0.5)), + "'external_t' must be NULL or created by borrow\\(\\) with") + expect_error(design_continuous(12, 0, vague, criterion = crit_cont(), + hypothetical_c = hypothetical( + data_binary(10, 3))), + "'hypothetical_c' must be NULL or created by hypothetical") + expect_error(design_continuous(12, 0, vague, criterion = crit_cont(), + hypothetical_c = hypothetical( + mean = c(0, 1), r = 1)), + "'hypothetical_c' must be NULL or created by hypothetical") + expect_error(design_continuous(12, 12, vague, criterion = crit_cont(), + hypothetical_c = hypothetical(mean = 0, + r = 1)), + "'hypothetical_c' can be used only when 'n_c' is 0.") + expect_error(design_continuous(12, 0, vague, vague, crit_cont()), + "When 'n_c' is 0, specify 'external_c'") + expect_error(design_continuous(12, 12, vague, vague, crit_cont(), + method = "XX"), + "'arg' should be one of") + expect_error(design_continuous(12, 12, vague, vague, crit_cont(), + method = "MC", nMC = 0), + "'nMC' must be at least 1 and at most 2147483647.") +}) + +test_that("design_continuous() requires a proper control distribution", { + # With the vague prior and external control data only, the control mean + # has a0 * n_e - 1 degrees of freedom + vague <- prior_vague() + expect_error(design_continuous(12, 0, vague, vague, crit_cont(), + external_c = borrow(data_continuous(4, 0, + 1), + 0.25)), + "'a0' times the number of external subjects must be greater") + des <- design_continuous(12, 0, vague, vague, crit_cont(), + external_c = borrow(data_continuous(5, 0, 1), + 0.25)) + expect_identical(des$control, "external") +}) + +test_that("design_continuous() checks the degrees of freedom for MM", { + vague <- prior_vague() + expect_error(design_continuous(5, 12, vague, vague, crit_cont(), + method = "MM"), + "\\(here 4 and 11\\)") + expect_error(design_continuous(12, 0, vague, vague, crit_cont(), + external_c = borrow(data_continuous(10, 0, + 1), + 0.5), + method = "MM"), + "\\(here 11 and 4\\)") + # A NIX prior adds nu0 degrees of freedom + des <- design_continuous(5, 5, prior_nix(0, 1, 1, 1), prior_nix(0, 1, 1, 1), + crit_cont(), method = "MM") + expect_identical(des$method, "MM") + # The other methods do not need the fourth moments + expect_identical(design_continuous(2, 2, vague, vague, crit_cont())$n_t, + 2L) +}) + +test_that("design_continuous() stores a fixed control", { + des <- ref_design_cont("C7") + expect_identical(des$control, "fixed") + expect_identical(des$fixed_c, -10) + expect_null(des$prior_c) + # The degrees of freedom are not checked for MM, which is not used + expect_identical(design_continuous(3, 0, prior_vague(), + criterion = crit_cont(), fixed_c = 0, + method = "MM")$control, "fixed") +}) + +test_that("design_continuous() checks the fixed control", { + vague <- prior_vague() + expect_error(design_continuous(12, 0, vague, vague, crit_cont(), + fixed_c = 0), + "'prior_c' must be NULL for a fixed control") + expect_error(design_continuous(12, 0, vague, criterion = crit_cont(), + fixed_c = c(0, 1)), + "'fixed_c' must have length 1.") + expect_error(design_continuous(12, 12, vague, vague, crit_cont(), + fixed_c = 0), + "'fixed_c' can be used only when 'n_c' is 0.") +}) diff --git a/tests/testthat/test-design_continuous2.R b/tests/testthat/test-design_continuous2.R new file mode 100644 index 0000000..f578679 --- /dev/null +++ b/tests/testthat/test-design_continuous2.R @@ -0,0 +1,77 @@ +test_that("design_continuous2() stores the specification", { + des <- ref_design_cont2("K3") + expect_s3_class(des, c("qdm_design_continuous2", "qdm_design"), + exact = TRUE) + expect_identical(des$endpoint, "continuous2") + expect_identical(des$n_t, 12L) + expect_identical(des$control, "concurrent") + expect_identical(des$method, "MM") + expect_identical(des$nMC, 10000L) + expect_equal(des$external_t$a0, 0.5) + expect_identical(ref_design_cont2("K4")$control, "hypothetical") + expect_identical(ref_design_cont2("K5")$control, "external") + expect_identical(ref_design_cont2("K1", "MC", 500)$nMC, 500L) + expect_null(ref_design_cont2("K6")$prior_c) +}) + +test_that("design_continuous2() validates its arguments", { + v <- prior_vague() + cr <- crit_cont2() + expect_error(design_continuous2(2, 12, v, v, cr), + "'n_t' must be at least 3.") + expect_error(design_continuous2(12, 2, v, v, cr), + "'n_c' must be 0 or a whole number of at least 3.") + expect_error(design_continuous2(12, 2 + 1e-9, v, v, cr), + "'n_c' must be 0 or a whole number of at least 3.") + expect_error(design_continuous2(12, 12, prior_nix(0, 1, 2, 3), v, cr), + "'prior_t' must be created by prior_niw\\(\\) or prior_vague") + expect_error(design_continuous2(12, 12, v, NULL, cr), + "'prior_c' must be created by prior_niw\\(\\) or prior_vague") + expect_error(design_continuous2(12, 12, v, v, crit_cont()), + "for two endpoints.") + expect_error(design_continuous2(12, 12, v, v, cr, + external_t = borrow(data_continuous(5, 1, + 2), + 0.5)), + "'external_t' must be NULL or created by borrow\\(\\) with") + expect_error(design_continuous2(12, 0, v, NULL, cr, + hypothetical_c = hypothetical(mean = 0, + r = 1)), + "with 'mean' of length 2 and 'r'.") + expect_error(design_continuous2(12, 0, v, v, cr, + hypothetical_c = hypothetical( + mean = c(0, 0), r = 1 + )), + "'prior_c' must be NULL for a hypothetical control") + expect_error(design_continuous2(12, 0, v, v, cr), + "When 'n_c' is 0, specify 'external_c'") + expect_error(design_continuous2(12, 12, v, v, cr, method = "NI"), + "'arg' should be one of") + expect_error(design_continuous2(12, 12, v, v, cr, nMC = 0), + "'nMC' must be at least 1 and at most 2147483647.") + # External control only with the vague prior needs a0 * n_e > 2 + ext <- borrow(data_continuous2(4, c(0, 0), cov2(1, 1, 0)), 0.5) + expect_error(design_continuous2(12, 0, v, v, cr, external_c = ext, + method = "MC"), + "must be greater than 2, so that the distribution") + # Moment matching needs more than 4 degrees of freedom (n - 2 > 4 for the + # vague prior) + expect_error(design_continuous2(6, 12, v, v, cr), + "\\(here 4 and 10\\). Use method = \"MC\".") + expect_s3_class(design_continuous2(6, 12, v, v, cr, method = "MC"), + "qdm_design_continuous2") +}) + +test_that("design_continuous2() stores and checks a fixed control", { + des <- ref_design_cont2("KF2") + expect_identical(des$control, "fixed") + expect_identical(des$fixed_c, c(1, 0.5)) + expect_null(des$prior_c) + vague <- prior_vague() + expect_error(design_continuous2(10, 0, vague, vague, crit_cont2(), + fixed_c = c(0, 0)), + "'prior_c' must be NULL for a fixed control") + expect_error(design_continuous2(10, 0, vague, criterion = crit_cont2(), + fixed_c = 0), + "'fixed_c' must have length 2.") +}) diff --git a/tests/testthat/test-design_tte.R b/tests/testthat/test-design_tte.R new file mode 100644 index 0000000..90116d3 --- /dev/null +++ b/tests/testthat/test-design_tte.R @@ -0,0 +1,75 @@ +test_that("design_tte() stores the specification", { + des <- ref_design_tte("T2") + expect_s3_class(des, c("qdm_design_tte", "qdm_design"), exact = TRUE) + expect_identical(des$endpoint, "tte") + expect_identical(des$n_t, 20L) + expect_identical(des$n_c, 20L) + expect_identical(des$milestone, 3) + expect_identical(des$control, "concurrent") + expect_identical(des$conduct, conduct_example) + expect_null(des$conduct_future) + expect_identical(des$nMC, 10000L) + expect_identical(ref_design_tte("T1")$control, "fixed") + expect_identical(ref_design_tte("T5")$control, "hypothetical") + expect_identical(ref_design_tte("T6")$control, "external") + # The future study of a predictive criterion is conducted like the study + expect_identical(ref_design_tte("T4")$conduct_future, conduct_complete) + # The conduct is needed only for the operating characteristics + expect_null(design_tte(10, 0, prior_gamma(1, 1), criterion = crit_tte(), + milestone = 3, fixed_c = 0.5)$conduct) +}) + +test_that("design_tte() validates its arguments", { + g <- prior_gamma(0.1, 1) + cr <- crit_tte() + expect_error(design_tte(0, 10, g, g, cr, 3), "'n_t' must be at least 1.") + expect_error(design_tte(10, 10, prior_beta(1, 1), g, cr, 3), + "'prior_t' must be created by prior_gamma\\(\\).") + expect_error(design_tte(10, 10, g, NULL, cr, 3), + "'prior_c' must be created by prior_gamma\\(\\).") + expect_error(design_tte(10, 10, g, g, list(), 3), + "'criterion' must be created by criterion_posterior\\(\\) or") + expect_error(design_tte(10, 10, g, g, cr, 0), + "'milestone' must be greater than 0.") + expect_error(design_tte(10, 10, g, g, cr, 3, + external_t = borrow(data_binary(5, 2), 0.5)), + "'external_t' must be NULL or created by borrow\\(\\) with") + expect_error(design_tte(10, 0, g, g, cr, 3, + hypothetical_c = hypothetical(data_binary(5, 2))), + "'hypothetical_c' must be NULL or created by hypothetical") + expect_error(design_tte(10, 0, g, g, cr, 3, fixed_c = 0.5), + "'prior_c' must be NULL for a fixed control") + expect_error(design_tte(10, 0, g, criterion = cr, milestone = 3, + fixed_c = 1.5), + "'fixed_c' must be at least 0 and at most 1.") + expect_error(design_tte(10, 10, g, g, cr, 3, conduct = list()), + "'conduct' must be created by conduct_tte\\(\\).") + expect_error(design_tte(10, 10, g, g, cr, 3, + conduct = conduct_tte(c(0, 5), cut_events = 21)), + "is at event 21, but the study has only 20 subjects.") + expect_error(design_tte(10, 10, g, g, cr, 3, nMC = 0), + "'nMC' must be at least 1") +}) + +test_that("design_tte() checks the conduct of the future study", { + g <- prior_gamma(0.1, 1) + cr <- criterion_predictive(0, m_t = 10, m_c = 8, gamma_go = 0.8, + gamma_nogo = 0.3) + expect_error(design_tte(10, 10, g, g, cr, 3), + "A predictive criterion needs 'conduct_future'") + expect_error(design_tte(10, 10, g, g, cr, 3, + conduct_future = conduct_tte(c(0, 5), + cut_events = 19)), + "'conduct_future' is at event 19, but the study has only 18") + # Without a control group in the future study for a fixed control + expect_error(design_tte(10, 0, g, criterion = cr, milestone = 3, + fixed_c = 0.5, + conduct_future = conduct_tte(c(0, 5), + cut_events = 11)), + "has only 10 subjects.") + co <- conduct_tte(c(0, 5), cut_events = 10) + des <- design_tte(10, 0, g, criterion = cr, milestone = 3, fixed_c = 0.5, + conduct_future = co) + expect_identical(des$conduct_future, co) + expect_null(des$conduct) +}) diff --git a/tests/testthat/test-dmultinom_counts.R b/tests/testthat/test-dmultinom_counts.R new file mode 100644 index 0000000..2c158ef --- /dev/null +++ b/tests/testthat/test-dmultinom_counts.R @@ -0,0 +1,18 @@ +test_that("dmultinom_counts() matches dmultinom()", { + x <- outcomes_binary2(5) + p <- c(0.1, 0.2, 0.3, 0.4) + ref <- apply(x, 1L, stats::dmultinom, prob = p) + expect_equal(dmultinom_counts(x, p), ref, tolerance = 1e-12) + expect_equal(sum(dmultinom_counts(x, p)), 1, tolerance = 1e-12) +}) + +test_that("dmultinom_counts() handles cells with probability 0 and NA", { + x <- outcomes_binary2(3) + p <- c(0.5, 0, 0.5, 0) + w <- dmultinom_counts(x, p) + expect_equal(w, apply(x, 1L, stats::dmultinom, prob = p), + tolerance = 1e-12) + expect_true(all(w[x[, "01"] > 0 | x[, "11"] > 0] == 0)) + expect_identical(dmultinom_counts(x, rep(NA_real_, 4)), + rep(NA_real_, nrow(x))) +}) diff --git a/tests/testthat/test-draws_continuous2.R b/tests/testthat/test-draws_continuous2.R new file mode 100644 index 0000000..712ed31 --- /dev/null +++ b/tests/testthat/test-draws_continuous2.R @@ -0,0 +1,11 @@ +test_that("draws_continuous2() draws the random numbers in a fixed order", { + set.seed(4) + d <- draws_continuous2(5L, 8) + set.seed(4) + z1 <- stats::rnorm(5) + z2 <- stats::rnorm(5) + x1 <- stats::rchisq(5, 7) + x2 <- stats::rchisq(5, 6) + z12 <- stats::rnorm(5) + expect_identical(d, list(z1 = z1, z2 = z2, x1 = x1, x2 = x2, z12 = z12)) +}) diff --git a/tests/testthat/test-event_labels.R b/tests/testthat/test-event_labels.R new file mode 100644 index 0000000..4a23e81 --- /dev/null +++ b/tests/testthat/test-event_labels.R @@ -0,0 +1,31 @@ +test_that("event_labels() describes the Go and NoGo events", { + expect_identical(event_labels(crit_post()), + list(go = "P(theta > 0.2 | data)", + nogo = "P(theta <= 0.1 | data)")) + cp <- criterion_predictive(0.05, m_t = 30, gamma_go = 0.9, + gamma_nogo = 0.7) + expect_identical(event_labels(cp), + list(go = "P(future theta > 0.05 | data)", + nogo = "P(future theta <= 0.05 | data)")) + c2 <- criterion_posterior(c(0.2, 0.1), c(0, 0), 0.5, 0.5, + go_regions = c(1, 2), nogo_regions = 9) + expect_identical(event_labels(c2), + list(go = "P(regions {1, 2} | data)", + nogo = "P(regions {9} | data)")) + expect_identical(event_labels(crit_post(tv = 1 / 3), digits = 2)[["go"]], + "P(theta > 0.33 | data)") +}) + +test_that("event_labels() gives one label per endpoint for marginal rules", { + cr <- criterion_posterior(c(0.2, 0.15), c(0.1, 0), 0.5, 0.5, rule = "and") + expect_identical(event_labels(cr), + list(go = c("P(theta1 > 0.2 | data)", + "P(theta2 > 0.15 | data)"), + nogo = c("P(theta1 <= 0.1 | data)", + "P(theta2 <= 0 | data)"))) + cp <- criterion_predictive(c(0, 0.1), m_t = 30, gamma_go = 0.5, + gamma_nogo = 0.5, rule = "or") + expect_identical(event_labels(cp)$nogo, + c("P(future theta1 <= 0 | data)", + "P(future theta2 <= 0.1 | data)")) +}) diff --git a/tests/testthat/test-format.qdm_borrow.R b/tests/testthat/test-format.qdm_borrow.R new file mode 100644 index 0000000..b83cf51 --- /dev/null +++ b/tests/testthat/test-format.qdm_borrow.R @@ -0,0 +1,12 @@ +test_that("format.qdm_borrow() describes the data and the weight", { + expect_identical(format(borrow(data_binary(20, 8), 0.5)), + "binary, n = 20, y = 8, a0 = 0.5") +}) + +test_that("format.qdm_borrow() works for every kind of external data", { + expect_identical(format(borrow(data_continuous(20, 1.5, 2), 1)), + "continuous, n = 20, mean = 1.5, sd = 2, a0 = 1") + expect_identical(format(borrow(data_binary2(c(1, 2, 3, 4)), 0)), + paste("two binary endpoints, n = 10,", + "counts (00, 01, 10, 11) = (1, 2, 3, 4), a0 = 0")) +}) diff --git a/tests/testthat/test-format.qdm_calibration.R b/tests/testthat/test-format.qdm_calibration.R new file mode 100644 index 0000000..0722a51 --- /dev/null +++ b/tests/testthat/test-format.qdm_calibration.R @@ -0,0 +1,22 @@ +test_that("format.qdm_calibration() reports the chosen thresholds", { + cal <- run_cal("D1") + expect_identical( + format(cal), + c(paste("Calibration of the decision thresholds (exact enumeration of", + "the outcomes)"), + paste(" gamma_go = 0.7: P(Go criterion met | scenario_go) = 0.0454", + "(target 0.05)"), + paste(" gamma_nogo = 0.41: P(NoGo criterion met | scenario_nogo) =", + "0.182 (target 0.2)")) + ) +}) + +test_that("format.qdm_calibration() reports thresholds that were not found", { + a <- cal_args$D1 + cal <- suppressWarnings( + qdm_calibrate(ref_design("D1"), a$scenario_go, a$scenario_nogo, + target_go = 1e-6, target_nogo = 0.2) + ) + expect_identical(format(cal)[2], + " gamma_go : no value in the grid meets the target 1e-06") +}) diff --git a/tests/testthat/test-format.qdm_conduct.R b/tests/testthat/test-format.qdm_conduct.R new file mode 100644 index 0000000..ad4ea13 --- /dev/null +++ b/tests/testthat/test-format.qdm_conduct.R @@ -0,0 +1,19 @@ +test_that("format.qdm_conduct() describes the conduct of a study", { + expect_identical(format(conduct_tte(accrual_time = c(0, 12), + cut_events = 20)), + c("Enrollment: uniform from 0 to 12", "Dropout: none", + "Analysis: at event 20")) + expect_identical( + format(conduct_tte(accrual_time = c(0, 5, 10, 15), + accrual_rate = c(0.4, 2, 4.5), + dropout_hazard = 0.00226, cut_time = 15.44)), + c(paste("Enrollment: piecewise uniform on (0, 5, 10, 15) with rates", + "(0.4, 2.0, 4.5)"), + "Dropout: hazard 0.00226", "Analysis: at time 15.44") + ) + expect_identical( + format(conduct_tte(accrual_time = c(0, 3), dropout_time = c(0, 6), + dropout_hazard = c(0.01, 0.05), cut_time = 9))[2], + "Dropout: hazards (0.01, 0.05) from times (0, 6)" + ) +}) diff --git a/tests/testthat/test-format.qdm_criterion.R b/tests/testthat/test-format.qdm_criterion.R new file mode 100644 index 0000000..5d24372 --- /dev/null +++ b/tests/testthat/test-format.qdm_criterion.R @@ -0,0 +1,51 @@ +test_that("format.qdm_criterion() describes a one-endpoint criterion", { + cr <- criterion_posterior(0.2, 0.1, gamma_go = 0.5, gamma_nogo = 0.8) + expect_identical(format(cr), + c("Posterior probability criterion", + " Go: P(theta > 0.2 | data) >= 0.5", + " NoGo: P(theta <= 0.1 | data) >= 0.8")) + cp <- criterion_predictive(0, m_t = 50, m_c = 40, gamma_go = 0.9, + gamma_nogo = 0.7) + expect_identical(format(cp)[1L], paste("Posterior predictive probability", + "criterion (m_t = 50, m_c = 40)")) + expect_identical(format(cp)[2L], + " Go: P(future theta > 0 | data) >= 0.9") +}) + +test_that("format.qdm_criterion() describes a two-endpoint criterion", { + cr <- criterion_posterior(c(0.2, 0.15), c(0.1, 0.05), 0.3, 0.4, + go_regions = c(1, 4)) + expect_identical(format(cr)[2:4], + c(" Go: P(regions {1, 4} | data) >= 0.3", + " NoGo: P(regions {9} | data) >= 0.4", + " TV = (0.20, 0.15), MAV = (0.10, 0.05)")) +}) + +test_that("format.qdm_criterion() describes a two-endpoint predictive criterion", { + cp <- criterion_predictive(c(0, 0.1), m_t = 30, gamma_go = 0.6, + gamma_nogo = 0.8, nogo_regions = c(2, 4)) + expect_identical(format(cp), + c(paste("Posterior predictive probability criterion", + "(m_t = 30, m_c = 30)"), + " Go: P(regions {1} | data) >= 0.6", + " NoGo: P(regions {2, 4} | data) >= 0.8", + " NULL = (0.0, 0.1)")) +}) + +test_that("format.qdm_criterion() describes marginal rules", { + cr <- criterion_posterior(c(0.2, 0.15), c(0.1, 0.05), c(0.6, 0.5), 0.7, + rule = "and") + expect_identical(format(cr), + c("Posterior probability criterion, marginal rule \"and\"", + paste(" Go: P(theta1 > 0.2 | data) >= 0.6 and", + "P(theta2 > 0.15 | data) >= 0.5"), + paste(" NoGo: P(theta1 <= 0.1 | data) >= 0.7 and", + "P(theta2 <= 0.05 | data) >= 0.7"))) + cp <- criterion_predictive(c(0, 0.1), m_t = 30, gamma_go = 0.6, + gamma_nogo = 0.8, rule = "or") + expect_identical(format(cp)[1:2], + c(paste("Posterior predictive probability criterion", + "(m_t = 30, m_c = 30), marginal rule \"or\""), + paste(" Go: P(future theta1 > 0 | data) >= 0.6 or", + "P(future theta2 > 0.1 | data) >= 0.6"))) +}) diff --git a/tests/testthat/test-format.qdm_data.R b/tests/testthat/test-format.qdm_data.R new file mode 100644 index 0000000..f3a179e --- /dev/null +++ b/tests/testthat/test-format.qdm_data.R @@ -0,0 +1,23 @@ +test_that("format.qdm_data() describes each kind of data", { + expect_identical(format(data_binary(12, 7)), "binary, n = 12, y = 7") + expect_identical(format(data_continuous(12, 3.2, 2)), + "continuous, n = 12, mean = 3.2, sd = 2") + expect_identical(format(data_binary2(c(4, 2, 3, 6))), + paste("two binary endpoints, n = 15,", + "counts (00, 01, 10, 11) = (4, 2, 3, 6)")) + expect_identical(format(data_continuous2(12, c(1, 2), diag(2))), + paste("two continuous endpoints, n = 12, mean = (1, 2),", + "cov = (1, 0; 0, 1)")) +}) + +test_that("format.qdm_data() honours digits and rejects unknown classes", { + expect_identical(format(data_continuous(10, 1 / 3, 2 / 3), digits = 2), + "continuous, n = 10, mean = 0.33, sd = 0.67") + fake <- structure(list(), class = c("qdm_data_other", "qdm_data")) + expect_error(format(fake), "Unknown data class.") +}) + +test_that("format.qdm_data() describes time-to-event data", { + expect_identical(format(data_tte(5, 40.25)), + "time-to-event, events = 5, exposure = 40.25") +}) diff --git a/tests/testthat/test-format.qdm_decision.R b/tests/testthat/test-format.qdm_decision.R new file mode 100644 index 0000000..536da27 --- /dev/null +++ b/tests/testthat/test-format.qdm_decision.R @@ -0,0 +1,101 @@ +test_that("format.qdm_decision() reports probabilities and criteria", { + res <- qdm_decide(ref_design("D1"), data_binary(12, 9), data_binary(12, 4)) + expect_identical( + format(res), + c("Decision: Go", + " Go: P(theta > 0.2 | data) = 0.8207 (threshold 0.5, met)", + " NoGo: P(theta <= 0.1 | data) = 0.07293 (threshold 0.8, not met)", + "Posterior distributions", + " Treatment: Beta(a = 10, b = 4)", + " Control: Beta(a = 5, b = 9)") + ) +}) + +test_that("format.qdm_decision() describes predictive criteria", { + res <- qdm_decide(ref_design("D5"), data_binary(10, 4), data_binary(10, 4)) + out <- format(res, digits = 3) + expect_identical(out[1], "Decision: Gray") + expect_identical(out[2], paste(" Go: P(future theta > 0.05 | data) =", + "0.406 (threshold 0.9, not met)")) +}) + +test_that("format.qdm_decision() describes continuous decisions", { + d <- ref_data_cont$C1 + res <- qdm_decide(ref_design_cont("C1"), d$t, d$c) + expect_identical( + format(res), + c("Decision: Gray", + " Go: P(theta > 30 | data) = 0.5 (threshold 0.6, not met)", + " NoGo: P(theta <= 15 | data) = 0.08784 (threshold 0.7, not met)", + "Posterior distributions", + " Treatment: mean ~ t(df = 11, location = 18, scale = 7.217)", + " Control: mean ~ t(df = 11, location = -12, scale = 7.217)") + ) +}) + +test_that("format.qdm_decision() describes two binary endpoints", { + d_t <- data_binary2(c(2, 1, 3, 4)) + d_c <- data_binary2(c(4, 2, 3, 1)) + res <- qdm_decide(ref_design_bin2("B1"), d_t, d_c) + out <- format(res, digits = 3) + expect_identical(out[1:3], + c("Decision: Go", + " Go: P(regions {1} | data) = 0.422 (threshold 0.4, met)", + paste(" NoGo: P(regions {4} | data) = 0.131", + "(threshold 0.3, not met)"))) + expect_identical(out[4], paste("Region probabilities: R1 = 0.422,", + "R2 = 0.222, R3 = 0.225, R4 = 0.131")) + expect_identical(out[6], paste(" Treatment: Dirichlet(alpha = (2.25,", + "1.25, 3.25, 4.25))")) + res2 <- qdm_decide(ref_design_bin2("B2"), d_t, d_c) + out2 <- format(res2, digits = 3) + expect_identical(out2[2:4], + c(" Go: met (rule \"and\")", + paste(" P(future theta1 > 0.1 | data) = 0.643", + "(threshold 0.6, met)"), + paste(" P(future theta2 > 0 | data) = 0.647", + "(threshold 0.5, met)"))) + expect_identical(out2[5], " NoGo: not met (rule \"and\")") +}) + +test_that("format.qdm_decision() describes two continuous endpoints", { + # Region probabilities of design K4: Python_reference/ref_continuous2_qdm.py + # (moment matching), P(R1) + P(R2) = 0.5799 and P(R9) = 0.0753 + d <- ref_data_cont2$K4 + out <- format(qdm_decide(ref_design_cont2("K4"), d$t), digits = 3) + expect_identical(out[1:3], + c("Decision: Go", + paste(" Go: P(regions {1, 2} | data) = 0.58", + "(threshold 0.4, met)"), + paste(" NoGo: P(regions {9} | data) = 0.0753", + "(threshold 0.3, not met)"))) + expect_match(out[4], "^Region probabilities: R1 = 0.475, R2 = 0.104, ") + expect_match(out[7], paste(" Control: mean ~ t(df = 13, location =", + "(-10, -1), scale = ("), fixed = TRUE) +}) + +test_that("format.qdm_decision() describes a fixed control", { + res <- qdm_decide(ref_design("D8"), data_binary(20, 11)) + expect_identical( + format(res), + c("Decision: Go", + " Go: P(theta > 0.2 | data) = 0.9151 (threshold 0.8, met)", + " NoGo: P(theta <= 0.05 | data) = 0.001687 (threshold 0.8, not met)", + "Posterior distributions", + " Treatment: Beta(a = 12, b = 10)", + " Control: fixed value 0.2") + ) +}) + +test_that("format.qdm_decision() describes a time-to-event decision", { + res <- qdm_decide(ref_design_tte("T1"), ref_data_tte$T1$t) + expect_identical( + format(res), + c("Decision: Go", + " Go: P(theta > 0.15 | data) = 0.6863 (threshold 0.6, met)", + " NoGo: P(theta <= 0 | data) = 0.001061 (threshold 0.8, not met)", + "Posterior distributions", + " Treatment: hazard ~ Gamma(shape = 6.1, rate = 151)", + " Control: fixed value 0.72") + ) +}) diff --git a/tests/testthat/test-format.qdm_design.R b/tests/testthat/test-format.qdm_design.R new file mode 100644 index 0000000..9f8f7a6 --- /dev/null +++ b/tests/testthat/test-format.qdm_design.R @@ -0,0 +1,138 @@ +test_that("format.qdm_design() describes a design with concurrent control", { + expect_identical( + format(ref_design("D2")), + c("Design: one binary endpoint", + " Treatment: n = 10, prior Beta(a = 1, b = 1)", + " External data: binary, n = 10, y = 6, a0 = 0.5", + " Control: concurrent, n = 8, prior Beta(a = 2, b = 3)", + " External data: binary, n = 20, y = 8, a0 = 0.5", + "Posterior probability criterion", + " Go: P(theta > 0.2 | data) >= 0.5", + " NoGo: P(theta <= 0.1 | data) >= 0.8") + ) +}) + +test_that("format.qdm_design() describes the other control forms", { + f3 <- format(ref_design("D3")) + expect_identical(f3[3:4], + c(" Control: hypothetical, prior Beta(a = 1, b = 1)", + " Hypothetical control: data (binary, n = 12, y = 4)")) + f4 <- format(ref_design("D4")) + expect_identical(f4[3:4], + c(" Control: external data only, prior Beta(a = 1, b = 1)", + " External data: binary, n = 20, y = 6, a0 = 0.5")) + f5 <- format(ref_design("D5")) + expect_identical(f5[4], paste("Posterior predictive probability criterion", + "(m_t = 30, m_c = 20)")) +}) + +test_that("format.qdm_design() rejects unknown endpoints", { + des <- ref_design("D1") + des$endpoint <- "unknown" + expect_error(format(des), "Unknown design.") +}) + +test_that("format.qdm_design() describes continuous designs", { + expect_identical( + format(ref_design_cont("C2")), + c("Design: one continuous endpoint", + paste(" Treatment: n = 10, prior N-Inv-Chisq(mu0 = 5, kappa0 = 2,", + "nu0 = 4, sigma0 = 20)"), + " External data: continuous, n = 6, mean = 20, sd = 30, a0 = 0.5", + paste(" Control: concurrent, n = 8, prior N-Inv-Chisq(mu0 = -5,", + "kappa0 = 1, nu0 = 3, sigma0 = 25)"), + " External data: continuous, n = 30, mean = -12, sd = 20, a0 = 0.4", + "Posterior probability criterion", + " Go: P(theta > 30 | data) >= 0.6", + " NoGo: P(theta <= 15 | data) >= 0.7", + "Probabilities: numerical integration") + ) + f3 <- format(ref_design_cont("C3", "MC", 500L)) + expect_identical(f3[2:4], + c(" Treatment: n = 12, prior Vague", + " Control: hypothetical", + " Hypothetical control: mean = (-10), r = 1.5")) + expect_identical(f3[length(f3)], + "Probabilities: Monte Carlo simulation (nMC = 500)") + f4 <- format(ref_design_cont("C4", "MM")) + expect_identical(f4[3], " Control: external data only, prior Vague") + expect_identical(f4[length(f4)], + "Probabilities: moment-matching approximation") +}) + +test_that("format.qdm_design() describes designs with two binary endpoints", { + f6 <- format(ref_design_bin2("B6")) + expect_identical(f6[1:3], + c("Design: two binary endpoints", + paste(" Treatment: n = 8, prior Dirichlet(alpha =", + "(0.25, 0.25, 0.25, 0.25))"), + paste(" External data: two binary endpoints, n = 6,", + "counts (00, 01, 10, 11) = (2, 1, 1, 2), a0 = 0.7"))) + expect_identical(f6[length(f6) - 1:0], + c("Probabilities: Monte Carlo simulation (nMC = 20000)", + "Operating characteristics: enumeration of all outcomes")) + f1 <- format(ref_design_bin2("B1", enumerate = FALSE)) + expect_identical(f1[length(f1) - 1:0], + c("Probabilities: exact computation", + "Operating characteristics: simulation")) +}) + +test_that("format.qdm_design() describes designs with two continuous endpoints", { + f2 <- format(ref_design_cont2("K2")) + expect_identical(f2[1:2], + c("Design: two continuous endpoints", + paste(" Treatment: n = 30, prior N-Inv-Wishart(mu0 =", + "(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = (6400,", + "15; 15, 36))"))) + expect_identical(f2[length(f2)], + "Probabilities: moment-matching approximation") + f3 <- format(ref_design_cont2("K3")) + expect_identical(f3[3], paste(" External data: two continuous endpoints,", + "n = 8, mean = (2, 1), cov = (25, 3; 3, 9),", + "a0 = 0.5")) + f4 <- format(ref_design_cont2("K4", "MC", 2000L)) + expect_identical(f4[3:4], + c(" Control: hypothetical", + " Hypothetical control: mean = (-10, -1), r = 1.5")) + expect_identical(f4[length(f4)], + "Probabilities: Monte Carlo simulation (nMC = 2000)") +}) + +test_that("format.qdm_design() describes a fixed control", { + f8 <- format(ref_design("D8")) + expect_identical(f8[3], " Control: fixed value 0.2") + f7 <- format(ref_design_cont("C7")) + expect_identical(f7[3], " Control: fixed value -10") + expect_identical(f7[length(f7)], + "Probabilities: exact computation (fixed control)") + fk <- format(ref_design_cont2("KF1")) + expect_identical(fk[3], " Control: fixed value (-10, -1)") + fb <- format(ref_design_bin2("BF1")) + expect_identical(fb[3], " Control: fixed value (0.25, 0.50)") +}) + +test_that("format.qdm_design() describes time-to-event designs", { + f1 <- format(ref_design_tte("T1")) + expect_identical( + f1, + c("Design: one time-to-event endpoint (milestone survival at t = 3)", + " Treatment: n = 30, prior Gamma(shape = 0.1, rate = 1)", + " Control: fixed value 0.72", + "Posterior probability criterion", + " Go: P(theta > 0.15 | data) >= 0.6", + " NoGo: P(theta <= 0 | data) >= 0.8", + "Probabilities: exact computation (fixed control)", + "Conduct of the study (operating characteristics):", + " Enrollment: uniform from 0 to 1", + " Dropout: none", + " Analysis: at time 1e+06") + ) + f4 <- format(ref_design_tte("T4", nMC = 500L)) + expect_identical(f4[length(f4) - 3L], "Conduct of the future study:") + expect_identical(f4[7], "Probabilities: simulation of future studies (nMC = 500)") + f6 <- format(ref_design_tte("T6")) + expect_identical(f6[3], " External data: time-to-event, events = 4, exposure = 30, a0 = 0.5") + des <- ref_design_tte("T2") + des$conduct <- NULL + expect_false(any(grepl("Conduct", format(des)))) +}) diff --git a/tests/testthat/test-format.qdm_hypothetical.R b/tests/testthat/test-format.qdm_hypothetical.R new file mode 100644 index 0000000..9cf27b5 --- /dev/null +++ b/tests/testthat/test-format.qdm_hypothetical.R @@ -0,0 +1,12 @@ +test_that("format.qdm_hypothetical() describes both kinds of control", { + expect_identical(format(hypothetical(data = data_binary(15, 5))), + "data (binary, n = 15, y = 5)") + expect_identical(format(hypothetical(mean = c(1, 2.5), r = 2)), + "mean = (1.0, 2.5), r = 2") +}) + +test_that("format.qdm_hypothetical() works for two binary endpoints", { + expect_identical(format(hypothetical(data = data_binary2(c(5, 3, 2, 1)))), + paste("data (two binary endpoints, n = 11,", + "counts (00, 01, 10, 11) = (5, 3, 2, 1))")) +}) diff --git a/tests/testthat/test-format.qdm_prior.R b/tests/testthat/test-format.qdm_prior.R new file mode 100644 index 0000000..35d3046 --- /dev/null +++ b/tests/testthat/test-format.qdm_prior.R @@ -0,0 +1,22 @@ +test_that("format.qdm_prior() describes each prior", { + expect_identical(format(prior_beta(0.5, 0.5)), "Beta(a = 0.5, b = 0.5)") + expect_identical(format(prior_dirichlet(rep(0.25, 4))), + "Dirichlet(alpha = (0.25, 0.25, 0.25, 0.25))") + expect_identical(format(prior_nix(0, 1, 3, 2)), + "N-Inv-Chisq(mu0 = 0, kappa0 = 1, nu0 = 3, sigma0 = 2)") + expect_identical(format(prior_niw(c(0, 1), 1, 4, diag(2))), + paste0("N-Inv-Wishart(mu0 = (0, 1), kappa0 = 1, nu0 = 4, ", + "Lambda0 = (1, 0; 0, 1))")) + expect_identical(format(prior_vague()), "Vague") +}) + +test_that("format.qdm_prior() honours digits and rejects unknown classes", { + expect_identical(format(prior_nix(1 / 3, 1, 1, 1), digits = 3), + "N-Inv-Chisq(mu0 = 0.333, kappa0 = 1, nu0 = 1, sigma0 = 1)") + fake <- structure(list(), class = c("qdm_prior_other", "qdm_prior")) + expect_error(format(fake), "Unknown prior class.") +}) + +test_that("format.qdm_prior() describes the Gamma prior", { + expect_identical(format(prior_gamma(0.1, 1)), "Gamma(shape = 0.1, rate = 1)") +}) diff --git a/tests/testthat/test-format_num.R b/tests/testthat/test-format_num.R new file mode 100644 index 0000000..c36fa24 --- /dev/null +++ b/tests/testthat/test-format_num.R @@ -0,0 +1,9 @@ +test_that("format_num() formats numbers as a comma-separated string", { + expect_identical(format_num(c(0.5, 12)), "0.5, 12.0") + expect_identical(format_num(1 / 3, digits = 3), "0.333") +}) + +test_that("format_num() handles negative numbers and single values", { + expect_identical(format_num(c(-1, 0.25)), "-1.00, 0.25") + expect_identical(format_num(7L), "7") +}) diff --git a/tests/testthat/test-format_posterior.R b/tests/testthat/test-format_posterior.R new file mode 100644 index 0000000..1b0eba8 --- /dev/null +++ b/tests/testthat/test-format_posterior.R @@ -0,0 +1,47 @@ +test_that("format_posterior() formats Beta parameters", { + expect_identical(format_posterior(ref_design("D1"), c(a = 7.5, b = 5.5)), + "Beta(a = 7.5, b = 5.5)") + expect_identical(format_posterior(ref_design("D1"), c(a = 1 / 3, b = 2), + digits = 2), + "Beta(a = 0.33, b = 2)") +}) + +test_that("format_posterior() gives the t distribution of a continuous mean", { + des <- ref_design_cont("C1") + expect_identical(format_posterior(des, c(mu = 18, kappa = 12, nu = 11, + sigma = 25)), + "mean ~ t(df = 11, location = 18, scale = 7.217)") + expect_identical(format_posterior(des, c(mu = -1 / 3, kappa = 4, nu = 2.5, + sigma = 2), digits = 2), + "mean ~ t(df = 2.5, location = -0.33, scale = 1)") +}) + +test_that("format_posterior() gives the Dirichlet parameters", { + expect_identical(format_posterior(ref_design_bin2("B1"), + c("00" = 2.25, "01" = 1.25, "10" = 3.25, + "11" = 4.25)), + "Dirichlet(alpha = (2.25, 1.25, 3.25, 4.25))") +}) + +test_that("format_posterior() gives the t distribution of two means", { + # kappa = 10, nu = 11: the scale matrix is Lambda / 100 + post <- c(mu1 = 1, mu2 = -2, kappa = 10, nu = 11, L11 = 200, L12 = 50, + L22 = 100) + expect_identical(format_posterior(ref_design_cont2("K1"), post), + paste("mean ~ t(df = 10, location = (1, -2),", + "scale = (2.0, 0.5; 0.5, 1.0))")) +}) + +test_that("format_posterior() gives the Gamma distribution of a hazard", { + expect_identical(format_posterior(ref_design_tte("T2"), + c(shape = 5.1, rate = 41)), + "hazard ~ Gamma(shape = 5.1, rate = 41)") +}) + +test_that("format_posterior() gives fixed control values", { + expect_identical(format_posterior(ref_design("D8"), c(value = 0.2)), + "fixed value 0.2") + expect_identical(format_posterior(ref_design_cont2("KF1"), + c(value1 = -10, value2 = -1)), + "fixed values (-10, -1)") +}) diff --git a/tests/testthat/test-hypothetical.R b/tests/testthat/test-hypothetical.R new file mode 100644 index 0000000..14d8795 --- /dev/null +++ b/tests/testthat/test-hypothetical.R @@ -0,0 +1,42 @@ +test_that("hypothetical() stores data for binary endpoints", { + d <- data_binary(15, 5) + h <- hypothetical(data = d) + expect_s3_class(h, "qdm_hypothetical", exact = TRUE) + expect_identical(h$type, "data") + expect_identical(h$data, d) + expect_null(h$mean) +}) + +test_that("hypothetical() stores location and scale for continuous endpoints", { + h1 <- hypothetical(mean = 1, r = 2) + expect_identical(h1$type, "location") + expect_identical(h1$mean, 1) + expect_identical(h1$r, 2) + expect_identical(hypothetical(mean = c(1, 2), r = 1)$mean, c(1, 2)) +}) + +test_that("hypothetical() rejects incomplete or conflicting input", { + expect_error(hypothetical(), "Specify either 'data'") + expect_error(hypothetical(data = data_binary(15, 5), mean = 1), + "Specify either 'data'") + expect_error(hypothetical(mean = 1), "Both 'mean' and 'r' must be") + expect_error(hypothetical(data = data_continuous(10, 0, 1)), + "created by data_binary\\(\\), data_binary2\\(\\) or data_tte") + expect_error(hypothetical(mean = 1:3, r = 1), "'mean' must have length 1") + expect_error(hypothetical(mean = 1, r = 0), "'r' must be greater than 0.") +}) + +test_that("hypothetical() accepts two binary endpoints and checks 'r' alone", { + d <- data_binary2(c(5, 3, 2, 1)) + expect_identical(hypothetical(data = d)$data, d) + expect_error(hypothetical(r = 1), "Both 'mean' and 'r' must be") + expect_error(hypothetical(mean = NA_real_, r = 1), + "'mean' must not contain missing") +}) + +test_that("hypothetical() accepts time-to-event data", { + d <- data_tte(8, 60) + h <- hypothetical(data = d) + expect_identical(h$type, "data") + expect_identical(h$data, d) +}) diff --git a/tests/testthat/test-mean_dist_continuous2.R b/tests/testthat/test-mean_dist_continuous2.R new file mode 100644 index 0000000..b9b4535 --- /dev/null +++ b/tests/testthat/test-mean_dist_continuous2.R @@ -0,0 +1,82 @@ +# Reference: Python_reference/ref_continuous2_qdm.py, section C (posterior +# scale Lambda / (kappa (nu - 1)); predictive scale (1 / kappa + 1 / m) +# Lambda / (nu - 1), checked in section B against direct simulation of the +# hierarchical model). +test_that("mean_dist_continuous2() gives the posterior and predictive scales", { + ref_t <- list( + K1 = list( + loc = c(18, 2.5), df = 10, + scale = c(330, 11, 2.29166666666667) + ), + K2 = list( + loc = c(4.98338870431894, 1.99667774086379), df = 33, + scale = c(193.297585517318, 5.62116011161827, 1.08738514826748) + ), + K3 = list( + loc = c(2.37257142857143, 1.00118633540373), df = 19, + scale = c(1.67795549308551, 0.263590024497268, 0.60288915604117) + ), + K4 = list( + loc = c(4, 1.5), df = 13, + scale = c(64.6153846153846, 3.23076923076923, 0.646153846153846) + ), + K5 = list( + loc = c(2.97520661157025, 1), df = 15, + scale = c(376.17571659495, 10.0826446280992, 2.03168044077135) + ), + K6 = list( + loc = c(7, 2), df = 13, + scale = c(9.87179487179487, -0.592307692307692, 0.394871794871795) + ) + ) + ref_c <- list( + K1 = list( + loc = c(-10, -1), df = 10, + scale = c(449.166666666667, 7.7, 3.3) + ), + K2 = list( + loc = c(-10, -1), df = 33, + scale = c(170.668478808014, 4.28495922681969, 1.26975737440854) + ), + K3 = list( + loc = c(-0.67910447761194, -1.32089552238806), df = 23, + scale = c(1.30581977910577, 0.095846627989191, 0.600695357734365) + ), + K4 = list( + loc = c(-10, -1), df = 13, + scale = c(96.9230769230769, 4.84615384615385, 0.969230769230769) + ), + K5 = list( + loc = c(-10, -1), df = 8, + scale = c(581.875, 12.46875, 2.96875) + ), + K6 = list( + loc = c(0, 0), df = 13, + scale = c(21.5384615384615, -1.29230769230769, 0.861538461538462) + ) + ) + for (name in names(ref_t)) { + des <- ref_design_cont2(name) + crit <- des$criterion + d <- ref_data_cont2[[name]] + pt <- posterior_continuous2(des$prior_t, d$t$n, d$t$mean, d$t$cov, + external = des$external_t) + pc <- if (is.null(d$c)) { + control_posterior_continuous2(des, pt) + } else { + control_posterior_continuous2(des, pt, d$c$n, d$c$mean, d$c$cov) + } + for (g in c("t", "c")) { + dd <- mean_dist_continuous2(if (g == "t") pt else pc, crit$type, + crit[[paste0("m_", g)]]) + e <- (if (g == "t") ref_t else ref_c)[[name]] + expect_equal(dd$loc, matrix(e$loc, 1L), tolerance = 1e-12, + info = paste(name, g)) + expect_equal(unname(dd$scale), matrix(e$scale, 1L), tolerance = 1e-12, + info = paste(name, g)) + expect_equal(dd$df, e$df, info = paste(name, g)) + } + } + dd <- mean_dist_continuous2(pt, "posterior") + expect_identical(colnames(dd$scale), c("V11", "V12", "V22")) +}) diff --git a/tests/testthat/test-meets_criterion.R b/tests/testthat/test-meets_criterion.R new file mode 100644 index 0000000..d4c64e3 --- /dev/null +++ b/tests/testthat/test-meets_criterion.R @@ -0,0 +1,13 @@ +test_that("meets_criterion() applies the joint and marginal rules", { + expect_identical(meets_criterion(c(0.2, 0.6), 0.5), c(FALSE, TRUE)) + p <- list(c(0.7, 0.7, 0.2), c(0.6, 0.3, 0.6)) + expect_identical(meets_criterion(p, c(0.5, 0.5), "and"), + c(TRUE, FALSE, FALSE)) + expect_identical(meets_criterion(p, c(0.5, 0.5), "or"), + c(TRUE, TRUE, TRUE)) + expect_identical(meets_criterion(p, c(0.8, 0.5), "or"), + c(TRUE, FALSE, TRUE)) + # A single decision: one probability per endpoint + expect_true(meets_criterion(c(0.7, 0.6), c(0.5, 0.6 + 1e-12), "and")) + expect_false(meets_criterion(c(0.7, 0.4), c(0.5, 0.5), "and")) +}) diff --git a/tests/testthat/test-meets_threshold.R b/tests/testthat/test-meets_threshold.R new file mode 100644 index 0000000..808a0bd --- /dev/null +++ b/tests/testthat/test-meets_threshold.R @@ -0,0 +1,12 @@ +test_that("meets_threshold() compares with a tolerance for ties", { + expect_true(meets_threshold(0.5, 0.5)) + expect_true(meets_threshold(0.5 - 1e-12, 0.5)) + expect_false(meets_threshold(0.5 - 1e-9, 0.5)) + expect_true(meets_threshold(0.7, 0.5)) + expect_identical(meets_threshold(c(0.1, 0.3, 0.29999999999999), 0.3), + c(FALSE, TRUE, TRUE)) + m <- matrix(c(0.2, 0.6, 0.4, 0.8), 2) + expect_identical(meets_threshold(m, 0.5), m >= 0.5) + expect_false(meets_threshold(0.49, 0.5, tol = 0.001)) + expect_true(meets_threshold(0.4995, 0.5, tol = 0.001)) +}) diff --git a/tests/testthat/test-met_curve.R b/tests/testthat/test-met_curve.R new file mode 100644 index 0000000..9d42c93 --- /dev/null +++ b/tests/testthat/test-met_curve.R @@ -0,0 +1,21 @@ +test_that("met_curve() gives the probability of meeting a threshold", { + p <- c(0.2, 0.5, 0.8) + w <- c(0.5, 0.3, 0.2) + expect_equal(met_curve(p, w, c(0.1, 0.2, 0.3, 0.5, 0.9)), + c(1, 1, 0.5, 0.5, 0)) + # Ties within the tolerance meet the threshold + expect_equal(met_curve(0.5 - 1e-12, 1, 0.5), 1) +}) + +test_that("met_curve() handles pairs of outcomes and marginal rules", { + # Probabilities over 2 x 2 pairs of treatment and control outcomes + p <- matrix(c(0.2, 0.6, 0.4, 0.8), 2L) + w <- list(t = c(0.3, 0.7), c = c(0.5, 0.5)) + expect_equal(met_curve(p, w, c(0.1, 0.5, 0.7)), + c(1, 0.7 * 0.5 + 0.7 * 0.5, 0.7 * 0.5)) + # Marginal rules: the same threshold for both endpoints + pl <- list(c(0.2, 0.6, 0.9), c(0.7, 0.5, 0.4)) + wv <- c(0.2, 0.3, 0.5) + expect_equal(met_curve(pl, wv, c(0.3, 0.5), "and"), c(0.3 + 0.5, 0.3)) + expect_equal(met_curve(pl, wv, c(0.3, 0.5), "or"), c(1, 1)) +}) diff --git a/tests/testthat/test-method_label.R b/tests/testthat/test-method_label.R new file mode 100644 index 0000000..2adcf5e --- /dev/null +++ b/tests/testthat/test-method_label.R @@ -0,0 +1,11 @@ +test_that("method_label() describes the methods", { + expect_identical(method_label("NI", 100L), "numerical integration") + expect_identical(method_label("MM", 100L), "moment-matching approximation") + expect_identical(method_label("MC", 2000L), + "Monte Carlo simulation (nMC = 2000)") +}) + +test_that("method_label() describes the exact computation for a fixed control", { + expect_identical(method_label("MC", 100L, fixed = TRUE), + "exact computation (fixed control)") +}) diff --git a/tests/testthat/test-oc_axis.R b/tests/testthat/test-oc_axis.R new file mode 100644 index 0000000..a65d11b --- /dev/null +++ b/tests/testthat/test-oc_axis.R @@ -0,0 +1,66 @@ +test_that("oc_axis() uses the treatment effect with a concurrent control", { + ax <- oc_axis(ref_design("D1"), scen_c) + expect_equal(ax$x, scen_c$pi_t - scen_c$pi_c) + expect_equal(ax$lines, c(0.1, 0.2)) + expect_identical(ax$labels, c("theta[MAV]", "theta[TV]")) + expect_null(ax$caption) + ax5 <- oc_axis(ref_design("D5"), scen_c) + expect_equal(ax5$lines, 0.05) + expect_identical(ax5$labels, "theta[NULL]") +}) + +test_that("oc_axis() shifts the thresholds without a concurrent control", { + # Control distribution Beta(5, 9) in D3 and Beta(4, 8) in D4 + ax <- oc_axis(ref_design("D3"), scen_u) + expect_equal(ax$x, scen_u$pi_t) + expect_equal(ax$lines, 5 / 14 + c(0.1, 0.2)) + expect_match(ax$caption, "shifted by the mean of the control distribution") + expect_match(ax$caption, "0.357") + expect_equal(oc_axis(ref_design("D4"), scen_u)$lines, 1 / 3 + c(0.1, 0.2)) +}) + +test_that("oc_axis() uses the mean difference for continuous designs", { + ax <- oc_axis(ref_design_cont("C1"), scen_cont_c) + expect_equal(ax$x, scen_cont_c$mu_t - scen_cont_c$mu_c) + expect_equal(ax$xlab, expression(theta == mu[t] - mu[c])) + expect_equal(ax$lines, c(15, 30)) + expect_null(ax$caption) + ax5 <- oc_axis(ref_design_cont("C5"), scen_cont_c) + expect_equal(ax5$lines, 10) +}) + +test_that("oc_axis() shifts the thresholds by the control location", { + # Hypothetical control located at -10 (C3) and at 0 (C6); external control + # data with mean -12 (C4) + ax <- oc_axis(ref_design_cont("C3"), scen_cont_u) + expect_equal(ax$x, scen_cont_u$mu_t) + expect_equal(ax$xlab, expression(mu[t])) + expect_equal(ax$lines, -10 + c(15, 30)) + expect_match(ax$caption, + "shifted by the location of the control distribution \\(-10\\)") + expect_equal(oc_axis(ref_design_cont("C4"), scen_cont_u)$lines, + -12 + c(15, 30)) + expect_equal(oc_axis(ref_design_cont("C6"), scen_cont_u)$lines, 5) +}) + +test_that("oc_axis() shifts the thresholds by a fixed control value", { + ax <- oc_axis(ref_design("D8"), scen_u) + expect_equal(ax$x, scen_u$pi_t) + expect_equal(ax$lines, 0.2 + c(0.05, 0.2)) + expect_match(ax$caption, "shifted by the fixed control value \\(0.2\\)") +}) + +test_that("oc_axis() uses milestone survival for time-to-event designs", { + sc <- data.frame(median_t = c(6, 12), median_c = 6) + ax <- oc_axis(ref_design_tte("T2"), sc) + s <- function(m) exp(-log(2) * 3 / m) + expect_equal(ax$x, s(c(6, 12)) - s(6)) + expect_equal(ax$xlab, expression(theta == S[t](t[0]) - S[c](t[0]))) + expect_null(ax$caption) + ax1 <- oc_axis(ref_design_tte("T1"), sc[, 1, drop = FALSE]) + expect_equal(ax1$x, s(c(6, 12))) + expect_equal(ax1$xlab, expression(S[t](t[0]))) + expect_equal(ax1$lines, 0.72 + c(0, 0.15)) + ax5 <- oc_axis(ref_design_tte("T5"), sc[, 1, drop = FALSE]) + expect_match(ax5$caption, "shifted by the mean of the control distribution") +}) diff --git a/tests/testthat/test-oc_from_sample.R b/tests/testthat/test-oc_from_sample.R new file mode 100644 index 0000000..1191fc0 --- /dev/null +++ b/tests/testthat/test-oc_from_sample.R @@ -0,0 +1,34 @@ +test_that("oc_from_sample() sums the probabilities of the outcomes", { + s <- list(p_go = c(0.9, 0.6, 0.2, 0.05), + p_nogo = c(0.01, 0.3, 0.7, 0.9), + weights = cbind(c(0.1, 0.2, 0.3, 0.4), c(0.25, 0.25, 0.25, 0.25))) + out <- oc_from_sample(s, gamma_go = 0.5, gamma_nogo = 0.8) + expect_identical(colnames(out), c("Go", "NoGo", "Gray", "Miss")) + expect_equal(out[1, ], c(Go = 0.3, NoGo = 0.4, Gray = 0.3, Miss = 0)) + expect_equal(out[2, ], c(Go = 0.5, NoGo = 0.25, Gray = 0.25, Miss = 0)) + out2 <- oc_from_sample(s, gamma_go = 0.5, gamma_nogo = 0.25) + expect_equal(out2[1, ], c(Go = 0.1, NoGo = 0.7, Gray = 0, Miss = 0.2)) +}) + +test_that("oc_from_sample() accepts probabilities that differ by scenario", { + s <- list(p_go = cbind(c(0.9, 0.1), c(0.1, 0.9)), + p_nogo = cbind(c(0.05, 0.9), c(0.9, 0.05)), + weights = cbind(c(0.5, 0.5), c(0.2, 0.8))) + out <- oc_from_sample(s, 0.5, 0.5) + expect_equal(out[, "Go"], c(0.5, 0.8)) + expect_equal(out[, "NoGo"], c(0.5, 0.2)) +}) + +test_that("oc_from_sample() handles pairs of outcomes and marginal rules", { + # Pairs of 2 treatment and 1 control outcome, 2 scenarios; marginal rule + s <- list(p_go = list(matrix(c(0.9, 0.2), 2L), matrix(c(0.8, 0.9), 2L)), + p_nogo = list(matrix(c(0.1, 0.7), 2L), matrix(c(0.1, 0.1), 2L)), + weights = NULL, + weights_t = cbind(c(0.4, 0.6), c(NA, NA)), + weights_c = matrix(1, 1L, 2L)) + out <- oc_from_sample(s, c(0.5, 0.5), c(0.5, 0.5), "or") + expect_equal(out[1, ], c(Go = 0.4, NoGo = 0, Gray = 0, Miss = 0.6)) + expect_true(all(is.na(out[2, ]))) + and <- oc_from_sample(s, c(0.5, 0.5), c(0.5, 0.5), "and") + expect_equal(and[1, ], c(Go = 0.4, NoGo = 0, Gray = 0.6, Miss = 0)) +}) diff --git a/tests/testthat/test-oc_sample.R b/tests/testthat/test-oc_sample.R new file mode 100644 index 0000000..bdddfc5 --- /dev/null +++ b/tests/testthat/test-oc_sample.R @@ -0,0 +1,29 @@ +test_that("oc_sample() dispatches on the endpoint of the design", { + des <- ref_design("D3") + sc <- data.frame(pi_t = 0.5) + expect_identical(oc_sample(des, sc, 10L), oc_sample_binary(des, sc)) +}) + +test_that("oc_sample() simulates continuous designs", { + des <- ref_design_cont("C3", "MM") + set.seed(1) + a <- oc_sample(des, scen_cont_u, 30L) + set.seed(1) + expect_identical(a, oc_sample_continuous(des, scen_cont_u, 30L)) +}) + +test_that("oc_sample() dispatches designs with two binary endpoints", { + des <- ref_design_bin2("B1", enumerate = FALSE) + set.seed(1) + a <- oc_sample(des, scen_bin2, 20L) + set.seed(1) + expect_identical(a, oc_sample_binary2(des, scen_bin2, 20L)) +}) + +test_that("oc_sample() dispatches designs with two continuous endpoints", { + des <- ref_design_cont2("K4") + set.seed(1) + a <- oc_sample(des, scen_cont2("K4"), 10L) + set.seed(1) + expect_identical(a, oc_sample_continuous2(des, scen_cont2("K4"), 10L)) +}) diff --git a/tests/testthat/test-oc_sample_binary.R b/tests/testthat/test-oc_sample_binary.R new file mode 100644 index 0000000..96c09ce --- /dev/null +++ b/tests/testthat/test-oc_sample_binary.R @@ -0,0 +1,37 @@ +test_that("oc_sample_binary() enumerates the outcomes with y_t fastest", { + des <- ref_design("D2") + s <- oc_sample_binary(des, data.frame(pi_t = c(0.3, 0.6), pi_c = 0.2)) + n_out <- (des$n_t + 1) * (des$n_c + 1) + expect_length(s$p_go, n_out) + expect_length(s$p_nogo, n_out) + expect_identical(dim(s$weights), c(as.integer(n_out), 2L)) + expect_equal(colSums(s$weights), c(1, 1), tolerance = 1e-12) + # Outcome (y_t, y_c) = (3, 2) is in row 3 + 2 * (n_t + 1) + 1 + k <- 3 + 2 * (des$n_t + 1) + 1 + expect_equal(s$weights[k, 2], stats::dbinom(3, 10, 0.6) * + stats::dbinom(2, 8, 0.2)) + post_t <- posterior_binary(des$prior_t, 10, 3, des$external_t) + post_c <- posterior_binary(des$prior_c, 8, 2, des$external_c) + expect_equal(s$p_go[k], pbetadiff(0.2, post_t$a, post_t$b, post_c$a, + post_c$b, lower.tail = FALSE)) + expect_identical(s$method, "exact enumeration of the outcomes") +}) + +test_that("oc_sample_binary() uses a fixed control distribution without a concurrent control", { + des <- ref_design("D3") + s <- oc_sample_binary(des, data.frame(pi_t = 0.5)) + expect_length(s$p_go, des$n_t + 1) + expect_identical(dim(s$weights), c(13L, 1L)) + expect_equal(s$p_go[10], pbetadiff(0.2, 10, 4, 5, 9, lower.tail = FALSE)) +}) + +test_that("oc_sample_binary() handles a fixed control", { + des <- ref_design("D8") + s <- oc_sample_binary(des, data.frame(pi_t = c(0.2, 0.6))) + expect_length(s$p_go, 21) + expect_identical(dim(s$weights), c(21L, 2L)) + y <- 0:20 + expect_equal(s$p_go, stats::pbeta(0.4, 1 + y, 21 - y, lower.tail = FALSE)) + expect_equal(s$p_nogo, stats::pbeta(0.25, 1 + y, 21 - y)) + expect_equal(s$weights[, 2], stats::dbinom(y, 20, 0.6)) +}) diff --git a/tests/testthat/test-oc_sample_binary2.R b/tests/testthat/test-oc_sample_binary2.R new file mode 100644 index 0000000..f76db5e --- /dev/null +++ b/tests/testthat/test-oc_sample_binary2.R @@ -0,0 +1,97 @@ +test_that("oc_sample_binary2() enumerates pairs of outcomes", { + des <- ref_design_bin2("B1") + s <- oc_sample_binary2(des, scen_bin2, 1L) + n_t <- choose(3 + 3, 3) + n_c <- choose(2 + 3, 3) + expect_identical(dim(s$p_go), as.integer(c(n_t, n_c))) + expect_false(s$per_scenario) + expect_null(s[["weights"]]) + expect_identical(dim(s$weights_t), as.integer(c(n_t, 3))) + expect_equal(colSums(s$weights_t), rep(1, 3)) + expect_equal(colSums(s$weights_c), rep(1, 3)) + # Each element is the probability for one pair of outcomes + x_t <- outcomes_binary2(3) + x_c <- outcomes_binary2(2) + res <- decide_binary2(des, data_binary2(x_t[7, ]), data_binary2(x_c[4, ])) + expect_equal(s$p_go[7, 4], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[7, 4], res$prob_nogo, tolerance = 1e-12) + expect_identical(s$method, paste("exact enumeration of the outcomes;", + "predictive probabilities computed", + "exactly")) + s2 <- oc_sample_binary2(ref_design_bin2("B4", nMC = 100L), scen_bin2_d, + 1L) + expect_length(s2$p_go, 2L) + expect_identical(dim(s2$p_go[[2]]), as.integer(rep(choose(7, 3), 2))) + expect_match(s2$method, "Monte Carlo simulation \\(nMC = 100\\)") + # Enumeration is limited to 1e7 pairs of outcomes (3276^2 for 25 subjects + # in each group) + big <- design_binary2(25, 25, dir_q(), dir_q(), + criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), 0.3, + 0.4)) + expect_error(oc_sample_binary2(big, scen_bin2, 1L), + "would need 10,732,176 pairs of treatment and control") + expect_identical(dim(oc_sample_binary2(ref_design_bin2("B7"), scen_bin2, + 1L)$p_go), c(20L, 1L)) +}) + +test_that("oc_sample_binary2() maps simulated studies to their probabilities", { + des <- ref_design_bin2("B2", enumerate = FALSE) + nsim <- 30L + set.seed(9) + s <- oc_sample_binary2(des, scen_bin2, nsim) + expect_true(s$per_scenario) + expect_identical(dim(s$p_go[[1]]), c(nsim, 3L)) + expect_equal(s$weights, matrix(1 / nsim, nsim, 3)) + # The uniform random numbers are drawn for the treatment group and then + # for the control group + set.seed(9) + u_t <- matrix(runif(nsim * 3), nrow = nsim) + u_c <- matrix(runif(nsim * 2), nrow = nsim) + for (j in c(1, 3)) { + x_t <- simulate_counts_binary2(u_t, cellprob_binary2(scen_bin2$pi_t1[j], + scen_bin2$pi_t2[j], + scen_bin2$rho_t[j])) + x_c <- simulate_counts_binary2(u_c, cellprob_binary2(scen_bin2$pi_c1[j], + scen_bin2$pi_c2[j], + scen_bin2$rho_c[j])) + for (i in c(1, 17, 30)) { + res <- decide_binary2(des, data_binary2(x_t[i, ]), + data_binary2(x_c[i, ])) + expect_equal(c(s$p_go[[1]][i, j], s$p_go[[2]][i, j]), res$prob_go, + tolerance = 1e-12) + expect_equal(c(s$p_nogo[[1]][i, j], s$p_nogo[[2]][i, j]), + res$prob_nogo, tolerance = 1e-12) + } + } + # Without a concurrent control group only the treatment group is simulated + set.seed(4) + s7 <- oc_sample_binary2(ref_design_bin2("B7", enumerate = FALSE), + scen_bin2[, 1:3], nsim) + after <- runif(1) + set.seed(4) + invisible(runif(nsim * 3)) + expect_identical(runif(1), after) + expect_identical(dim(s7$p_go), c(nsim, 3L)) +}) + +test_that("oc_sample_binary2() handles a fixed control", { + des <- ref_design_bin2("BF1") + sc <- scen_bin2[, 1:3] + s <- oc_sample_binary2(des, sc, 1L) + x_t <- outcomes_binary2(3) + expect_identical(dim(s$p_go), c(20L, 1L)) + expect_equal(s$weights_c, matrix(1, 1L, 3L)) + res <- decide_binary2(des, data_binary2(x_t[7, ]), NULL) + expect_equal(s$p_go[7, 1], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[7, 1], res$prob_nogo, tolerance = 1e-12) + # Simulation + set.seed(6) + s2 <- oc_sample_binary2(ref_design_bin2("BF1", enumerate = FALSE), sc, 20L) + set.seed(6) + u_t <- matrix(runif(20 * 3), nrow = 20) + x <- simulate_counts_binary2(u_t, cellprob_binary2(sc$pi_t1[2], + sc$pi_t2[2], + sc$rho_t[2])) + res2 <- decide_binary2(des, data_binary2(x[5, ]), NULL) + expect_equal(s2$p_go[5, 2], res2$prob_go, tolerance = 1e-12) +}) diff --git a/tests/testthat/test-oc_sample_continuous.R b/tests/testthat/test-oc_sample_continuous.R new file mode 100644 index 0000000..33ba288 --- /dev/null +++ b/tests/testthat/test-oc_sample_continuous.R @@ -0,0 +1,89 @@ +test_that("oc_sample_continuous() returns probabilities and weights", { + set.seed(1) + s <- oc_sample_continuous(ref_design_cont("C1"), scen_cont_c, 50L) + expect_identical(dim(s$p_go), c(50L, 3L)) + expect_identical(dim(s$p_nogo), c(50L, 3L)) + expect_equal(s$weights, matrix(1 / 50, 50, 3)) + expect_true(all(s$p_go >= 0 & s$p_go <= 1)) + expect_true(all(s$p_go + s$p_nogo <= 1 + 1e-12)) + expect_identical(s$method, paste("simulation of 50 studies; probabilities", + "by numerical integration")) + s_mc <- oc_sample_continuous(ref_design_cont("C3", "MC", 200L), + scen_cont_u, 5L) + expect_identical(s_mc$method, paste("simulation of 5 studies; probabilities", + "by Monte Carlo simulation (nMC = 200)")) +}) + +test_that("oc_sample_continuous() uses common random numbers", { + sc <- data.frame(mu_t = c(10, 30, 10), sd_t = c(20, 25, 20), mu_c = 0, + sd_c = 25) + set.seed(2) + s <- oc_sample_continuous(ref_design_cont("C1", "MM"), sc, 200L) + expect_identical(s$p_go[, 1], s$p_go[, 3]) + expect_identical(s$p_nogo[, 1], s$p_nogo[, 3]) + # A larger true effect gives larger probabilities of the Go region for + # every simulated study when only the location changes + sc2 <- data.frame(mu_t = c(10, 30), sd_t = 20, mu_c = 0, sd_c = 25) + set.seed(2) + s2 <- oc_sample_continuous(ref_design_cont("C1", "MM"), sc2, 200L) + expect_true(all(s2$p_go[, 2] > s2$p_go[, 1])) +}) + +test_that("oc_sample_continuous() simulates the sufficient statistics", { + # The draws are rnorm(nsim) and rchisq(nsim, n_t - 1) for the treatment + # group, then the same for the control group. Each simulated study is + # recomputed here with qdm_decide(). + nsim <- 20L + sc <- data.frame(mu_t = c(20, 35), sd_t = c(25, 30), mu_c = c(0, -5), + sd_c = c(25, 20)) + des <- ref_design_cont("C2") + set.seed(3) + s <- oc_sample_continuous(des, sc, nsim) + set.seed(3) + z_t <- rnorm(nsim) + x_t <- rchisq(nsim, 9) + z_c <- rnorm(nsim) + x_c <- rchisq(nsim, 7) + for (j in 1:2) { + for (i in c(1, 7, 20)) { + d_t <- data_continuous(10, sc$mu_t[j] + sc$sd_t[j] * z_t[i] / sqrt(10), + sc$sd_t[j] * sqrt(x_t[i] / 9)) + d_c <- data_continuous(8, sc$mu_c[j] + sc$sd_c[j] * z_c[i] / sqrt(8), + sc$sd_c[j] * sqrt(x_c[i] / 7)) + res <- qdm_decide(des, d_t, d_c) + expect_equal(s$p_go[i, j], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[i, j], res$prob_nogo, tolerance = 1e-12) + } + } + # Without a concurrent control group only the treatment group is simulated + des3 <- ref_design_cont("C3") + set.seed(4) + s3 <- oc_sample_continuous(des3, scen_cont_u[2, ], nsim) + after <- runif(1) + set.seed(4) + z_t <- rnorm(nsim) + x_t <- rchisq(nsim, 11) + expect_identical(runif(1), after) + d_t <- data_continuous(12, 20 + 20 * z_t[5] / sqrt(12), + 20 * sqrt(x_t[5] / 11)) + expect_equal(s3$p_go[5, 1], qdm_decide(des3, d_t)$prob_go, + tolerance = 1e-12) +}) + +test_that("oc_sample_continuous() handles a fixed control", { + nsim <- 10L + des <- ref_design_cont("C7") + set.seed(5) + s <- oc_sample_continuous(des, scen_cont_u, nsim) + set.seed(5) + z_t <- rnorm(nsim) + x_t <- rchisq(nsim, 11) + ybar <- 20 + 20 * z_t / sqrt(12) + sd <- 20 * sqrt(x_t / 11) + expect_equal(s$p_go[, 2], stats::pt((20 - ybar) / (sd / sqrt(12)), 11, + lower.tail = FALSE), tolerance = 1e-12) + expect_equal(s$p_nogo[, 2], stats::pt((5 - ybar) / (sd / sqrt(12)), 11), + tolerance = 1e-12) + expect_identical(s$method, paste("simulation of 10 studies; probabilities", + "by exact computation (fixed control)")) +}) diff --git a/tests/testthat/test-oc_sample_continuous2.R b/tests/testthat/test-oc_sample_continuous2.R new file mode 100644 index 0000000..4da6220 --- /dev/null +++ b/tests/testthat/test-oc_sample_continuous2.R @@ -0,0 +1,69 @@ +test_that("oc_sample_continuous2() gives one column per scenario", { + des <- ref_design_cont2("K1") + sc <- scen_cont2("K1") + set.seed(1) + s <- oc_sample_continuous2(des, sc, 50L) + expect_identical(dim(s$p_go), c(50L, 3L)) + expect_true(s$per_scenario) + expect_equal(s$weights, matrix(1 / 50, 50, 3)) + expect_identical(s$method, paste("simulation of 50 studies; probabilities", + "by moment-matching approximation")) + # The first study of scenario 2, recomputed with decide_continuous2() + set.seed(1) + dt <- draws_continuous2(50L, 12) + dc <- draws_continuous2(50L, 12) + one <- function(d) lapply(d, `[`, 1L) + st <- stats_continuous2(one(dt), 12, c(0, 1), c(70, 6), 0.4) + sc2 <- stats_continuous2(one(dc), 12, c(-10, -1), c(70, 6), 0.4) + res <- decide_continuous2( + des, + data_continuous2(12, st$mean[1L, ], matrix(st$cov[1L, c(1, 2, 2, 3)], 2)), + data_continuous2(12, sc2$mean[1L, ], matrix(sc2$cov[1L, c(1, 2, 2, 3)], 2)) + ) + expect_equal(s$p_go[1L, 2L], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[1L, 2L], res$prob_nogo, tolerance = 1e-12) + # Identical scenarios give identical probabilities (common random numbers) + set.seed(2) + s2 <- oc_sample_continuous2(des, sc[c(2, 2), ], 20L) + expect_identical(s2$p_go[, 1L], s2$p_go[, 2L]) +}) + +test_that("oc_sample_continuous2() handles marginal rules and no control", { + set.seed(3) + s <- oc_sample_continuous2(ref_design_cont2("K5"), scen_cont2("K5"), 20L) + expect_length(s$p_go, 2L) + expect_identical(dim(s$p_nogo[[2]]), c(20L, 3L)) + # Without a concurrent control group only the treatment group is simulated + set.seed(4) + oc_sample_continuous2(ref_design_cont2("K4"), scen_cont2("K4"), 20L) + after <- stats::runif(1) + set.seed(4) + draws_continuous2(20L, 15) + expect_identical(stats::runif(1), after) + set.seed(5) + s6 <- oc_sample_continuous2(ref_design_cont2("K1", "MC", 300L), + scen_cont2("K1")[1, ], 5L) + expect_identical(dim(s6$p_go), c(5L, 1L)) + expect_match(s6$method, "Monte Carlo simulation \\(nMC = 300\\)") +}) + +test_that("oc_sample_continuous2() handles a fixed control", { + des <- ref_design_cont2("KF1") + sc <- scen_cont2("K4") + set.seed(7) + s <- oc_sample_continuous2(des, sc, 10L) + expect_identical(s$method, paste("simulation of 10 studies; probabilities", + "by exact computation (fixed control)")) + set.seed(7) + dt <- draws_continuous2(10L, 10) + one <- function(d) lapply(d, `[`, 3L) + st <- stats_continuous2(one(dt), 10, c(sc$mu_t1[2], sc$mu_t2[2]), + c(sc$sd_t1[2], sc$sd_t2[2]), sc$rho_t[2]) + res <- decide_continuous2( + des, + data_continuous2(10, st$mean[1L, ], matrix(st$cov[1L, c(1, 2, 2, 3)], 2)), + NULL + ) + expect_equal(s$p_go[3L, 2L], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[3L, 2L], res$prob_nogo, tolerance = 1e-12) +}) diff --git a/tests/testthat/test-oc_sample_tte.R b/tests/testthat/test-oc_sample_tte.R new file mode 100644 index 0000000..df5174a --- /dev/null +++ b/tests/testthat/test-oc_sample_tte.R @@ -0,0 +1,119 @@ +test_that("oc_sample_tte() matches the exact operating characteristics", { + # Complete follow-up with a fixed control: each criterion is a threshold on + # the total observed time, which is Gamma(30, log(2) / median) + # (Python_reference/ref_fixed_tte_qdm.py, design T1) + des <- ref_design_tte("T1") + sc <- data.frame(median_t = c(6.3, 9, 12, 20)) + nsim <- 20000L + set.seed(1) + s <- oc_sample_tte(des, sc, nsim) + oc <- oc_from_sample(s, des$criterion$gamma_go, des$criterion$gamma_nogo) + ref_go <- c(2.48918966507e-09, 0.000437959295081, 0.0642164668685, + 0.899733183632) + ref_nogo <- c(0.205961280815, 0.00511165154121, 6.01475591958e-05, + 2.15285582264e-09) + tol <- function(p) 4.5 * sqrt(p * (1 - p) / nsim) + 0.002 + expect_true(all(abs(oc[, "Go"] - ref_go) <= tol(ref_go))) + expect_true(all(abs(oc[, "NoGo"] - ref_nogo) <= tol(ref_nogo))) + expect_identical(s$method, paste("simulation of 20000 studies;", + "probabilities by exact computation", + "(fixed control)")) +}) + +test_that("oc_sample_tte() computes the probabilities of each simulated study", { + des <- ref_design_tte("T2") + sc <- data.frame(median_t = c(6, 12), median_c = c(6, 8)) + nsim <- 15L + set.seed(2) + s <- oc_sample_tte(des, sc, nsim) + expect_identical(dim(s$p_go), c(nsim, 2L)) + expect_true(s$per_scenario) + expect_equal(s$weights, matrix(1 / nsim, nsim, 2)) + # The same random numbers, drawn by the C++ code + set.seed(2) + ca <- conduct_args(des$conduct) + sim <- cpp_tte_oc_data(nsim, 20L, 20L, log(2) / c(6, 12), log(2) / c(6, 8), + ca$acc_time, ca$acc_cum, ca$drop_start, + ca$drop_hazard, ca$cut_time, ca$cut_events) + k <- nsim + 4L + res <- qdm_decide(des, data_tte(sim[k, 1], sim[k, 2]), + data_tte(sim[k, 3], sim[k, 4])) + expect_equal(s$p_go[4, 2], res$prob_go, tolerance = 1e-12) + expect_equal(s$p_nogo[4, 2], res$prob_nogo, tolerance = 1e-12) + expect_identical(s$method, paste("simulation of 15 studies; probabilities", + "by numerical integration")) +}) + +test_that("oc_sample_tte() handles the other control forms", { + sc <- data.frame(median_t = c(6, 12)) + set.seed(3) + s5 <- oc_sample_tte(ref_design_tte("T5"), sc, 10L) + expect_identical(dim(s5$p_go), c(10L, 2L)) + # Only the treatment group is simulated: the C++ code uses the same + # random numbers with no control group + set.seed(3) + ca <- conduct_args(conduct_example) + sim <- cpp_tte_oc_data(10L, 30L, 0L, log(2) / c(6, 12), c(1, 1), + ca$acc_time, ca$acc_cum, ca$drop_start, + ca$drop_hazard, ca$cut_time, ca$cut_events) + expect_true(all(sim[, 3:4] == 0)) + p <- region_prob_tte(ref_design_tte("T5"), + posterior_tte(prior_gamma(0.1, 1), sim[, 1], sim[, 2]), + list(shape = 8.1, rate = 61)) + expect_equal(as.vector(s5$p_go), p$go, tolerance = 1e-12) + set.seed(4) + s6 <- oc_sample_tte(ref_design_tte("T6"), sc, 5L) + expect_true(all(s6$p_go >= 0 & s6$p_go <= 1)) + # Predictive criterion + set.seed(5) + s3 <- oc_sample_tte(ref_design_tte("T3", nMC = 50L), sc, 4L) + expect_identical(s3$p_nogo, 1 - s3$p_go) + expect_match(s3$method, "simulation of future studies \\(nMC = 50\\)") +}) + +test_that("oc_sample_tte() needs the conduct of the study", { + des <- design_tte(10, 0, prior_gamma(1, 1), criterion = crit_tte(), + milestone = 3, fixed_c = 0.5) + expect_error(oc_sample_tte(des, data.frame(median_t = 5), 10L), + "The operating characteristics need the conduct of the study") +}) + +test_that("the simulated studies follow the model for other conducts", { + # Closed forms for the simulation of cpp_tte_oc_data() with hazard 0.1 and + # 30 subjects, within 4.5 simulation standard errors + nsim <- 4000L + lam <- 0.1 + close_to <- function(x, mu) { + abs(mean(x) - mu) <= 4.5 * stats::sd(x) / sqrt(length(x)) + } + sim_conduct <- function(conduct, seed) { + ca <- conduct_args(conduct) + set.seed(seed) + cpp_tte_oc_data(nsim, 30L, 0L, lam, 1, ca$acc_time, ca$acc_cum, + ca$drop_start, ca$drop_hazard, ca$cut_time, + ca$cut_events) + } + # All subjects enrolled at once and an analysis at the 10th event: every + # study has 10 events, and the total observed time is Gamma(10, lam) + sim <- sim_conduct(conduct_tte(c(0, 1e-9), cut_events = 10), 21) + expect_true(all(sim[, 1] == 10)) + expect_true(close_to(sim[, 2], 10 / lam)) + # Analysis at the 30th event with piecewise exponential dropout (hazard + # 0.1 before time 2 and 0.5 after): a study with fewer than 30 events is + # followed to the end, so the number of events and the total observed + # time are the sums of 1(T <= C) and min(T, C) over the subjects + sim <- sim_conduct(conduct_tte(c(0, 1), dropout_time = c(0, 2), + dropout_hazard = c(0.1, 0.5), + cut_events = 30), 22) + e_min <- (1 - exp(-2 * (lam + 0.1))) / (lam + 0.1) + + exp(-0.2 - 2 * lam) / (lam + 0.5) + expect_true(any(sim[, 1] < 30)) + expect_true(close_to(sim[, 1], 30 * lam * e_min)) + expect_true(close_to(sim[, 2], 30 * e_min)) + # Uniform enrollment over 10 time units and an analysis at time 5: + # subjects enrolled after the analysis contribute nothing + sim <- sim_conduct(conduct_tte(c(0, 10), cut_time = 5), 23) + e_r <- (5 - (1 - exp(-5 * lam)) / lam) / (10 * lam) + expect_true(close_to(sim[, 1], 30 * lam * e_r)) + expect_true(close_to(sim[, 2], 30 * e_r)) +}) diff --git a/tests/testthat/test-outcome_key.R b/tests/testthat/test-outcome_key.R new file mode 100644 index 0000000..3d7c3bd --- /dev/null +++ b/tests/testthat/test-outcome_key.R @@ -0,0 +1,11 @@ +test_that("outcome_key() distinguishes count vectors", { + x <- outcomes_binary2(6) + expect_identical(anyDuplicated(outcome_key(x)), 0L) + expect_equal(outcome_key(matrix(c(1L, 2L, 3L, 4L), 1L)), + 2 + 5 * 3 + 5 ^ 2 * 4) + # The base grows with the counts (a fixed base of 1001 would give the + # same key to these two rows) + y <- rbind(c(0L, 1001L, 0L, 0L), c(1000L, 0L, 1L, 0L)) + expect_false(outcome_key(y)[1] == outcome_key(y)[2]) + expect_length(outcome_key(matrix(integer(0), 0L, 4L)), 0L) +}) diff --git a/tests/testthat/test-outcome_prob.R b/tests/testthat/test-outcome_prob.R new file mode 100644 index 0000000..3369edb --- /dev/null +++ b/tests/testthat/test-outcome_prob.R @@ -0,0 +1,11 @@ +test_that("outcome_prob() uses full or factored weights", { + s1 <- list(weights = cbind(c(0.2, 0.8), c(0.5, 0.5))) + expect_equal(outcome_prob(c(TRUE, FALSE), s1), c(0.2, 0.5)) + # Pairs of outcomes: P(pair) = w_t * w_c + s2 <- list(weights_t = cbind(c(0.3, 0.7), c(0.6, 0.4)), + weights_c = cbind(c(0.1, 0.9), c(0.5, 0.5))) + ind <- matrix(c(TRUE, FALSE, TRUE, TRUE), 2L) + expect_equal(outcome_prob(ind, s2), + c(0.3 * 0.1 + 0.3 * 0.9 + 0.7 * 0.9, + 0.6 * 0.5 + 0.6 * 0.5 + 0.4 * 0.5)) +}) diff --git a/tests/testthat/test-outcomes_binary2.R b/tests/testthat/test-outcomes_binary2.R new file mode 100644 index 0000000..e749ab3 --- /dev/null +++ b/tests/testthat/test-outcomes_binary2.R @@ -0,0 +1,11 @@ +test_that("outcomes_binary2() lists all count vectors once", { + for (n in c(0, 1, 4, 10)) { + x <- outcomes_binary2(n) + expect_identical(nrow(x), as.integer(choose(n + 3, 3))) + expect_true(all(rowSums(x) == n)) + expect_true(all(x >= 0)) + expect_identical(anyDuplicated(x), 0L) + } + expect_identical(colnames(outcomes_binary2(2)), c("00", "01", "10", "11")) + expect_type(outcomes_binary2(2), "integer") +}) diff --git a/tests/testthat/test-pbetabinomdiff.R b/tests/testthat/test-pbetabinomdiff.R new file mode 100644 index 0000000..8dfdb5b --- /dev/null +++ b/tests/testthat/test-pbetabinomdiff.R @@ -0,0 +1,110 @@ +# Reference values: Python_reference/ref_distributions_mpmath.py (exact +# rational summation with mpmath, 40 digits), cross-checked with scipy. +ref_pbetabinomdiff <- data.frame( + q = c(0, 0.1, 0.05, -0.1, 0), + m_t = c(20, 30, 20, 15, 1000), + a_t = c(7.5, 3, 7.5, 1.5, 50.5), + b_t = c(5.5, 2, 5.5, 3.5, 50.5), + m_c = c(20, 20, 20, 25, 1000), + a_c = c(4.5, 2, 4.5, 2.5, 40.5), + b_c = c(8.5, 3, 8.5, 2.5, 60.5), + upper = c(0.80686057751115994, 0.62263529749757634, 0.74700508465629342, + 0.36688900774350382, 0.91128008512545626) +) + +test_that("pbetabinomdiff() matches exact upper tail references", { + r <- ref_pbetabinomdiff + for (i in seq_len(nrow(r))) { + expect_equal(pbetabinomdiff(r$q[i], r$m_t[i], r$a_t[i], r$b_t[i], + r$m_c[i], r$a_c[i], r$b_c[i], + lower.tail = FALSE), + r$upper[i], tolerance = 1e-9, info = paste("case", i)) + } +}) + +test_that("pbetabinomdiff() lower tail is the complement of the upper tail", { + r <- ref_pbetabinomdiff + for (i in seq_len(nrow(r))) { + expect_equal(pbetabinomdiff(r$q[i], r$m_t[i], r$a_t[i], r$b_t[i], + r$m_c[i], r$a_c[i], r$b_c[i]), + 1 - r$upper[i], tolerance = 1e-9, info = paste("case", i)) + } +}) + +test_that("pbetabinomdiff() puts exact ties in the lower tail", { + # With m_t = m_c = 20 and q = 0.05, the difference equals q exactly when + # Y_t - Y_c = 1. Brute-force enumeration with integer arithmetic. + k <- 0:20 + p_t <- dbetabinom(k, 20, 7.5, 5.5) + p_c <- dbetabinom(k, 20, 4.5, 8.5) + above <- outer(k, k, "-") > 1 + expected <- sum(outer(p_t, p_c) * above) + expect_equal(pbetabinomdiff(0.05, 20, 7.5, 5.5, 20, 4.5, 8.5, + lower.tail = FALSE), + expected, tolerance = 1e-12) +}) + +test_that("pbetabinomdiff() is vectorised over q and the shapes", { + vec <- pbetabinomdiff(c(0, 0.1), 20, c(7.5, 6.5), 5.5, 20, 4.5, 8.5) + one <- c(pbetabinomdiff(0, 20, 7.5, 5.5, 20, 4.5, 8.5), + pbetabinomdiff(0.1, 20, 6.5, 5.5, 20, 4.5, 8.5)) + expect_identical(vec, one) +}) + +test_that("pbetabinomdiff() validates its arguments", { + expect_error(pbetabinomdiff(0, 0, 1, 1, 10, 1, 1), "'m_t' must be at least") + expect_error(pbetabinomdiff(0, 10, 1, 1, c(10, 20), 1, 1), + "'m_c' must have length 1.") + expect_error(pbetabinomdiff(0, 10, 1, -1, 10, 1, 1), + "'b_t' must be greater than 0.") +}) + +test_that("pbetabinomdiff() agrees with direct enumeration over a grid", { + pmf <- function(m, a, b) { + k <- 0:m + choose(m, k) * beta(k + a, m - k + b) / beta(a, b) + } + qs <- c(-1, -0.5, -0.1, 0, 1 / 12, 0.2, 0.5, 1) + for (m_t in c(1, 5, 12)) { + for (m_c in c(1, 4, 12)) { + for (s in list(c(0.5, 0.5, 0.5, 0.5), c(3, 1.5, 2, 6))) { + joint <- outer(pmf(m_t, s[1], s[2]), pmf(m_c, s[3], s[4])) + diffs <- outer(m_c * (0:m_t), m_t * (0:m_c), "-") / (m_t * m_c) + brute <- vapply(qs, function(q) sum(joint[diffs > q]), numeric(1)) + got <- pbetabinomdiff(qs, m_t, s[1], s[2], m_c, s[3], s[4], + lower.tail = FALSE) + expect_equal(got, brute, tolerance = 1e-12, + info = paste("m_t =", m_t, "m_c =", m_c)) + } + } + } +}) + +test_that("pbetabinomdiff() has the correct limits", { + args <- list(m_t = 6, a_t = 2, b_t = 3, m_c = 4, a_c = 1.5, b_c = 2.5) + up <- function(q) { + do.call(pbetabinomdiff, c(list(q = q, lower.tail = FALSE), args)) + } + expect_identical(up(1), 0) + expect_equal(up(-1.01), 1, tolerance = 1e-14) + # The difference equals -1 only when Y_t = 0 and Y_c = m_c + p_t0 <- dbetabinom(0, 6, 2, 3) + p_cm <- dbetabinom(4, 4, 1.5, 2.5) + expect_equal(up(-1), 1 - p_t0 * p_cm, tolerance = 1e-12) + # Values of q far outside [-1, 1] (the cut points are computed with q + # restricted to [-2, 2]) + expect_equal(up(-1e17), 1, tolerance = 1e-14) + expect_identical(up(1e17), 0) + expect_identical(do.call(pbetabinomdiff, c(list(q = -1e17), args)), 0) +}) + +test_that("pbetabinomdiff() agrees with Monte Carlo simulation", { + skip_on_cran() + set.seed(12) + n <- 1e6 + y_t <- stats::rbinom(n, 20, stats::rbeta(n, 7.5, 5.5)) + y_c <- stats::rbinom(n, 15, stats::rbeta(n, 4.5, 8.5)) + d <- y_t / 20 - y_c / 15 + p <- pbetabinomdiff(0.1, 20, 7.5, 5.5, 15, 4.5, 8.5, lower.tail = FALSE) + expect_lt(abs(mean(d > 0.1) - p), 4 * sqrt(p * (1 - p) / n)) +}) diff --git a/tests/testthat/test-pbetadiff.R b/tests/testthat/test-pbetadiff.R new file mode 100644 index 0000000..543396f --- /dev/null +++ b/tests/testthat/test-pbetadiff.R @@ -0,0 +1,180 @@ +# Reference values: Python_reference/ref_distributions_mpmath.py (mpmath, 40 +# digits, two integral representations), cross-checked with scipy. +ref_pbetadiff <- data.frame( + q = c(0, 0.1, -0.2, 0.05, 0.2, 0.001, 0.95, -0.95), + a_t = c(5, 6, 2.5, 0.5, 7.5, 30.5, 20, 1), + b_t = c(5, 3, 10.5, 12.5, 5.5, 9970.5, 1, 20), + a_c = c(5, 5, 4.5, 0.5, 4.5, 10.5, 1, 20), + b_c = c(5, 8, 8.5, 12.5, 8.5, 9990.5, 20, 1), + upper = c(0.5, 0.81832837711327888, 0.60911710328926547, + 0.16845257184576472, 0.57601763350543618, 0.94619967208045943, + 0.27051374743310446, 0.72948625256689554) +) + +test_that("pbetadiff() matches high-precision upper tail references", { + r <- ref_pbetadiff + for (i in seq_len(nrow(r))) { + expect_equal(pbetadiff(r$q[i], r$a_t[i], r$b_t[i], r$a_c[i], r$b_c[i], + lower.tail = FALSE), + r$upper[i], tolerance = 1e-9, info = paste("case", i)) + } +}) + +test_that("pbetadiff() lower tail is the complement of the upper tail", { + r <- ref_pbetadiff + lower <- pbetadiff(r$q, r$a_t, r$b_t, r$a_c, r$b_c) + expect_equal(lower, 1 - r$upper, tolerance = 1e-9) +}) + +test_that("pbetadiff() is vectorised with recycling", { + q <- c(-0.1, 0, 0.1) + vec <- pbetadiff(q, 6, 3, 5, 8, lower.tail = FALSE) + one <- vapply(q, pbetadiff, numeric(1), a_t = 6, b_t = 3, a_c = 5, b_c = 8, + lower.tail = FALSE) + expect_identical(vec, one) + expect_true(all(diff(vec) < 0)) +}) + +test_that("pbetadiff() returns 0 and 1 outside the support", { + expect_identical(pbetadiff(1, 2, 3, 4, 5, lower.tail = FALSE), 0) + expect_identical(pbetadiff(-1, 2, 3, 4, 5, lower.tail = FALSE), 1) +}) + +test_that("pbetadiff() validates its arguments", { + expect_error(pbetadiff(0, 0, 1, 1, 1), "'a_t' must be greater than 0.") + expect_error(pbetadiff(c(0, 0.1), c(1, 2, 3), 1, 1, 1), + "'q' must have length 1 or 3.") + expect_error(pbetadiff(0, 1, 1, 1, 1, lower.tail = NA), + "'lower.tail' must be TRUE or FALSE.") +}) + +test_that("pbetadiff() matches the finite-sum formula for integer a_t at q = 0", { + # For integer a_t, P(pi_t > pi_c) is a finite sum (Python_reference/ + # check_closed_forms.py confirms it against numerical integration). + grid <- expand.grid(a_t = 1:8, b_t = c(0.5, 1, 3.5, 12), + a_c = c(0.5, 1, 3.5, 12), b_c = c(0.5, 1, 3.5, 12)) + exact <- vapply(seq_len(nrow(grid)), function(k) { + g <- grid[k, ] + i <- seq(0, g$a_t - 1) + sum(exp(lbeta(g$a_c + i, g$b_c + g$b_t) - log(g$b_t + i) - + lbeta(1 + i, g$b_t) - lbeta(g$a_c, g$b_c))) + }, numeric(1)) + got <- pbetadiff(0, grid$a_t, grid$b_t, grid$a_c, grid$b_c, + lower.tail = FALSE) + expect_equal(got, exact, tolerance = 1e-9) +}) + +# Stress cases: Python_reference/ref_pbetadiff_stress_mpmath.py (mpmath, 30 +# digits, tanh-sinh quadrature with the singular points of the densities at +# the ends of the range of integration). Python_reference/ +# select_pbetadiff_stress.py selects every tenth case of the grid and all +# cases in which the integration without the change of variables near the +# singular endpoints had an absolute error above 1e-9 (17 cases). +stress_pbetadiff <- data.frame( + case = c(0, 5, 10, 14, 20, 30, 32, 37, 40, 41, 50, 60, + 70, 73, 76, 80, 90, 98, 100, 110, 113, 117, 119, 120, + 123, 124, 130, 139, 140, 150, 160, 170, 180, 190, 200, 210, + 220, 230, 240, 250), + q = c(-0.9, -0.9, -0.9, -0.9, -0.9, -0.3, -0.3, -0.3, -0.3, -0.3, + -0.05, -0.05, -0.05, -0.05, -0.05, -0.05, -1e-06, -1e-06, -1e-06, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1e-06, + 1e-06, 1e-06, 0.05, 0.05, 0.05, 0.05, 0.05, 0.3, 0.3, 0.9), + a_t = c(0.3, 0.8, 1, 3.5, 12, 0.3, 0.5, 1.5, 3.5, 3.5, + 0.3, 0.5, 1.5, 3.5, 12, 50.5, 0.8, 1.5, 3.5, 0.3, + 0.5, 1, 1, 1, 1, 1.5, 3.5, 1000.5, 1000.5, 0.5, + 0.8, 3.5, 0.3, 0.8, 1.5, 12, 1000.5, 12, 1000.5, 1.5), + b_t = c(0.5, 0.3, 0.8, 0.3, 12, 1, 0.3, 12, 0.3, 1, + 0.5, 2.5, 1000.5, 0.5, 1.5, 3.5, 1.5, 12, 0.3, 2.5, + 2.5, 0.5, 2.5, 2.5, 12, 0.8, 0.8, 0.8, 1000.5, 1.5, + 12, 3.5, 2.5, 0.5, 0.3, 0.3, 3.5, 1, 1.5, 0.3), + a_c = c(12, 0.3, 1.5, 0.3, 0.8, 50.5, 3.5, 0.5, 1.5, 0.8, + 1000.5, 0.3, 0.3, 12, 0.3, 50.5, 1.5, 0.8, 0.5, 0.8, + 0.3, 0.3, 0.3, 0.5, 0.5, 3.5, 1.5, 3.5, 0.5, 1.5, + 12, 0.3, 0.3, 50.5, 1, 0.8, 1000.5, 12, 12, 0.8), + b_c = c(1, 0.8, 1000.5, 0.8, 1, 3.5, 0.8, 0.8, 0.8, 0.8, + 1, 4, 50.5, 0.8, 0.8, 50.5, 1.5, 0.8, 0.5, 4, + 4, 0.3, 4, 4, 3.5, 0.8, 0.5, 0.8, 1, 3.5, + 50.5, 0.8, 4, 1000.5, 1, 1000.5, 0.8, 12, 0.5, 0.5), + upper = c(0.78147756325279410379, 0.99814248309371167287, + 1.0, 0.99999930346318561614, + 0.99999999687305614588, 0.12754816221221219706, + 0.63185169360613470981, 0.57394455466253133721, + 0.98222197132984332322, 0.9481908891291601313, + 0.10037577211254767805, 0.82947269524096216324, + 0.99011640073675305789, 0.59433463828456951789, + 0.96336946952969003811, 0.99999999996782670512, + 0.33150884141014086879, 0.13816863642211098422, + 0.86371317408546832994, 0.31860889966307426188, + 0.69800257255950772626, 0.60918576977096304155, + 0.85558188487959095894, 0.77513966687846307973, + 0.46228623390197753798, 0.31785262915599758083, + 0.53637529537897118811, 0.99128280000881698558, + 0.70706261048164388536, 0.3847177119395777698, + 0.068325499164829594361, 0.75125177720507794449, + 0.33295432566138725666, 0.91326733770048470407, + 0.78338650747441059305, 0.99999999999999998181, + 1.6216022603770513545e-24, 0.84579210478621164998, + 0.0036725899305870677651, 0.040901440062194422561) +) + +test_that("pbetadiff() is accurate when shape parameters are below 1", { + r <- stress_pbetadiff + upper <- pbetadiff(r$q, r$a_t, r$b_t, r$a_c, r$b_c, lower.tail = FALSE) + lower <- pbetadiff(r$q, r$a_t, r$b_t, r$a_c, r$b_c) + for (i in seq_len(nrow(r))) { + expect_lt(abs(upper[i] - r$upper[i]), 1e-9, + label = paste("upper tail error, stress case", r$case[i])) + expect_lt(abs(lower[i] - (1 - r$upper[i])), 1e-9, + label = paste("lower tail error, stress case", r$case[i])) + } +}) + +test_that("pbetadiff() agrees with integration over the treatment variable", { + # Alternative representation: P(pi_t - pi_c > q) = + # int f_t(y) F_c(y - q) dy + [q < 0] P(pi_t > 1 + q) + grid <- expand.grid(q = c(-0.6, -0.2, 0.05, 0.3, 0.7), + shapes = 1:3) + shapes <- list(c(2.5, 4.5, 3.5, 6.5), c(0.5, 9.5, 1.5, 8.5), + c(15.5, 5.5, 10.5, 10.5)) + for (k in seq_len(nrow(grid))) { + q <- grid$q[k] + s <- shapes[[grid$shapes[k]]] + alt <- stats::integrate( + function(y) stats::dbeta(y, s[1], s[2]) * stats::pbeta(y - q, s[3], s[4]), + lower = max(0, q), upper = min(1, 1 + q), rel.tol = 1e-11 + )$value + if (q < 0) { + alt <- alt + stats::pbeta(1 + q, s[1], s[2], lower.tail = FALSE) + } + expect_equal(pbetadiff(q, s[1], s[2], s[3], s[4], lower.tail = FALSE), + alt, tolerance = 1e-7, info = paste("case", k)) + } +}) + +test_that("pbetadiff() is a non-increasing function of q in [0, 1]", { + q <- seq(-1.2, 1.2, length.out = 241) + p <- pbetadiff(q, 3.5, 9.5, 6.5, 6.5, lower.tail = FALSE) + expect_true(all(diff(p) <= 1e-10)) + expect_true(all(p >= 0 & p <= 1)) + expect_identical(p[q <= -1], rep(1, sum(q <= -1))) + expect_identical(p[q >= 1], rep(0, sum(q >= 1))) +}) + +test_that("pbetadiff() handles long vectors", { + q <- seq(-0.5, 0.5, length.out = 1200) + p <- pbetadiff(q, 7.5, 5.5, 4.5, 8.5) + expect_length(p, 1200L) + expect_identical(p[c(1, 600, 1200)], + pbetadiff(q[c(1, 600, 1200)], 7.5, 5.5, 4.5, 8.5)) +}) + +test_that("pbetadiff() agrees with Monte Carlo simulation", { + skip_on_cran() + set.seed(11) + n <- 1e6 + d <- stats::rbeta(n, 7.5, 5.5) - stats::rbeta(n, 4.5, 8.5) + for (q in c(-0.1, 0, 0.2)) { + p <- pbetadiff(q, 7.5, 5.5, 4.5, 8.5, lower.tail = FALSE) + expect_lt(abs(mean(d > q) - p), 4 * sqrt(p * (1 - p) / n)) + } +}) diff --git a/tests/testthat/test-plot.qdm_boundary.R b/tests/testthat/test-plot.qdm_boundary.R new file mode 100644 index 0000000..2e96266 --- /dev/null +++ b/tests/testthat/test-plot.qdm_boundary.R @@ -0,0 +1,68 @@ +plot_labels <- function(p) { + if (exists("get_labs", envir = asNamespace("ggplot2"), inherits = FALSE)) { + ggplot2::get_labs(p) + } else { + p$labels + } +} + +test_that("plot.qdm_boundary() draws the decision of each grid point", { + b <- qdm_boundary(ref_design("D8"), n_t = 10:20) + p <- plot(b) + expect_s3_class(p, "ggplot") + tiles <- ggplot2::ggplot_build(p)$data[[1]] + expect_identical(nrow(tiles), nrow(b)) + idx <- match(paste(tiles$x, tiles$y), paste(b$n_t, b$y_t)) + expect_false(anyNA(idx)) + cols <- c(Go = "#658D1B", NoGo = "#D91E49", Gray = "#939597", + Miss = "#E69F00") + expect_identical(unname(tiles$fill), unname(cols[as.character( + b$decision[idx])])) + labs <- plot_labels(p) + expect_identical(labs$x, "Treatment group size") + expect_identical(labs$y, "Responders in the treatment group") + expect_identical(labs$fill, "Decision") +}) + +test_that("plot.qdm_boundary() shows the control data in a caption", { + b <- qdm_boundary(ref_design_tte("T2"), events_t = 0:20, + exposure_t = seq(20, 200, by = 20), + data_c = data_tte(9, 35)) + p <- plot(b) + labs <- plot_labels(p) + expect_match(labs$caption, "^Control data: ") + expect_identical(labs$x, "Total observed time of the treatment group") + tiles <- ggplot2::ggplot_build(p)$data[[1]] + expect_setequal(unique(tiles$fill), + c(Go = "#658D1B", NoGo = "#D91E49", Gray = "#939597", + Miss = "#E69F00")[unique(as.character(b$decision))]) +}) + +test_that("plot.qdm_boundary() needs the axes attribute", { + b <- qdm_boundary(ref_design("D8")) + attr(b, "axes") <- NULL + expect_error(plot(b), + "'x' must be an unmodified result of qdm_boundary\\(\\).") +}) + +test_that("plot.qdm_boundary() takes colors, text size and legend", { + b <- qdm_boundary(ref_design("D8"), n_t = 10:20) + p <- plot(b, col_go = "black", col_nogo = "blue", col_gray = "white", + base_size = 8, legend_position = "none") + tiles <- ggplot2::ggplot_build(p)$data[[1]] + idx <- match(paste(tiles$x, tiles$y), paste(b$n_t, b$y_t)) + cols <- c(Go = "black", NoGo = "blue", Gray = "white", Miss = "#E69F00") + expect_identical(unname(tiles$fill), unname(cols[as.character( + b$decision[idx])])) + expect_true(all(c("Go", "NoGo", "Gray") %in% as.character(b$decision))) + th <- plot_theme(p) + expect_identical(th[["legend.position"]], "none") + expect_identical(element_size(th[["text"]]), 8) + expect_error(plot(b, col_gray = "grey500"), + "'col_gray' must be a single color name", fixed = TRUE) + expect_warning( + plot(b, linewidth = 2), + "Ignoring unknown argument(s) of plot.qdm_boundary(): linewidth.", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-plot.qdm_calibration.R b/tests/testthat/test-plot.qdm_calibration.R new file mode 100644 index 0000000..2f018ec --- /dev/null +++ b/tests/testthat/test-plot.qdm_calibration.R @@ -0,0 +1,51 @@ +test_that("plot.qdm_calibration() draws the calibration curves", { + cal <- run_cal("D1") + p <- plot(cal) + expect_s3_class(p, "ggplot") + b <- ggplot2::ggplot_build(p) + # Layers: targets, chosen thresholds, curves + expect_equal(sort(b$data[[1]]$yintercept), c(0.05, 0.2)) + expect_equal(sort(b$data[[2]]$xintercept), c(0.41, 0.7)) + steps <- b$data[[3]] + expect_equal(nrow(steps), 2L * 99L) + expect_equal(steps$y[steps$group == 1], cal$curve$prob_go) + expect_equal(steps$y[steps$group == 2], cal$curve$prob_nogo) + expect_identical(unique(steps$colour[steps$group == 2]), "#D91E49") +}) + +test_that("plot.qdm_calibration() omits thresholds that were not found", { + a <- cal_args$D1 + cal <- suppressWarnings( + qdm_calibrate(ref_design("D1"), a$scenario_go, a$scenario_nogo, + target_go = 1e-6, target_nogo = 0.2) + ) + b <- ggplot2::ggplot_build(plot(cal)) + expect_equal(b$data[[2]]$xintercept, 0.41) +}) + +test_that("plot.qdm_calibration() takes colors, line width and legend", { + cal <- run_cal("D1") + p <- plot(cal, col_go = "black", col_nogo = "blue", linewidth = 0.4, + base_size = 9, legend_position = "top") + b <- ggplot2::ggplot_build(p) + steps <- b$data[[3]] + expect_identical(unique(steps$colour[steps$group == 1]), "black") + expect_identical(unique(steps$colour[steps$group == 2]), "blue") + expect_identical(unique(steps$linewidth), 0.4) + # The targets take the colors of their criteria + expect_setequal(b$data[[1]]$colour, c("black", "blue")) + th <- plot_theme(p) + expect_identical(th[["legend.position"]], "top") + expect_identical(element_size(th[["text"]]), 9) + expect_identical(unique(ggplot2::ggplot_build(plot(cal))$data[[3]]$linewidth), + 1) + expect_error(plot(cal, col_nogo = NA), + "'col_nogo' must be a single color name", fixed = TRUE) + expect_error(plot(cal, base_size = -1), "'base_size' must be greater than 0.", + fixed = TRUE) + expect_warning( + plot(cal, point_size = 2), + "Ignoring unknown argument(s) of plot.qdm_calibration(): point_size.", + fixed = TRUE + ) +}) diff --git a/tests/testthat/test-plot.qdm_oc.R b/tests/testthat/test-plot.qdm_oc.R new file mode 100644 index 0000000..693aad1 --- /dev/null +++ b/tests/testthat/test-plot.qdm_oc.R @@ -0,0 +1,213 @@ +test_that("plot.qdm_oc() draws the decision probabilities", { + oc <- qdm_oc(ref_design("D1"), + data.frame(pi_t = c(0.6, 0.2, 0.4), pi_c = 0.4)) + p <- plot(oc) + expect_s3_class(p, "ggplot") + b <- ggplot2::ggplot_build(p) + # Layers: threshold lines, their labels, curves, points + expect_equal(sort(unique(b$data[[1]]$xintercept)), c(0.1, 0.2)) + lines <- b$data[[3]] + expect_equal(nrow(lines), 9L) + expect_equal(sort(unique(lines$x)), c(-0.2, 0, 0.2)) + # Curves for Go, NoGo and Gray, in increasing order of the effect + expect_identical(sort(unique(lines$group)), 1:3) + expect_equal(lines$y[lines$group == 1], oc$Go[order(oc$pi_t)]) + expect_equal(lines$y[lines$group == 3], oc$Gray[order(oc$pi_t)]) + expect_identical(unique(lines$colour[lines$group == 1]), "#658D1B") +}) + +test_that("plot.qdm_oc() adds Miss decisions and shifted thresholds", { + expect_warning(oc <- qdm_oc(ref_design("D6"), scen_c), "Miss") + lines <- ggplot2::ggplot_build(plot(oc))$data[[3]] + expect_identical(sort(unique(lines$group)), 1:4) + expect_equal(lines$y[lines$group == 4], oc$Miss) + expect_identical(unique(lines$colour[lines$group == 4]), "#E69F00") + oc3 <- qdm_oc(ref_design("D3"), scen_u) + b3 <- ggplot2::ggplot_build(plot(oc3)) + expect_equal(sort(unique(b3$data[[1]]$xintercept)), 5 / 14 + c(0.1, 0.2)) + expect_equal(sort(unique(b3$data[[3]]$x)), scen_u$pi_t) +}) + +test_that("plot.qdm_oc() needs distinct values on the horizontal axis", { + # Two scenarios with the same effect (0.2) but different control rates + oc <- qdm_oc(ref_design("D1"), data.frame(pi_t = c(0.5, 0.6), + pi_c = c(0.3, 0.4))) + expect_error(plot(oc), "distinct values on the horizontal axis") + oc_cont <- qdm_oc(ref_design_cont("C1", "MM"), + data.frame(mu_t = 20, sd_t = c(20, 30), mu_c = 0, + sd_c = 25), nsim = 20, seed = 1) + expect_error(plot(oc_cont), "distinct values on the horizontal axis") +}) + +test_that("plot.qdm_oc() needs the design attribute", { + oc <- qdm_oc(ref_design("D1"), scen_c) + attr(oc, "design") <- NULL + expect_error(plot(oc), "'x' must be an unmodified result of qdm_oc().") +}) + +test_that("plot.qdm_oc() draws continuous operating characteristics", { + oc <- qdm_oc(ref_design_cont("C1", "MM"), scen_cont_c, nsim = 200, + seed = 1) + b <- ggplot2::ggplot_build(plot(oc)) + expect_equal(sort(unique(b$data[[1]]$xintercept)), c(15, 30)) + expect_equal(sort(unique(b$data[[3]]$x)), c(0, 20, 40)) + oc3 <- qdm_oc(ref_design_cont("C3", "MM"), scen_cont_u, nsim = 200, + seed = 1) + b3 <- ggplot2::ggplot_build(plot(oc3)) + expect_equal(sort(unique(b3$data[[1]]$xintercept)), c(5, 20)) + expect_equal(sort(unique(b3$data[[3]]$x)), scen_cont_u$mu_t) +}) + +test_that("plot.qdm_oc() draws heat maps for two endpoints", { + sc <- expand.grid(th1 = c(0, 0.2), th2 = c(0, 0.2, 0.4)) + sc <- data.frame(pi_t1 = 0.3 + sc$th1, pi_t2 = 0.3 + sc$th2, rho_t = 0.5, + pi_c1 = 0.3, pi_c2 = 0.3, rho_c = 0.5) + w <- character(0) + oc <- withCallingHandlers(qdm_oc(ref_design_bin2("B2"), sc), + warning = function(e) { + w <<- c(w, conditionMessage(e)) + invokeRestart("muffleWarning") + }) + # Scenario 5 (pi_t1 = 0.3, pi_t2 = 0.7, rho_t = 0.5) is infeasible + expect_identical(w, paste("Scenario(s) 5 are not evaluable: the", + "correlation is outside the feasible range for", + "the response rates. Their probabilities are", + "NA.")) + expect_identical(which(is.na(oc$Go)), 5L) + p <- plot(oc) + expect_s3_class(p, "ggplot") + b <- ggplot2::ggplot_build(p) + tiles <- b$data[[1]] + expect_identical(nrow(tiles), 3L * nrow(sc)) + labels <- b$data[[2]]$label + expect_identical(sum(labels == "NE"), 3L * sum(is.na(oc$Go))) + expect_true(all(labels[labels != "NE"] %in% + sprintf("%.2f", c(oc$Go, oc$NoGo, oc$Gray)))) + # Scenarios that are not evaluable are white + d <- plot_data(p) + expect_identical(unique(d$fill[is.na(d$prob)]), "#FFFFFF") + # Several correlations at the same effects cannot be drawn together + oc2 <- qdm_oc(ref_design_bin2("B2"), rbind(scen_bin2[1, ], scen_bin2[1, ])) + expect_error(plot(oc2), "with different correlations or control") + # Without a concurrent control group the axes are the treatment rates + oc7 <- suppressWarnings(qdm_oc(ref_design_bin2("B7"), + sc[, c("pi_t1", "pi_t2", "rho_t")])) + n_dec <- 3L + any(oc7$Miss > 0, na.rm = TRUE) + expect_identical(nrow(ggplot2::ggplot_build(plot(oc7))$data[[1]]), + n_dec * nrow(sc)) +}) + +test_that("plot.qdm_oc() draws heat maps for two continuous endpoints", { + sc <- expand.grid(mu_t1 = c(-10, 10), mu_t2 = c(-1, 1, 3)) + sc$sd_t1 <- 30 + sc$sd_t2 <- 3 + sc$rho_t <- 0.5 + oc <- withCallingHandlers( + qdm_oc(ref_design_cont2("K4"), sc, nsim = 50L, seed = 1), + warning = function(w) { + if (grepl("Miss", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + } + ) + p <- plot(oc) + expect_s3_class(p, "ggplot") + n_dec <- 3L + any(oc$Miss > 0) + expect_identical(nrow(ggplot2::ggplot_build(p)$data[[1]]), + n_dec * nrow(sc)) +}) + +test_that("plot.qdm_oc() draws fixed-control and time-to-event designs", { + oc <- qdm_oc(ref_design("D8"), scen_u) + b <- ggplot2::ggplot_build(plot(oc)) + expect_equal(sort(unique(b$data[[1]]$xintercept)), c(0.25, 0.4)) + expect_equal(sort(unique(b$data[[3]]$x)), scen_u$pi_t) + sc <- data.frame(median_t = c(6.3, 9, 12, 20)) + oc_t <- qdm_oc(ref_design_tte("T1"), sc, nsim = 200, seed = 1) + b_t <- ggplot2::ggplot_build(plot(oc_t)) + expect_equal(sort(unique(b_t$data[[1]]$xintercept)), c(0.72, 0.87)) + expect_equal(sort(unique(b_t$data[[3]]$x)), + exp(-log(2) * 3 / sc$median_t)) +}) + +test_that("plot.qdm_oc() takes colors, sizes and the legend position", { + oc <- qdm_oc(ref_design("D1"), + data.frame(pi_t = c(0.6, 0.2, 0.4), pi_c = 0.4)) + p <- plot(oc, col_go = "black", col_nogo = "blue", col_gray = "#123456", + linewidth = 2, point_size = 3, label_size = 5, base_size = 16, + legend_position = "right") + b <- ggplot2::ggplot_build(p) + # Layers: threshold lines, their labels, curves, points + lines <- b$data[[3]] + expect_identical(unique(lines$colour[lines$group == 1]), "black") + expect_identical(unique(lines$colour[lines$group == 2]), "blue") + expect_identical(unique(lines$colour[lines$group == 3]), "#123456") + expect_identical(unique(lines$linewidth), 2) + expect_identical(unique(b$data[[4]]$size), 3) + expect_identical(unique(b$data[[2]]$size), 5) + th <- plot_theme(p) + expect_identical(th[["legend.position"]], "right") + expect_identical(element_size(th[["text"]]), 16) + # Defaults + b0 <- ggplot2::ggplot_build(plot(oc)) + expect_identical(unique(b0$data[[3]]$linewidth), 1) + expect_identical(unique(b0$data[[4]]$size), 1.5) + expect_equal(unique(b0$data[[2]]$size), 0.8 * 11 / ggplot2::.pt) + expect_identical(plot_theme(plot(oc))[["legend.position"]], "bottom") + # The plot can be changed further with ggplot2 + p2 <- suppressMessages( + plot(oc) + ggplot2::scale_colour_manual( + values = c(Go = "gray10", NoGo = "gray40", Gray = "gray70") + ) + ) + lines2 <- ggplot2::ggplot_build(p2)$data[[3]] + expect_identical(unique(lines2$colour[lines2$group == 1]), "gray10") + # Invalid arguments + expect_error(plot(oc, col_go = "nocolor"), + "'col_go' must be a single color name", fixed = TRUE) + expect_error(plot(oc, col_miss = NA), + "'col_miss' must be a single color name", fixed = TRUE) + expect_error(plot(oc, linewidth = -1), "'linewidth' must be at least 0.", + fixed = TRUE) + expect_error(plot(oc, legend_position = "inside"), + "'legend_position' must be one of", fixed = TRUE) + # Unknown arguments are ignored with a warning + expect_warning(p3 <- plot(oc, col_Go = "red"), + "Ignoring unknown argument(s) of plot.qdm_oc(): col_Go.", + fixed = TRUE) + expect_s3_class(p3, "ggplot") +}) + +test_that("plot.qdm_oc() shades the heat maps with the decision colors", { + sc <- expand.grid(mu_t1 = c(-10, 10), mu_t2 = c(-1, 1, 3)) + sc$sd_t1 <- 30 + sc$sd_t2 <- 3 + sc$rho_t <- 0.5 + oc <- withCallingHandlers( + qdm_oc(ref_design_cont2("K4"), sc, nsim = 50L, seed = 1), + warning = function(w) { + if (grepl("Miss", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + } + ) + p <- plot(oc) + d <- plot_data(p) + cols <- c(Go = "#658D1B", NoGo = "#D91E49", Gray = "#939597", + Miss = "#E69F00") + expect_identical(d$fill, shade_color(d$prob, + cols[as.character(d$decision)])) + b <- ggplot2::ggplot_build(p) + expect_identical(sort(b$data[[1]]$fill), sort(d$fill)) + expect_equal(unique(b$data[[2]]$size), 0.8 * 11 / ggplot2::.pt) + # Other colors: with black, the shade of probability p is the gray level + # 255 (1 - p) + p2 <- plot(oc, col_go = "black", col_nogo = "darkgreen", col_gray = "gray", + col_miss = "red", label_size = 4, base_size = 9) + d2 <- plot_data(p2) + go <- d2$decision == "Go" + v <- as.integer(round(255 - 255 * d2$prob[go])) + expect_identical(d2$fill[go], sprintf("#%02X%02X%02X", v, v, v)) + expect_identical(unique(ggplot2::ggplot_build(p2)$data[[2]]$size), 4) + expect_identical(element_size(plot_theme(p2)[["text"]]), 9) +}) diff --git a/tests/testthat/test-plot_style.R b/tests/testthat/test-plot_style.R new file mode 100644 index 0000000..741bbd2 --- /dev/null +++ b/tests/testthat/test-plot_style.R @@ -0,0 +1,41 @@ +test_that("plot_style() returns the default style", { + s <- plot_style() + expect_identical(s$linewidth, 1) + expect_identical(s$point_size, 1.5) + expect_equal(s$label_size, 0.8 * 11 / ggplot2::.pt) + expect_identical(s$theme[["legend.position"]], "bottom") + expect_identical(element_size(s$theme[["text"]]), 11) +}) + +test_that("plot_style() takes the given values", { + s <- plot_style(linewidth = 0.5, point_size = 3, label_size = 4, + base_size = 16, legend_position = "none") + expect_identical(s$linewidth, 0.5) + expect_identical(s$point_size, 3) + expect_identical(s$label_size, 4) + expect_identical(s$theme[["legend.position"]], "none") + expect_identical(element_size(s$theme[["text"]]), 16) + # The default label size follows the base size + expect_equal(plot_style(base_size = 20)$label_size, 0.8 * 20 / ggplot2::.pt) + for (pos in c("top", "left", "right")) { + expect_identical(plot_style(legend_position = pos)$theme[[ + "legend.position"]], pos) + } +}) + +test_that("plot_style() rejects invalid values", { + expect_error(plot_style(linewidth = -1), "'linewidth' must be at least 0.", + fixed = TRUE) + expect_error(plot_style(point_size = "a"), "'point_size' must be numeric.", + fixed = TRUE) + expect_error(plot_style(label_size = c(1, 2)), + "'label_size' must have length 1.", fixed = TRUE) + expect_error(plot_style(base_size = 0), "'base_size' must be greater than 0.", + fixed = TRUE) + msg <- "'legend_position' must be one of" + expect_error(plot_style(legend_position = "inside"), msg, fixed = TRUE) + expect_error(plot_style(legend_position = c("top", "left")), msg, + fixed = TRUE) + expect_error(plot_style(legend_position = 1), msg, fixed = TRUE) + expect_error(plot_style(legend_position = NA_character_), msg, fixed = TRUE) +}) diff --git a/tests/testthat/test-posterior_binary.R b/tests/testthat/test-posterior_binary.R new file mode 100644 index 0000000..4633046 --- /dev/null +++ b/tests/testthat/test-posterior_binary.R @@ -0,0 +1,28 @@ +test_that("posterior_binary() adds the data to the prior", { + pr <- prior_beta(0.5, 1.5) + post <- posterior_binary(pr, 10, 0:10) + expect_equal(post$a, 0.5 + 0:10) + expect_equal(post$b, 1.5 + 10 - 0:10) +}) + +test_that("posterior_binary() weights external data by a0", { + pr <- prior_beta(1, 1) + ext <- borrow(data_binary(20, 8), 0.25) + post <- posterior_binary(pr, 12, 5, external = ext) + expect_equal(post$a, 1 + 0.25 * 8 + 5) + expect_equal(post$b, 1 + 0.25 * 12 + 7) + # a0 = 0 ignores the external data; a0 = 1 pools it + expect_equal(posterior_binary(pr, 12, 5, borrow(data_binary(20, 8), 0)), + posterior_binary(pr, 12, 5)) + expect_equal(posterior_binary(pr, 12, 5, borrow(data_binary(20, 8), 1)), + posterior_binary(pr, 32, 13)) +}) + +test_that("posterior_binary() adds hypothetical data", { + pr <- prior_beta(2, 3) + hyp <- hypothetical(data_binary(15, 6)) + post <- posterior_binary(pr, 0, 0, hypothetical = hyp) + expect_equal(post, list(a = 8, b = 12)) + post2 <- posterior_binary(pr, 0, 0, borrow(data_binary(10, 4), 0.5), hyp) + expect_equal(post2, list(a = 10, b = 15)) +}) diff --git a/tests/testthat/test-posterior_binary2.R b/tests/testthat/test-posterior_binary2.R new file mode 100644 index 0000000..5e3a00d --- /dev/null +++ b/tests/testthat/test-posterior_binary2.R @@ -0,0 +1,23 @@ +test_that("posterior_binary2() reproduces Yamaguchi et al. (submitted), S1.1.2", { + # Power priors of case study 3: Dir(1.65, 0.95, 0.95, 1.65) for the + # treatment group (a0t = 0.7, counts (2, 1, 1, 2)) and + # Dir(7.25, 1.25, 1.75, 0.75) for the control group (a0c = 0.5, counts + # (14, 2, 3, 1)), with Dir(0.25, 0.25, 0.25, 0.25) initial priors + des <- ref_design_bin2("B6") + expect_equal(posterior_binary2(des$prior_t, c(0, 0, 0, 0), des$external_t), + matrix(c(1.65, 0.95, 0.95, 1.65), 1L, + dimnames = list(NULL, c("00", "01", "10", "11")))) + expect_equal(posterior_binary2(des$prior_c, c(0, 0, 0, 0), + des$external_c)[1L, ], + c("00" = 7.25, "01" = 1.25, "10" = 1.75, "11" = 0.75)) +}) + +test_that("posterior_binary2() adds the counts row by row", { + q <- dir_q() + x <- rbind(c(1, 2, 3, 4), c(0, 0, 5, 0)) + expect_equal(unname(posterior_binary2(q, x)), x + 0.25) + hyp <- hypothetical(data_binary2(c(2, 1, 1, 0))) + expect_equal(unname(posterior_binary2(q, c(0, 0, 0, 0), + hypothetical = hyp)), + matrix(c(2.25, 1.25, 1.25, 0.25), 1L)) +}) diff --git a/tests/testthat/test-posterior_continuous.R b/tests/testthat/test-posterior_continuous.R new file mode 100644 index 0000000..e0c9bd2 --- /dev/null +++ b/tests/testthat/test-posterior_continuous.R @@ -0,0 +1,91 @@ +test_that("posterior_continuous() gives t(n - 1, ybar, s^2 / n) with the vague prior", { + post <- posterior_continuous(prior_vague(), 12, c(18, -3), c(25, 4)) + expect_equal(post$mu, c(18, -3)) + expect_equal(post$kappa, 12) + expect_equal(post$nu, 11) + expect_equal(post$sigma2, c(25, 4) ^ 2) +}) + +test_that("posterior_continuous() matches the closed forms of the NIX posterior", { + # Python_reference/ref_continuous_qdm.py, design C2: closed form with the + # prior mean, the external data and the current data as three weighted + # groups + pt <- posterior_continuous(prior_nix(5, 2, 4, 20), 10, 22, 24, + external = borrow(data_continuous(6, 20, 30), + 0.5)) + expect_equal(pt$mu, 19.3333333333, tolerance = 1e-10) + expect_equal(pt$kappa, 15) + expect_equal(pt$nu, 17) + expect_equal(sqrt(pt$sigma2), 23.6610045699, tolerance = 1e-10) + pc <- posterior_continuous(prior_nix(-5, 1, 3, 25), 8, -8, 18, + external = borrow(data_continuous(30, -12, 20), + 0.4)) + expect_equal(pc$mu, -10.1428571429, tolerance = 1e-10) + expect_equal(pc$kappa, 21) + expect_equal(pc$nu, 23) + expect_equal(sqrt(pc$sigma2), 19.6574705664, tolerance = 1e-10) + # Without data, the prior parameters are returned + p0 <- posterior_continuous(prior_nix(1, 2, 3, 4), 0) + expect_identical(p0, list(mu = 1, kappa = 2, nu = 3, sigma2 = 16)) +}) + +test_that("posterior_continuous() reproduces Huang et al. (submitted), Table 3", { + # Vague prior, power prior with weight a0 for 60 adult subjects and 30 + # pediatric subjects. Closed form of Huang et al., Section 6.2: + # kappa = 60 a0 + 30, nu = 60 a0 + 29, + # nu sigma^2 = a0 S_x + S_y + 60 a0 30 / (60 a0 + 30) (ybar - ybar_e)^2. + a0 <- c(0.25, 0.5, 0.75) + pub_mean_c <- c(2.70, 2.65, 2.62) + pub_sd_c <- c(0.640, 0.543, 0.480) + pub_mean_t <- c(-0.57, -0.60, -0.62) + pub_sd_t <- c(0.589, 0.504, 0.448) + for (i in seq_along(a0)) { + pc <- posterior_continuous(prior_vague(), 30, 2.8, 4.3, + external = borrow(data_continuous(60, 2.5, 4), + a0[i])) + pt <- posterior_continuous(prior_vague(), 30, -0.5, 3.9, + external = borrow(data_continuous(60, -0.7, + 3.8), + a0[i])) + k <- 60 * a0[i] + 30 + expect_equal(pc$kappa, k) + expect_equal(pc$nu, k - 1) + expect_equal(pc$mu, (60 * a0[i] * 2.5 + 30 * 2.8) / k) + expect_equal(pc$sigma2, (a0[i] * 59 * 4 ^ 2 + 29 * 4.3 ^ 2 + + 60 * a0[i] * 30 / k * (2.8 - 2.5) ^ 2) / + (k - 1)) + expect_equal(pt$sigma2, (a0[i] * 59 * 3.8 ^ 2 + 29 * 3.9 ^ 2 + + 60 * a0[i] * 30 / k * (-0.5 + 0.7) ^ 2) / + (k - 1)) + # Posterior means (2 decimals) and standard deviations (3 decimals) of + # the published table; the standard deviation of t(nu, mu, s^2) is + # s sqrt(nu / (nu - 2)). Two of the treatment standard deviations differ + # from the exact values (0.58846 and 0.44738) by up to 0.0006, slightly + # more than rounding; the article summarizes Monte Carlo samples of the + # posterior distributions (its Section 6.3). + post_sd <- function(p) sqrt(p$sigma2 / p$kappa * p$nu / (p$nu - 2)) + expect_equal(round(pc$mu, 2), pub_mean_c[i]) + expect_equal(round(pt$mu, 2), pub_mean_t[i]) + expect_equal(round(post_sd(pc), 3), pub_sd_c[i]) + expect_lt(abs(post_sd(pt) - pub_sd_t[i]), 0.001) + } +}) + +test_that("posterior_continuous() handles external data only and a0 = 0", { + ext <- borrow(data_continuous(30, -12, 20), 0.4) + # Huang et al., Section 6.1: NIX(ybar_e, a0 n_e, a0 n_e - 1, + # a0 (n_e - 1) s_e^2 / (a0 n_e - 1)) with the vague prior + p <- posterior_continuous(prior_vague(), 0, external = ext) + expect_equal(p$mu, -12) + expect_equal(p$kappa, 12) + expect_equal(p$nu, 11) + expect_equal(p$sigma2, 0.4 * 29 * 400 / 11) + # a0 = 0 ignores the external data, and a small a0 is close to it + none <- posterior_continuous(prior_vague(), 12, 3, 2) + expect_identical(posterior_continuous(prior_vague(), 12, 3, 2, + borrow(data_continuous(30, 9, 5), 0)), + none) + tiny <- posterior_continuous(prior_vague(), 12, 3, 2, + borrow(data_continuous(30, 9, 5), 1e-8)) + expect_equal(unlist(tiny), unlist(none), tolerance = 1e-6) +}) diff --git a/tests/testthat/test-posterior_continuous2.R b/tests/testthat/test-posterior_continuous2.R new file mode 100644 index 0000000..d46fb51 --- /dev/null +++ b/tests/testthat/test-posterior_continuous2.R @@ -0,0 +1,82 @@ +# Reference: Python_reference/ref_continuous2_qdm.py, section A (closed form +# with three weighted groups: prior mean, external data and current data; +# equal to the formulas of Yamaguchi et al., submitted, A.10 and A.2.5). +test_that("posterior_continuous2() matches the closed form", { + ref <- list( + K1 = list( + mu = c(18, 2.5), kappa = 12, nu = 11, + Lambda = c(39600, 1320, 275) + ), + K2 = list( + mu = c(4.98338870431894, 1.99667774086379), kappa = 30.1, nu = 34, + Lambda = c(192002.491694352, 5583.49833887043, 1080.09966777409) + ), + K3 = list( + mu = c(2.37257142857143, 1.00118633540373), kappa = 16.1, nu = 20, + Lambda = c(388.265193142857, 60.9925782857143, 139.503625440994) + ), + K4 = list( + mu = c(4, 1.5), kappa = 15, nu = 14, + Lambda = c(12600, 630, 126) + ), + K5 = list( + mu = c(2.97520661157025, 1), kappa = 12.1, nu = 16, + Lambda = c(68275.8925619835, 1830, 368.75) + ), + K6 = list( + mu = c(7, 2), kappa = 15, nu = 14, + Lambda = c(1400, -84, 56) + ) + ) + for (name in names(ref)) { + des <- ref_design_cont2(name) + d <- ref_data_cont2[[name]]$t + p <- posterior_continuous2(des$prior_t, d$n, d$mean, d$cov, + external = des$external_t) + e <- ref[[name]] + expect_equal(p$mu, matrix(e$mu, 1L), tolerance = 1e-12, info = name) + expect_equal(p$kappa, e$kappa, tolerance = 1e-12, info = name) + expect_equal(p$nu, e$nu, tolerance = 1e-12, info = name) + expect_equal(unname(p$Lambda), matrix(e$Lambda, 1L), tolerance = 1e-12, + info = name) + } +}) + +test_that("posterior_continuous2() updates many studies at once", { + des <- ref_design_cont2("K3") + d <- ref_data_cont2$K3$t + one <- posterior_continuous2(des$prior_t, d$n, d$mean, d$cov, + external = des$external_t) + cov3 <- c(d$cov[1L, 1L], d$cov[1L, 2L], d$cov[2L, 2L]) + many <- posterior_continuous2(des$prior_t, d$n, + rbind(d$mean, d$mean + c(1, -1)), + rbind(cov3, cov3 * 2), + external = des$external_t) + expect_identical(dim(many$mu), c(2L, 2L)) + expect_identical(colnames(many$Lambda), c("L11", "L12", "L22")) + expect_equal(many$mu[1L, ], one$mu[1L, ], tolerance = 1e-14) + expect_equal(many$Lambda[1L, ], one$Lambda[1L, ], tolerance = 1e-14) + other <- posterior_continuous2(des$prior_t, d$n, d$mean + c(1, -1), + 2 * d$cov, external = des$external_t) + expect_equal(many$Lambda[2L, ], other$Lambda[1L, ], tolerance = 1e-14) +}) + +test_that("posterior_continuous2() handles the vague prior and a0 = 0", { + # Vague prior: mu = ybar, kappa = n, nu = n - 1, Lambda = (n - 1) cov + cv <- cov2(3, 2, 0.5) + p <- posterior_continuous2(prior_vague(), 10, c(1, 2), cv) + expect_equal(p$mu, matrix(c(1, 2), 1L)) + expect_identical(c(p$kappa, p$nu), c(10, 9)) + expect_equal(unname(p$Lambda[1L, ]), 9 * c(9, 3, 4)) + # External data with a0 = 0 are ignored + q <- posterior_continuous2(prior_vague(), 10, c(1, 2), cv, + external = borrow(data_continuous2(5, c(0, 0), + cv), 0)) + expect_identical(q, p) + # No current data: the prior + pr <- prior_niw(c(1, -1), 2, 5, lambda_cs4) + r0 <- posterior_continuous2(pr, 0) + expect_equal(r0$mu, matrix(c(1, -1), 1L)) + expect_equal(unname(r0$Lambda[1L, ]), c(25, 1, 9)) + expect_identical(c(r0$kappa, r0$nu), c(2, 5)) +}) diff --git a/tests/testthat/test-posterior_tte.R b/tests/testthat/test-posterior_tte.R new file mode 100644 index 0000000..67269e5 --- /dev/null +++ b/tests/testthat/test-posterior_tte.R @@ -0,0 +1,10 @@ +test_that("posterior_tte() adds events and observed times to the prior", { + pr <- prior_gamma(0.1, 1) + expect_identical(posterior_tte(pr, 5, 40), list(shape = 5.1, rate = 41)) + expect_identical(posterior_tte(pr, c(0, 3), c(0, 10)), + list(shape = c(0.1, 3.1), rate = c(1, 11))) + # External data with a0 = 0.5, hypothetical data with full weight + post <- posterior_tte(pr, 6, 150, external = borrow(data_tte(4, 30), 0.5), + hypothetical = hypothetical(data_tte(8, 60))) + expect_equal(post, list(shape = 0.1 + 2 + 8 + 6, rate = 1 + 15 + 60 + 150)) +}) diff --git a/tests/testthat/test-ppred_fixed_binary.R b/tests/testthat/test-ppred_fixed_binary.R new file mode 100644 index 0000000..2a52a51 --- /dev/null +++ b/tests/testthat/test-ppred_fixed_binary.R @@ -0,0 +1,22 @@ +# Reference: Python_reference/ref_fixed_tte_qdm.py (rational arithmetic) +test_that("ppred_fixed_binary() does not count a future effect equal to q", { + # P(Y / 10 - 0.3 > 0) for Y ~ Beta-binomial(10, 4, 8) is P(Y >= 4) = 283/646; + # counting Y = 3 would give 0.632684652808 + p <- ppred_fixed_binary(0, 10, 4, 8, 0.3, lower.tail = FALSE) + expect_equal(p, 283 / 646, tolerance = 1e-12) + expect_equal(ppred_fixed_binary(0, 10, 4, 8, 0.3), 1 - 283 / 646, + tolerance = 1e-12) + # A tie produced with rounding errors (0.1 + 0.2 is not exactly 0.3) + expect_equal(ppred_fixed_binary(0.1, 10, 4, 8, 0.2, lower.tail = FALSE), + 283 / 646, tolerance = 1e-12) +}) + +test_that("ppred_fixed_binary() is vectorized over the Beta parameters", { + ref <- c(0.0350877192982, 0.125902992776, 0.267801857585) + y <- 0:2 + expect_equal(ppred_fixed_binary(0, 10, 1 + y, 11 - y, 0.3, + lower.tail = FALSE), ref, tolerance = 1e-10) + expect_equal(ppred_fixed_binary(-2, 10, c(1, 5), 3, 0.5, + lower.tail = FALSE), c(1, 1)) + expect_equal(ppred_fixed_binary(2, 10, c(1, 5), 3, 0.5), c(1, 1)) +}) diff --git a/tests/testthat/test-print.qdm_borrow.R b/tests/testthat/test-print.qdm_borrow.R new file mode 100644 index 0000000..0fd6a90 --- /dev/null +++ b/tests/testthat/test-print.qdm_borrow.R @@ -0,0 +1,7 @@ +test_that("print.qdm_borrow() prints the description and returns invisibly", { + b <- borrow(data_binary(20, 8), 0.5) + expect_output(res <- withVisible(print(b)), + "External data: binary, n = 20, y = 8, a0 = 0.5") + expect_false(res$visible) + expect_identical(res$value, b) +}) diff --git a/tests/testthat/test-print.qdm_boundary.R b/tests/testthat/test-print.qdm_boundary.R new file mode 100644 index 0000000..6b6d50b --- /dev/null +++ b/tests/testthat/test-print.qdm_boundary.R @@ -0,0 +1,28 @@ +test_that("print.qdm_boundary() prints the counts and the first rows", { + b <- qdm_boundary(ref_design("D8")) + counts <- table(b$decision) + header <- sprintf(paste("Decision boundary on a grid of 21 points", + "(Go: %d, NoGo: %d, Gray: %d, Miss: 0)"), + counts[["Go"]], counts[["NoGo"]], counts[["Gray"]]) + out <- capture.output(res <- withVisible(print(b))) + expect_identical(out[1L], header) + expect_match(out[2L], "n_t y_t") + expect_length(out, 1L + 7L + 1L) + expect_identical(out[9L], "... 15 more rows") + expect_false(res$visible) + expect_identical(res$value, b) +}) + +test_that("print.qdm_boundary() prints small grids in full", { + b <- qdm_boundary(ref_design_tte("T1"), events_t = 6, exposure_t = 150) + out <- capture.output(print(b)) + expect_identical(out[1L], paste("Decision boundary on a grid of 1 point", + "(Go: 1, NoGo: 0, Gray: 0, Miss: 0)")) + expect_length(out, 3L) + expect_false(any(grepl("more rows", out))) +}) + +test_that("print.qdm_boundary() counts a single remaining row", { + out <- capture.output(print(qdm_boundary(ref_design("D8"), n_t = 6))) + expect_identical(out[length(out)], "... 1 more row") +}) diff --git a/tests/testthat/test-print.qdm_calibration.R b/tests/testthat/test-print.qdm_calibration.R new file mode 100644 index 0000000..a3504df --- /dev/null +++ b/tests/testthat/test-print.qdm_calibration.R @@ -0,0 +1,20 @@ +test_that("print.qdm_calibration() prints the thresholds and the table", { + cal <- run_cal("D3") + out <- capture.output(res <- withVisible(print(cal))) + expect_false(res$visible) + expect_identical(res$value, cal) + expect_match(out[1], "^Calibration of the decision thresholds") + expect_identical(out[4], "Decision probabilities with the chosen thresholds") + expect_match(out[5], "scenario +pi_t +Go +NoGo +Gray +Miss") + expect_match(out[6], "^ +scenario_go ") +}) + +test_that("print.qdm_calibration() omits the table without thresholds", { + a <- cal_args$D1 + cal <- suppressWarnings( + qdm_calibrate(ref_design("D1"), a$scenario_go, a$scenario_nogo, + target_go = 1e-6, target_nogo = 0.2) + ) + out <- capture.output(print(cal)) + expect_length(out, 3L) +}) diff --git a/tests/testthat/test-print.qdm_conduct.R b/tests/testthat/test-print.qdm_conduct.R new file mode 100644 index 0000000..e6322af --- /dev/null +++ b/tests/testthat/test-print.qdm_conduct.R @@ -0,0 +1,5 @@ +test_that("print.qdm_conduct() prints the description", { + co <- conduct_tte(accrual_time = c(0, 12), cut_events = 20) + expect_output(res <- print(co), "Enrollment: uniform from 0 to 12") + expect_identical(res, co) +}) diff --git a/tests/testthat/test-print.qdm_criterion.R b/tests/testthat/test-print.qdm_criterion.R new file mode 100644 index 0000000..adf3a11 --- /dev/null +++ b/tests/testthat/test-print.qdm_criterion.R @@ -0,0 +1,7 @@ +test_that("print.qdm_criterion() prints each line and returns invisibly", { + cr <- criterion_posterior(0.2, 0.1, gamma_go = 0.5, gamma_nogo = 0.8) + expect_output(res <- withVisible(print(cr)), + "Posterior probability criterion\n Go:") + expect_false(res$visible) + expect_identical(res$value, cr) +}) diff --git a/tests/testthat/test-print.qdm_data.R b/tests/testthat/test-print.qdm_data.R new file mode 100644 index 0000000..8cb116c --- /dev/null +++ b/tests/testthat/test-print.qdm_data.R @@ -0,0 +1,6 @@ +test_that("print.qdm_data() prints the description and returns invisibly", { + d <- data_binary(12, 7) + expect_output(res <- withVisible(print(d)), "Data: binary, n = 12, y = 7") + expect_false(res$visible) + expect_identical(res$value, d) +}) diff --git a/tests/testthat/test-print.qdm_decision.R b/tests/testthat/test-print.qdm_decision.R new file mode 100644 index 0000000..2217630 --- /dev/null +++ b/tests/testthat/test-print.qdm_decision.R @@ -0,0 +1,7 @@ +test_that("print.qdm_decision() prints the decision and returns invisibly", { + res <- qdm_decide(ref_design("D3"), data_binary(12, 9)) + expect_output(out <- withVisible(print(res)), + "Decision: Go\n Go: P\\(theta > 0.2 \\| data\\)") + expect_false(out$visible) + expect_identical(out$value, res) +}) diff --git a/tests/testthat/test-print.qdm_design.R b/tests/testthat/test-print.qdm_design.R new file mode 100644 index 0000000..f0b4270 --- /dev/null +++ b/tests/testthat/test-print.qdm_design.R @@ -0,0 +1,7 @@ +test_that("print.qdm_design() prints the description and returns invisibly", { + des <- ref_design("D3") + expect_output(res <- withVisible(print(des)), + "Design: one binary endpoint\n Treatment: n = 12") + expect_false(res$visible) + expect_identical(res$value, des) +}) diff --git a/tests/testthat/test-print.qdm_hypothetical.R b/tests/testthat/test-print.qdm_hypothetical.R new file mode 100644 index 0000000..f3a1fd7 --- /dev/null +++ b/tests/testthat/test-print.qdm_hypothetical.R @@ -0,0 +1,7 @@ +test_that("print.qdm_hypothetical() prints the description invisibly", { + h <- hypothetical(mean = 1, r = 1) + expect_output(res <- withVisible(print(h)), + "Hypothetical control: mean = \\(1\\), r = 1") + expect_false(res$visible) + expect_identical(res$value, h) +}) diff --git a/tests/testthat/test-print.qdm_oc.R b/tests/testthat/test-print.qdm_oc.R new file mode 100644 index 0000000..c5b76d1 --- /dev/null +++ b/tests/testthat/test-print.qdm_oc.R @@ -0,0 +1,16 @@ +test_that("print.qdm_oc() prints the method and the table", { + oc <- qdm_oc(ref_design("D1"), scen_c[2:3, ]) + expect_output(res <- withVisible(print(oc)), + paste0("Operating characteristics \\(exact enumeration of ", + "the outcomes\\)\n pi_t pi_c")) + expect_false(res$visible) + expect_identical(res$value, oc) + expect_output(print(oc, digits = 2), "0.15") +}) + +test_that("print.qdm_oc() works after the attributes are dropped", { + oc <- qdm_oc(ref_design("D1"), scen_c) + attr(oc, "method") <- NULL + out <- capture.output(print(oc)) + expect_match(out[1], "pi_t") +}) diff --git a/tests/testthat/test-print.qdm_prior.R b/tests/testthat/test-print.qdm_prior.R new file mode 100644 index 0000000..f9b2405 --- /dev/null +++ b/tests/testthat/test-print.qdm_prior.R @@ -0,0 +1,6 @@ +test_that("print.qdm_prior() prints the description and returns invisibly", { + p <- prior_beta(1, 2) + expect_output(res <- withVisible(print(p)), "Prior: Beta\\(a = 1, b = 2\\)") + expect_false(res$visible) + expect_identical(res$value, p) +}) diff --git a/tests/testthat/test-prior_beta.R b/tests/testthat/test-prior_beta.R new file mode 100644 index 0000000..4ddd4a3 --- /dev/null +++ b/tests/testthat/test-prior_beta.R @@ -0,0 +1,18 @@ +test_that("prior_beta() stores the shape parameters", { + p <- prior_beta(0.5, 2) + expect_s3_class(p, c("qdm_prior_beta", "qdm_prior"), exact = TRUE) + expect_identical(p$a, 0.5) + expect_identical(p$b, 2) +}) + +test_that("prior_beta() rejects non-positive shapes", { + expect_error(prior_beta(0, 1), "'a' must be greater than 0.") + expect_error(prior_beta(1, -1), "'b' must be greater than 0.") + expect_error(prior_beta(c(1, 2), 1), "'a' must have length 1.") +}) + +test_that("prior_beta() rejects missing and non-numeric shapes", { + expect_error(prior_beta(NA_real_, 1), "'a' must not contain missing") + expect_error(prior_beta(1, "2"), "'b' must be numeric.") + expect_error(prior_beta(Inf, 1), "'a' must be finite.") +}) diff --git a/tests/testthat/test-prior_dirichlet.R b/tests/testthat/test-prior_dirichlet.R new file mode 100644 index 0000000..b549de3 --- /dev/null +++ b/tests/testthat/test-prior_dirichlet.R @@ -0,0 +1,17 @@ +test_that("prior_dirichlet() stores a named parameter vector", { + p <- prior_dirichlet(c(0.25, 0.5, 1, 2)) + expect_s3_class(p, c("qdm_prior_dirichlet", "qdm_prior"), exact = TRUE) + expect_identical(p$alpha, c("00" = 0.25, "01" = 0.5, "10" = 1, "11" = 2)) +}) + +test_that("prior_dirichlet() rejects invalid parameters", { + expect_error(prior_dirichlet(c(1, 1, 1)), "'alpha' must have length 4.") + expect_error(prior_dirichlet(c(1, 1, 1, 0)), + "'alpha' must be greater than 0.") +}) + +test_that("prior_dirichlet() ignores input names", { + p <- prior_dirichlet(c(w = 1, x = 2, y = 3, z = 4)) + expect_identical(names(p$alpha), c("00", "01", "10", "11")) + expect_error(prior_dirichlet(c(1, NA, 1, 1)), "'alpha' must not contain") +}) diff --git a/tests/testthat/test-prior_gamma.R b/tests/testthat/test-prior_gamma.R new file mode 100644 index 0000000..113c822 --- /dev/null +++ b/tests/testthat/test-prior_gamma.R @@ -0,0 +1,12 @@ +test_that("prior_gamma() stores the shape and rate", { + p <- prior_gamma(0.1, 2) + expect_s3_class(p, c("qdm_prior_gamma", "qdm_prior"), exact = TRUE) + expect_identical(p$shape, 0.1) + expect_identical(p$rate, 2) +}) + +test_that("prior_gamma() rejects invalid parameters", { + expect_error(prior_gamma(0, 1), "'shape' must be greater than 0.") + expect_error(prior_gamma(1, -1), "'rate' must be greater than 0.") + expect_error(prior_gamma(c(1, 2), 1), "'shape' must have length 1.") +}) diff --git a/tests/testthat/test-prior_niw.R b/tests/testthat/test-prior_niw.R new file mode 100644 index 0000000..52f6329 --- /dev/null +++ b/tests/testthat/test-prior_niw.R @@ -0,0 +1,27 @@ +test_that("prior_niw() stores the hyperparameters", { + L <- matrix(c(2, 0.5, 0.5, 1), 2) + p <- prior_niw(mu0 = c(1, 2), kappa0 = 1, nu0 = 4, Lambda0 = L) + expect_s3_class(p, c("qdm_prior_niw", "qdm_prior"), exact = TRUE) + expect_identical(p$mu0, c(1, 2)) + expect_identical(p$Lambda0, L) +}) + +test_that("prior_niw() rejects invalid hyperparameters", { + expect_error(prior_niw(1, 1, 4, diag(2)), "'mu0' must have length 2.") + expect_error(prior_niw(c(0, 0), 1, 1, diag(2)), + "'nu0' must be greater than 1.") + expect_error(prior_niw(c(0, 0), 1, 4, matrix(c(1, 2, 2, 1), 2)), + "'Lambda0' must be positive definite.") +}) + +test_that("prior_niw() checks every hyperparameter", { + expect_error(prior_niw(c(0, 0), 0, 4, diag(2)), + "'kappa0' must be greater than 0.") + expect_error(prior_niw(c(0, 0), 1, 4, matrix(c(1, 0.5, 0, 1), 2)), + "'Lambda0' must be symmetric.") + expect_error(prior_niw(c(0, 0), 1, 4, diag(3)), + "'Lambda0' must be a numeric 2 x 2 matrix.") + p <- prior_niw(c(0, 0), 1, 4, + matrix(c(1, 0, 0, 1), 2, dimnames = list(c("a", "b"), NULL))) + expect_null(dimnames(p$Lambda0)) +}) diff --git a/tests/testthat/test-prior_nix.R b/tests/testthat/test-prior_nix.R new file mode 100644 index 0000000..9fd8510 --- /dev/null +++ b/tests/testthat/test-prior_nix.R @@ -0,0 +1,19 @@ +test_that("prior_nix() stores the hyperparameters", { + p <- prior_nix(mu0 = 1, kappa0 = 2, nu0 = 3, sigma0 = 4) + expect_s3_class(p, c("qdm_prior_nix", "qdm_prior"), exact = TRUE) + expect_identical(unclass(p), + list(mu0 = 1, kappa0 = 2, nu0 = 3, sigma0 = 4)) +}) + +test_that("prior_nix() rejects invalid hyperparameters", { + expect_error(prior_nix(NA_real_, 1, 1, 1), + "'mu0' must not contain missing") + expect_error(prior_nix(0, 0, 1, 1), "'kappa0' must be greater than 0.") + expect_error(prior_nix(0, 1, 0, 1), "'nu0' must be greater than 0.") + expect_error(prior_nix(0, 1, 1, -2), "'sigma0' must be greater than 0.") +}) + +test_that("prior_nix() rejects vector hyperparameters", { + expect_error(prior_nix(c(0, 1), 1, 1, 1), "'mu0' must have length 1.") + expect_error(prior_nix(0, 1, c(1, 2), 1), "'nu0' must have length 1.") +}) diff --git a/tests/testthat/test-prior_vague.R b/tests/testthat/test-prior_vague.R new file mode 100644 index 0000000..86fe573 --- /dev/null +++ b/tests/testthat/test-prior_vague.R @@ -0,0 +1,5 @@ +test_that("prior_vague() creates a vague prior object", { + p <- prior_vague() + expect_s3_class(p, c("qdm_prior_vague", "qdm_prior"), exact = TRUE) + expect_length(p, 0L) +}) diff --git a/tests/testthat/test-psurv_fixed.R b/tests/testthat/test-psurv_fixed.R new file mode 100644 index 0000000..a8384dd --- /dev/null +++ b/tests/testthat/test-psurv_fixed.R @@ -0,0 +1,16 @@ +test_that("psurv_fixed() uses the Gamma distribution of the hazard", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design T1: + # P(S_t > 0.87) and P(S_t <= 0.72) for Gamma(6.1, 151) at t0 = 3 + expect_equal(psurv_fixed(0.87, 3, 6.1, 151, lower.tail = FALSE), + 0.686259165773, tolerance = 1e-10) + expect_equal(psurv_fixed(0.72, 3, 6.1, 151), 0.00106102273767, + tolerance = 1e-10) + expect_equal(psurv_fixed(0.5, 2, c(1, 2), c(3, 4), lower.tail = FALSE), + stats::pgamma(-log(0.5) / 2, c(1, 2), c(3, 4))) +}) + +test_that("psurv_fixed() handles values outside (0, 1)", { + expect_identical(psurv_fixed(c(-0.1, 0, 1, 1.2), 3, 2, 10, + lower.tail = FALSE), c(1, 1, 0, 0)) + expect_identical(psurv_fixed(c(-0.1, 0, 1, 1.2), 3, 2, 10), c(0, 0, 1, 1)) +}) diff --git a/tests/testthat/test-psurvdiff.R b/tests/testthat/test-psurvdiff.R new file mode 100644 index 0000000..c7e3c87 --- /dev/null +++ b/tests/testthat/test-psurvdiff.R @@ -0,0 +1,49 @@ +# References: Python_reference/ref_tte_psurvdiff.py (integration over the +# treatment hazard, independent of the integration over the control hazard +# in the package, and a Monte Carlo check of the reference itself). +ref_psurv <- data.frame( + q = c(0.1, -0.2, 0, 0.15, -0.05, 0.3, -0.6, 0.95, -0.95, 0, 0.05), + t0 = c(3, 3, 3, 12, 12, 6, 1, 1, 1, 2, 5), + a_t = c(5.1, 5.1, 0.5, 20.1, 20.1, 2, 0.3, 0.1, 50, 200, 1), + b_t = c(41, 41, 10, 300, 300, 30, 0.5, 1, 10, 400, 1), + a_c = c(3.1, 0.6, 0.8, 15.1, 15.1, 40, 0.2, 0.1, 0.1, 180, 1), + b_c = c(20, 8, 12, 160, 160, 200, 0.4, 1, 1, 400, 1), + p = c(0.385583382387744, 0.587302972430312, 0.608102285596848, + 0.407897841150297, 0.913904306893679, 0.703965564247968, + 0.869776929562393, 0.001098668828026, 0.237991538782146, + 0.152129549407913, 0.326187822705525) +) + +test_that("psurvdiff() matches the independent references", { + r <- ref_psurv + up <- psurvdiff(r$q, r$t0, r$a_t, r$b_t, r$a_c, r$b_c, lower.tail = FALSE) + expect_equal(up, r$p, tolerance = 1e-10) + low <- psurvdiff(r$q, r$t0, r$a_t, r$b_t, r$a_c, r$b_c) + expect_equal(low, 1 - r$p, tolerance = 1e-10) +}) + +test_that("psurvdiff() handles values outside (-1, 1) and recycles", { + expect_identical(psurvdiff(c(-1.5, -1, 1, 2), 3, 2, 10, 3, 12, + lower.tail = FALSE), c(1, 1, 0, 0)) + expect_identical(psurvdiff(c(-1.5, 1, 2), 3, 2, 10, 3, 12), c(0, 1, 1)) + expect_length(psurvdiff(0.1, c(1, 2, 3), 2, 10, 3, 12), 3L) + # Identical distributions: P(S_t - S_c > 0) = 0.5 + expect_equal(psurvdiff(0, 3, 4, 20, 4, 20), 0.5, tolerance = 1e-10) +}) + +test_that("psurvdiff() validates its arguments", { + expect_error(psurvdiff(0, 0, 1, 1, 1, 1), "'milestone' must be greater") + expect_error(psurvdiff(0, 1, -1, 1, 1, 1), "'shape_t' must be greater") + expect_error(psurvdiff(0, 1, 1, 1, 1, 1, lower.tail = NA), + "'lower.tail' must be TRUE or FALSE.") + expect_error(psurvdiff(c(0, 1), 1, c(1, 2, 3), 1, 1, 1), + "must have length 1 or 3.") +}) + +test_that("psurvdiff() handles long vectors", { + # 1000 values reach the check for user interrupts in the C++ loop + p1 <- psurvdiff(0.1, 3, 5.1, 41, 9.1, 36, lower.tail = FALSE) + p <- psurvdiff(rep(0.1, 1000L), 3, 5.1, 41, 9.1, 36, lower.tail = FALSE) + expect_length(p, 1000L) + expect_identical(p, rep(p1, 1000L)) +}) diff --git a/tests/testthat/test-ptdiff.R b/tests/testthat/test-ptdiff.R new file mode 100644 index 0000000..fbd9a4f --- /dev/null +++ b/tests/testthat/test-ptdiff.R @@ -0,0 +1,270 @@ +# Reference values: Python_reference/ref_distributions_mpmath.py (mpmath, 40 +# digits, two integral representations), cross-checked with scipy. +s1 <- sqrt(15.62 / 36) +s2 <- sqrt(13.28 / 31) +ref_ptdiff <- data.frame( + q = c(1, 0, 1, 2, 0.5, 0, -2, 1), + mu_t = c(3, 1, 5, 0, 0, -5.2, -5.2, 2), + scale_t = c(1, 1, 2, 1, 0.01, s1, s1, 1), + df_t = c(15, 5, 10, 3, 10, 35, 35, Inf), + mu_c = c(1, 1, 3, 0, 0, -2.7, -2.7, 0), + scale_c = c(1, 1, 1.5, 0.2, 1, s2, s2, 1.5), + df_c = c(15, 20, 15, 3, 4.5, 30, 30, Inf), + ni = c(0.7502661261453839, 0.5, 0.64781149700404485, 0.074147617800499862, + 0.3202865229079607, 0.0051019590255298554, 0.2989120884753876, + 0.71045012902304058), + mm = c(0.75034682914089527, 0.5, 0.64835811602628018, NA, + 0.32028123131924755, 0.0051031869369207273, 0.29890417235967946, + 0.71045012902304058) +) + +test_that("ptdiff() with NI matches high-precision references", { + r <- ref_ptdiff + for (i in seq_len(nrow(r))) { + expect_equal(ptdiff(r$q[i], r$mu_t[i], r$scale_t[i], r$df_t[i], + r$mu_c[i], r$scale_c[i], r$df_c[i], + lower.tail = FALSE), + r$ni[i], tolerance = 1e-9, info = paste("case", i)) + } +}) + +# Stress cases: Python_reference/ref_ptdiff_stress_mpmath.py (mpmath, 30 +# digits, integrals over the control and over the treatment variable, which +# agree). Locations mu_t = 0.3 and mu_c = -0.2; scale ratios from 1e-9 to +# 1e3 and degrees of freedom from 0.5 to Inf. The integration scheme used +# before the change of variables had absolute errors above 1e-9 in 15 of +# these cases (Python_reference/compare_ptdiff_stress.py). +stress_ptdiff <- data.frame( + case = c(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, + 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, + 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, + 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, + 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, + 70, 71), + q = c(-3, 0, 0.7, 5, 40, 10000, -3, 0, 0, 0.7, + 5, 40, 10000, -3, 0, 0.7, 0.7, 5, 40, 10000, + -3, 0, 0.7, 5, 5, 40, 10000, -3, 0, 0.7, + 5, 40, 40, 10000, -3, 0, 0.7, 5, 40, 10000, + 10000, -3, 0, 0.7, 5, 40, 10000, -3, -3, 0, + 0.7, 5, 40, 10000, -3, 0, 0, 0.7, 5, 40, + 10000, -3, 0, 0.7, 0.7, 5, 40, 10000, -3, 0, + 0.7, 5), + scale_t = c(1, 1, 1, 1, 1, 1, 1, 1, 0.001, 0.001, + 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 1, 1, 1, 1, + 1, 1, 1, 1, 50, 50, 50, 50, 50, 50, + 50, 50, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1e-06, 1e-06, + 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 2, 2, 2, 2, + 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, + 1, 1), + df_t = c(1, 2.5, Inf, 0.5, 3, 100, Inf, 0.5, 1, 2.5, + Inf, 0.5, 3, 100, Inf, 0.5, 1, 2.5, Inf, 0.5, + 3, 100, Inf, 0.5, 1, 2.5, Inf, 0.5, 3, 100, + Inf, 0.5, 1, 2.5, Inf, 0.5, 3, 100, Inf, 0.5, + 1, 2.5, Inf, 0.5, 3, 100, Inf, 0.5, 1, 2.5, + Inf, 0.5, 3, 100, Inf, 0.5, 1, 2.5, Inf, 0.5, + 3, 100, Inf, 0.5, 1, 2.5, Inf, 0.5, 3, 100, + Inf, 0.5), + scale_c = c(0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 1, 1, + 1, 1, 1, 1, 1, 1, 1000, 1000, 1000, 1000, + 1000, 1000, 1000, 1000, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + 0.02, 0.02, 1, 1, 1, 1, 1, 1, 1, 1, + 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1, 1, + 1, 1, 1, 1, 1, 1, 3, 3, 3, 3, + 3, 3, 3, 3, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09), + df_c = c(1, 30, 3, 0.5, Inf, 1, Inf, 50, 1, 30, + 3, 0.5, Inf, 1, Inf, 50, 1, 30, 3, 0.5, + Inf, 1, Inf, 50, 1, 30, 3, 0.5, Inf, 1, + Inf, 50, 1, 30, 3, 0.5, Inf, 1, Inf, 50, + 1, 30, 3, 0.5, Inf, 1, Inf, 50, 1, 30, + 3, 0.5, Inf, 1, Inf, 50, 1, 30, 3, 0.5, + Inf, 1, Inf, 50, 1, 30, 3, 0.5, Inf, 1, + Inf, 50), + upper = c(0.91133039170764425418, 0.67115093567010934752, + 0.42074040765924459801, 0.15394679082069016453, + 0.000017850414896238118547, 3.1832580572246072843e-8, + 0.99976736939376622699, 0.62134085990839123404, + 0.64745639548047548244, 0.42141527088928027295, + 0.010245208541066846977, 0.0524735833335331264, + 1.1028232722294309817e-21, 0.91141446074178731388, + 0.69146237325774192374, 0.422790303642966117, + 0.49993640162198838471, 0.49821966580044579444, + 0.48548671355610357016, 0.10389508478043332841, + 0.50139629304005562656, 0.50015915476742657095, + 0.49992021158434583382, 0.49825110004024779717, + 0.4714404483635505827, 0.24877584569437109426, + 8.8239094167393032372e-18, 0.51854475341116702796, + 0.50367544390155720288, 0.4984087287039126337, + 0.46414361027560233783, 0.32883148281684476407, + 0.016103204440453942834, 7.194296606551776707e-11, + 0.9709385519672941852, 0.55020871728690150942, + 0.44944380850956707758, 0.073394727911349497345, + 1.2196097806026371956e-171, 0.0032070899425161695899, + 0.000031832611973852153915, 0.9738272265198326242, + 0.69146246127374905511, 0.4471399630492135827, + 0.010245206172229073533, 8.063758991918860477e-9, + 8.3925074411958435885e-21712558, 0.82960734002820512989, + 0.91141438313524486913, 0.68963849755699125182, + 0.42713516462318657448, 0.15073157555078742611, + 1.7960747258925735792e-23, 0.000031832580141272224882, + 0.99976737092096294777, 0.69024244472609524235, + 0.53172551743055356951, 0.48037994515799900416, + 0.14540739116563212103, 0.14767836587184530183, + 8.8225891425226291726e-12, 0.74572201641115103476, + 0.5551465322334494115, 0.48676599817665109517, + 0.43716704187221225578, 0.014947029504366996746, + 1.7960814320930068024e-32, 0.0032071906965681227405, + 0.98025948119035860002, 0.6909132169382523281, + 0.420740290560896977, 0.15062658127776870293) +) + +test_that("ptdiff() with NI is accurate for extreme scales and tails", { + r <- stress_ptdiff + upper <- ptdiff(r$q, 0.3, r$scale_t, r$df_t, -0.2, r$scale_c, r$df_c, + lower.tail = FALSE) + lower <- ptdiff(r$q, 0.3, r$scale_t, r$df_t, -0.2, r$scale_c, r$df_c) + for (i in seq_len(nrow(r))) { + expect_lt(abs(upper[i] - r$upper[i]), 1e-9, + label = paste("upper tail error, stress case", r$case[i])) + expect_lt(abs(lower[i] - (1 - r$upper[i])), 1e-9, + label = paste("lower tail error, stress case", r$case[i])) + } +}) + +test_that("ptdiff() with MM matches the closed-form references", { + r <- ref_ptdiff[!is.na(ref_ptdiff$mm), ] + for (i in seq_len(nrow(r))) { + expect_equal(ptdiff(r$q[i], r$mu_t[i], r$scale_t[i], r$df_t[i], + r$mu_c[i], r$scale_c[i], r$df_c[i], method = "MM", + lower.tail = FALSE), + r$mm[i], tolerance = 1e-10, info = paste("case", i)) + } +}) + +test_that("ptdiff() reproduces the glaucoma example of Yamaguchi et al.", { + # Moment-matching paper, Section 5.2: P(Delta < 0) = 0.9949 and + # P(Delta <= -2) = 0.7011 + for (m in c("NI", "MM")) { + p0 <- ptdiff(0, -5.2, s1, 35, -2.7, s2, 30, method = m) + p2 <- ptdiff(-2, -5.2, s1, 35, -2.7, s2, 30, method = m) + expect_equal(round(p0, 4), 0.9949, info = m) + expect_equal(round(p2, 4), 0.7011, info = m) + } +}) + +test_that("ptdiff() lower tail is the complement of the upper tail", { + r <- ref_ptdiff + lower <- ptdiff(r$q, r$mu_t, r$scale_t, r$df_t, r$mu_c, r$scale_c, r$df_c) + expect_equal(lower, 1 - r$ni, tolerance = 1e-9) +}) + +test_that("ptdiff() with MC agrees with NI within Monte Carlo error", { + r <- ref_ptdiff[c(1, 3, 6), ] + set.seed(2026) + est <- ptdiff(r$q, r$mu_t, r$scale_t, r$df_t, r$mu_c, r$scale_c, r$df_c, + method = "MC", nMC = 1e5, lower.tail = FALSE) + se <- sqrt(r$ni * (1 - r$ni) / 1e5) + expect_true(all(abs(est - r$ni) < 4 * se)) +}) + +test_that("ptdiff() with MC is reproducible with a seed", { + set.seed(1) + a <- ptdiff(1, 3, 1, 15, 1, 1, 15, method = "MC", nMC = 1000) + set.seed(1) + b <- ptdiff(1, 3, 1, 15, 1, 1, 15, method = "MC", nMC = 1000) + expect_identical(a, b) +}) + +test_that("ptdiff() validates its arguments", { + expect_error(ptdiff(0, 0, 1, 3, 0, 1, 10, method = "MM"), + "requires 'df_t' and 'df_c' greater than 4") + expect_error(ptdiff(0, 0, 0, 3, 0, 1, 10), "'scale_t' must be greater") + expect_error(ptdiff(0, 0, 1, 3, 0, 1, 10, method = "MC", nMC = 0), + "'nMC' must be at least 1 and at most 2147483647.") + expect_error(ptdiff(0, 0, 1, 3, 0, 1, 10, method = "XX"), + "should be one of") +}) + +test_that("ptdiff() is exact for Cauchy variables (one degree of freedom)", { + # T_t - T_c is Cauchy with location mu_t - mu_c and scale s_t + s_c + grid <- expand.grid(q = c(-5, -1, 0, 0.3, 2, 20), + s = 1:3) + sc <- list(c(1, 1), c(0.2, 3), c(5, 0.5)) + for (k in seq_len(nrow(grid))) { + s <- sc[[grid$s[k]]] + exact <- stats::pcauchy(grid$q[k], 1.5 - 0.5, s[1] + s[2], + lower.tail = FALSE) + expect_equal(ptdiff(grid$q[k], 1.5, s[1], 1, 0.5, s[2], 1, + lower.tail = FALSE), + exact, tolerance = 1e-8, info = paste("case", k)) + } +}) + +test_that("ptdiff() is exact for normal variables (infinite df)", { + q <- c(-3, -0.5, 0, 0.7, 4) + exact <- stats::pnorm(q, 2 - 0.5, sqrt(1.2 ^ 2 + 0.8 ^ 2), + lower.tail = FALSE) + for (m in c("NI", "MM")) { + expect_equal(ptdiff(q, 2, 1.2, Inf, 0.5, 0.8, Inf, method = m, + lower.tail = FALSE), + exact, tolerance = 1e-9, info = m) + } + # Large degrees of freedom are close to the normal case + expect_equal(ptdiff(q, 2, 1.2, 1e7, 0.5, 0.8, 1e7, lower.tail = FALSE), + exact, tolerance = 1e-6) +}) + +test_that("ptdiff() with MM is close to NI for moderate degrees of freedom", { + # Accuracy of the moment-matching approximation (Yamaguchi et al.) + grid <- expand.grid(q = c(-2, 0, 1, 3), df_t = c(10, 30), df_c = c(12, 60), + scale_c = c(0.5, 1, 2)) + ni <- ptdiff(grid$q, 0.5, 1, grid$df_t, 0, grid$scale_c, grid$df_c) + mm <- ptdiff(grid$q, 0.5, 1, grid$df_t, 0, grid$scale_c, grid$df_c, + method = "MM") + expect_lt(max(abs(ni - mm)), 2e-3) +}) + +test_that("ptdiff() is a non-increasing function of q", { + q <- seq(-10, 10, length.out = 201) + p <- ptdiff(q, 1, 1, 3, 0, 2, 7, lower.tail = FALSE) + expect_true(all(diff(p) <= 1e-10)) + expect_true(all(p >= 0 & p <= 1)) +}) + +test_that("ptdiff() handles long vectors", { + q <- seq(-3, 3, length.out = 1200) + p <- ptdiff(q, 1, 1, 8, 0, 1.5, 12) + expect_length(p, 1200L) + expect_identical(p[c(1, 600, 1200)], + ptdiff(q[c(1, 600, 1200)], 1, 1, 8, 0, 1.5, 12)) +}) + +test_that("ptdiff() with MC uses the default nMC and both tails", { + set.seed(5) + up <- ptdiff(1, 3, 1, 15, 1, 1, 15, method = "MC", lower.tail = FALSE) + lo <- ptdiff(1, 3, 1, 15, 1, 1, 15, method = "MC") + ref <- 0.7502661261453839 + se <- sqrt(ref * (1 - ref) / 10000) + expect_lt(abs(up - ref), 4 * se) + expect_lt(abs(lo - (1 - ref)), 4 * se) +}) + +test_that("ptdiff() with MC agrees with NI for many draws", { + skip_on_cran() + set.seed(6) + ref <- ptdiff(c(-1, 0.5, 2), 1, 1, 6, 0, 1.5, 9, lower.tail = FALSE) + est <- ptdiff(c(-1, 0.5, 2), 1, 1, 6, 0, 1.5, 9, method = "MC", + nMC = 1e6, lower.tail = FALSE) + expect_true(all(abs(est - ref) < 4 * sqrt(ref * (1 - ref) / 1e6))) +}) + +test_that("ptdiff() checks the lengths of its arguments", { + expect_error(ptdiff(c(0, 1), c(0, 1, 2), 1, 5, 0, 1, 5), + "'q' must have length 1 or 3.") + expect_error(ptdiff(0, 0, 1, 0, 0, 1, 5), "'df_t' must be greater than 0.") + expect_error(ptdiff(0, 0, 1, 5, 0, 1, 5, lower.tail = "yes"), + "'lower.tail' must be TRUE or FALSE.") +}) diff --git a/tests/testthat/test-ptdiff_mm_upper.R b/tests/testthat/test-ptdiff_mm_upper.R new file mode 100644 index 0000000..8c67df0 --- /dev/null +++ b/tests/testthat/test-ptdiff_mm_upper.R @@ -0,0 +1,28 @@ +test_that("ptdiff_mm_upper() follows Proposition 1 of Yamaguchi et al.", { + # With equal scales s and degrees of freedom nu, nu* = 2 nu - 4 and + # scale* = s sqrt(2 nu (nu* - 2) / ((nu - 2) nu*)). + for (nu in c(5, 10, 30)) { + nu_star <- 2 * nu - 4 + scale_star <- sqrt(2 * nu * (nu_star - 2) / ((nu - 2) * nu_star)) + expect_equal(ptdiff_mm_upper(1.3, 0, 1, nu, 0, 1, nu), + stats::pt(1.3 / scale_star, nu_star, lower.tail = FALSE), + tolerance = 1e-12, info = paste("nu =", nu)) + } +}) + +test_that("ptdiff_mm_upper() reduces to the normal case for infinite df", { + expect_equal(ptdiff_mm_upper(1, 2, 1, Inf, 0, 1.5, Inf), + stats::pnorm(1, 2, sqrt(1 + 1.5 ^ 2), lower.tail = FALSE), + tolerance = 1e-12) +}) + +test_that("ptdiff_mm_upper() handles one infinite degree of freedom", { + # With df_t = Inf, nu* = 4 + (v_t + v_c)^2 (df_c - 4) / v_c^2 + v_t <- 1 + v_c <- 2 ^ 2 * 10 / 8 + nu_star <- 4 + (v_t + v_c) ^ 2 * (10 - 4) / v_c ^ 2 + scale_star <- sqrt((v_t + v_c) * (nu_star - 2) / nu_star) + expect_equal(ptdiff_mm_upper(0.5, 1, 1, Inf, 0, 2, 10), + stats::pt((0.5 - 1) / scale_star, nu_star, lower.tail = FALSE), + tolerance = 1e-12) +}) diff --git a/tests/testthat/test-qdm_boundary.R b/tests/testthat/test-qdm_boundary.R new file mode 100644 index 0000000..f45e160 --- /dev/null +++ b/tests/testthat/test-qdm_boundary.R @@ -0,0 +1,92 @@ +test_that("qdm_boundary() returns the decision at each point of the grid", { + des <- ref_design("D8") + b <- qdm_boundary(des) + expect_identical(class(b), c("qdm_boundary", "data.frame")) + expect_identical(names(b), c("n_t", "y_t", "prob_go", "prob_nogo", + "decision")) + expect_identical(b$n_t, rep(20L, 21L)) + expect_identical(levels(b$decision), c("Go", "NoGo", "Gray", "Miss")) + expected <- decision_label(meets_threshold(b$prob_go, 0.8), + meets_threshold(b$prob_nogo, 0.8)) + expect_identical(as.character(b$decision), expected) + expect_identical(as.character(b$decision[12L]), + qdm_decide(des, data_binary(20, 11))$decision) + expect_identical(attr(b, "design"), des) + expect_named(attr(b, "axes"), c("x", "y", "xlab", "ylab", "caption")) + expect_identical(rownames(b), as.character(seq_len(21L))) +}) + +test_that("qdm_boundary() shows a Miss decision", { + # Beta(2, 2) posterior for y = 1 of 2: P(p > 0.4) = 0.648 and + # P(p < 0.25) = 0.15625, so both criteria are met + des <- design_binary(2, 0, prior_beta(1, 1), + criterion = crit_post(0.6, 0.15, tv = 0.2, mav = 0.05), + fixed_c = 0.2) + b <- qdm_boundary(des) + expect_identical(as.character(b$decision), c("NoGo", "Miss", "Go")) +}) + +test_that("qdm_boundary() handles all supported endpoints", { + b <- qdm_boundary(ref_design_cont("C1"), mean_t = c(0, 30), sd_t = 25, + data_c = ref_data_cont$C1$c) + expect_identical(names(b), c("n_t", "mean_t", "sd_t", "diff", "prob_go", + "prob_nogo", "decision")) + dec <- qdm_decide(ref_design_cont("C1"), data_continuous(12, 30, 25), + ref_data_cont$C1$c) + expect_equal(b$prob_go[2L], dec$prob_go) + expect_identical(as.character(b$decision[2L]), dec$decision) + b2 <- qdm_boundary(ref_design_cont2("K5"), mean_t = list(3, 1), + cov_t = cov2(75, 5.5, 0.4)) + expect_identical(names(b2), c("n_t", "mean_t1", "mean_t2", "prob_go1", + "prob_go2", "prob_nogo1", "prob_nogo2", + "decision")) + dec2 <- qdm_decide(ref_design_cont2("K5"), ref_data_cont2$K5$t) + expect_equal(c(b2$prob_go1, b2$prob_go2), unname(dec2$prob_go)) + expect_identical(as.character(b2$decision), dec2$decision) + b_t <- qdm_boundary(ref_design_tte("T1"), n_t = 10, exposure_t = 100) + expect_equal(b_t$events_t, 0:10) + expect_identical(names(b_t), c("events_t", "exposure_t", "prob_go", + "prob_nogo", "decision")) + b3 <- qdm_boundary(ref_design_tte("T2"), events_t = 5, exposure_t = 40, + data_c = data_tte(9, 35)) + expect_equal(b3$prob_go, ref_prob_tte$T2[["go"]], tolerance = 1e-10) + expect_identical(as.character(b3$decision), + qdm_decide(ref_design_tte("T2"), data_tte(5, 40), + data_tte(9, 35))$decision) +}) + +test_that("qdm_boundary() restores the random number generator", { + des <- ref_design_cont("C1", method = "MC", nMC = 2000L) + run <- function(seed) { + qdm_boundary(des, mean_t = c(10, 30), sd_t = 25, + data_c = ref_data_cont$C1$c, seed = seed) + } + set.seed(1) + state <- .Random.seed + b1 <- run(5) + expect_identical(.Random.seed, state) + expect_identical(run(5), b1) + run(NULL) + expect_false(identical(.Random.seed, state)) + expect_error(run(1.5), "'seed' must contain whole numbers only.") +}) + +test_that("qdm_boundary() validates its arguments", { + expect_error(qdm_boundary("design"), + "'design' must be created by a design_\\*\\(\\) function") + expect_error(qdm_boundary(ref_design_bin2("B1")), + "qdm_boundary\\(\\) does not support two binary endpoints") + expect_error(qdm_boundary(ref_design("D8"), mean_t = 1), + "'mean_t' is not used for this endpoint.") + expect_error(qdm_boundary(ref_design("D8"), sd_t = 1, + data_c = data_binary(10, 2)), + "'sd_t', 'data_c' are not used for this endpoint.") + expect_error(qdm_boundary(ref_design_tte("T1"), exposure_t = 100, + cov_t = diag(2)), + "'cov_t' is not used for this endpoint.") + expect_error(qdm_boundary(ref_design_cont("C1"), mean_t = 1, sd_t = 1), + "'data_c' must be given for a design with a concurrent") + expect_error(qdm_boundary(ref_design_cont("C3"), mean_t = 1, sd_t = 1, + data_c = ref_data_cont$C1$c), + "'data_c' must be NULL for a design without a concurrent") +}) diff --git a/tests/testthat/test-qdm_calibrate.R b/tests/testthat/test-qdm_calibrate.R new file mode 100644 index 0000000..9a9d143 --- /dev/null +++ b/tests/testthat/test-qdm_calibrate.R @@ -0,0 +1,293 @@ +# The references ref_cal and the arguments cal_args are defined in +# helper-calibration.R. +test_that("qdm_calibrate() matches the exact references", { + for (name in names(ref_cal)) { + ref <- ref_cal[[name]] + expect_silent(cal <- run_cal(name)) + expect_s3_class(cal, "qdm_calibration", exact = TRUE) + expect_equal(cal$gamma_go, ref$gamma_go, info = name) + expect_equal(cal$gamma_nogo, ref$gamma_nogo, info = name) + expect_equal(cal$prob_go, ref$prob_go, tolerance = 1e-10, info = name) + expect_equal(cal$prob_nogo, ref$prob_nogo, tolerance = 1e-10, + info = name) + expect_equal(cal$curve$gamma, seq(0.01, 0.99, by = 0.01), info = name) + expect_equal(cal$curve$prob_go, ref$curve_go, tolerance = 1e-10, + info = name) + expect_equal(cal$curve$prob_nogo, ref$curve_nogo, tolerance = 1e-10, + info = name) + got <- cal$oc[, c("Go", "NoGo", "Gray", "Miss")] + expect_equal(got, ref$oc, tolerance = 1e-9, info = name) + expect_identical(cal$oc$scenario, c("scenario_go", "scenario_nogo")) + } +}) + +test_that("qdm_calibrate() chooses the smallest threshold that meets the target", { + cal <- run_cal("D1") + k <- match(cal$gamma_go, cal$curve$gamma) + expect_lte(cal$curve$prob_go[k], 0.05) + expect_gt(cal$curve$prob_go[k - 1L], 0.05) + k <- match(cal$gamma_nogo, cal$curve$gamma) + expect_lte(cal$curve$prob_nogo[k], 0.2) + expect_gt(cal$curve$prob_nogo[k - 1L], 0.2) + # The probabilities of meeting the criteria do not increase with gamma + expect_true(all(diff(cal$curve$prob_go) <= 1e-12)) + expect_true(all(diff(cal$curve$prob_nogo) <= 1e-12)) +}) + +test_that("qdm_calibrate() returns the design with the chosen thresholds", { + cal <- run_cal("D1") + des <- ref_design("D1") + expect_identical(cal$design$criterion$gamma_go, cal$gamma_go) + expect_identical(cal$design$criterion$gamma_nogo, cal$gamma_nogo) + cal$design$criterion$gamma_go <- des$criterion$gamma_go + cal$design$criterion$gamma_nogo <- des$criterion$gamma_nogo + expect_identical(cal$design, des) + # Its operating characteristics are those reported in 'oc' + cal <- run_cal("D5") + oc <- qdm_oc(cal$design, rbind(cal_args$D5$scenario_go, + cal_args$D5$scenario_nogo)) + expect_equal(oc$Go, cal$oc$Go, tolerance = 1e-12) + expect_equal(oc$NoGo, cal$oc$NoGo, tolerance = 1e-12) + expect_identical(cal$scenario_go, cal_args$D5$scenario_go) + expect_identical(cal$target_nogo, 0.2) + expect_identical(cal$method, "exact enumeration of the outcomes") +}) + +test_that("qdm_calibrate() accepts a custom grid", { + cal <- run_cal("D1", grid = c(0.9, 0.5, 0.7, 0.5, 0.3)) + expect_equal(cal$curve$gamma, c(0.3, 0.5, 0.7, 0.9)) + expect_identical(cal$gamma_go, 0.7) + expect_equal(cal$curve$prob_go, + ref_cal$D1$curve_go[c(30, 50, 70, 90)], tolerance = 1e-10) +}) + +test_that("qdm_calibrate() warns when no threshold meets a target", { + a <- cal_args$D1 + expect_warning( + cal <- qdm_calibrate(ref_design("D1"), a$scenario_go, a$scenario_nogo, + target_go = 1e-6, target_nogo = 0.2), + "No value in 'grid' gives a probability of meeting the Go criterion" + ) + expect_true(is.na(cal$gamma_go)) + expect_true(is.na(cal$prob_go)) + expect_null(cal$design) + expect_null(cal$oc) + expect_equal(cal$gamma_nogo, ref_cal$D1$gamma_nogo) + expect_warning( + cal <- qdm_calibrate(ref_design("D1"), a$scenario_go, a$scenario_nogo, + target_go = 0.5, target_nogo = 1e-6, + grid = c(0.1, 0.2)), + "No value in 'grid' gives a probability of meeting the NoGo criterion" + ) + expect_true(is.na(cal$gamma_nogo)) + expect_equal(cal$gamma_go, 0.2) +}) + +test_that("qdm_calibrate() warns when Miss decisions are possible", { + # Loose targets give small thresholds with gamma_go + gamma_nogo <= 1 + a <- cal_args$D5 + expect_warning( + cal <- qdm_calibrate(ref_design("D5"), a$scenario_go, a$scenario_nogo, + target_go = 0.9, target_nogo = 0.9), + "both met \\(Miss\\)" + ) + expect_lte(cal$gamma_go + cal$gamma_nogo, 1) + expect_true(any(cal$oc$Miss > 0)) +}) + +test_that("qdm_calibrate() validates its arguments", { + des <- ref_design("D1") + a <- cal_args$D1 + expect_error(qdm_calibrate(des, rbind(a$scenario_go, a$scenario_go), + a$scenario_nogo, 0.05, 0.2), + "'scenario_go' must have exactly one row.") + expect_error(qdm_calibrate(des, a$scenario_go, data.frame(pi_t = 0.7), + 0.05, 0.2), + "'scenario_nogo' must have the column\\(s\\) pi_t, pi_c.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0, 0.2), + "'target_go' must be greater than 0 and less than 1.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0.05, 1), + "'target_nogo' must be greater than 0 and less than 1.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0.05, 0.2, + grid = c(0, 0.5)), + "'grid' must be greater than 0 and less than 1.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0.05, 0.2, + nsim = -1), + "'nsim' must be at least 1 and at most 2147483647.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0.05, 0.2, + seed = "a"), + "'seed' must be numeric.") + expect_error(qdm_calibrate(des, a$scenario_go, a$scenario_nogo, 0.05, 0.2, + seed = 2^31), + "'seed' must be at least -2147483647 and at most 2147483647.") + expect_error(qdm_calibrate(NULL, a$scenario_go, a$scenario_nogo, 0.05, + 0.2), + "'design' must be created by") +}) + +test_that("qdm_calibrate() with a seed leaves the random number stream unchanged", { + set.seed(8) + before <- .Random.seed + cal <- run_cal("D3", seed = 1) + expect_identical(.Random.seed, before) + expect_equal(cal$gamma_go, ref_cal$D3$gamma_go) +}) + +test_that("qdm_calibrate() matches the exact curves of a continuous design", { + # Python_reference/ref_continuous_qdm.py, design C3 with method "MM": + # probabilities that the Go criterion is met under mu_t = 10 and that the + # NoGo criterion is met under mu_t = 20 (sd_t = 20), gamma = 0.1, ..., 0.9 + ex_go <- c(0.644148402974, 0.370239194278, 0.195251555187, + 0.0945586633576, 0.0416322583318, 0.0162867375315, + 0.00540389479526, 0.00136970089245, 0.000193194739424) + ex_nogo <- c(0.33847199557, 0.123049979982, 0.0436537914186, + 0.0147880630576, 0.00468738422972, 0.00134979585112, + 0.000335015391109, 6.40013474872e-05, 6.72233598684e-06) + nsim <- 20000 + grid <- seq(0.1, 0.9, by = 0.1) + sc_go <- data.frame(mu_t = 10, sd_t = 20) + sc_nogo <- data.frame(mu_t = 20, sd_t = 20) + cal <- qdm_calibrate(ref_design_cont("C3", "MM"), sc_go, sc_nogo, + target_go = 0.1, target_nogo = 0.05, grid = grid, + nsim = nsim, seed = 5) + tol <- function(p) 4.5 * sqrt(p * (1 - p) / nsim) + 0.002 + expect_true(all(abs(cal$curve$prob_go - ex_go) <= tol(ex_go))) + expect_true(all(abs(cal$curve$prob_nogo - ex_nogo) <= tol(ex_nogo))) + # The chosen thresholds are the smallest grid values whose simulated + # probabilities meet the targets + expect_equal(cal$gamma_go, + grid[which(cal$curve$prob_go <= 0.1 + 1e-12)[1]]) + expect_equal(cal$gamma_nogo, + grid[which(cal$curve$prob_nogo <= 0.05 + 1e-12)[1]]) + # The decision probabilities are those of qdm_oc() with the same seed + oc <- qdm_oc(cal$design, rbind(sc_go, sc_nogo), nsim = nsim, seed = 5) + expect_equal(cal$oc$Go, oc$Go) + expect_equal(cal$oc$NoGo, oc$NoGo) + expect_identical(cal$method, attr(oc, "method")) +}) + +test_that("qdm_calibrate() matches the exact curves for two binary endpoints", { + # Python_reference/ref_binary2_qdm.py, design B1 (predictive, exact): + # P(Go criterion met | scenario 1) and P(NoGo criterion met | scenario 2) + ex_go <- c(0.593520788365099, 0.389565893365665, 0.240549158867837, + 0.159374861945474, 0.0931251408088504, 0.0268240062260297, + 0.0174331839434175, 0.00107659720288955, 0) + ex_nogo <- c(0.6868067, 0.4085798, 0.2488433, 0.1210625, 0.0716579, + 0.0376649, 0.0119313, 0.0045342, 6.48e-05) + grid <- seq(0.1, 0.9, by = 0.1) + cal <- qdm_calibrate(ref_design_bin2("B1"), scen_bin2[1, ], scen_bin2[2, ], + target_go = 0.1, target_nogo = 0.05, grid = grid) + expect_equal(cal$curve$prob_go, ex_go, tolerance = 1e-9) + expect_equal(cal$curve$prob_nogo, ex_nogo, tolerance = 1e-9) + expect_equal(cal$gamma_go, 0.5) + expect_equal(cal$gamma_nogo, 0.6) + expect_equal(cal$design$criterion$gamma_go, 0.5) + expect_identical(cal$oc$Miss, c(0, 0)) +}) + +test_that("qdm_calibrate() uses one threshold for both endpoints with a marginal rule", { + des <- ref_design_bin2("B2") + grid <- seq(0.2, 0.8, by = 0.1) + cal <- qdm_calibrate(des, scen_bin2[1, ], scen_bin2[3, ], target_go = 0.1, + target_nogo = 0.1, grid = grid) + expect_identical(length(cal$design$criterion$gamma_go), 2L) + expect_equal(cal$design$criterion$gamma_go, rep(cal$gamma_go, 2)) + expect_equal(cal$design$criterion$gamma_nogo, rep(cal$gamma_nogo, 2)) + # The curve agrees with qdm_oc() for a design with the thresholds (g, g) + g <- 0.4 + des_g <- des + des_g$criterion$gamma_go <- c(g, g) + oc <- suppressWarnings(qdm_oc(des_g, scen_bin2[1, ])) + expect_equal(oc$Go + oc$Miss, cal$curve$prob_go[abs(grid - g) < 1e-9], + tolerance = 1e-12) + expect_true(all(diff(cal$curve$prob_go) <= 1e-12)) +}) + +test_that("qdm_calibrate() requires feasible scenarios for two binary endpoints", { + bad <- data.frame(pi_t1 = 0.35, pi_t2 = 0.15, rho_t = 0.6, pi_c1 = 0.2, + pi_c2 = 0.15, rho_c = 0.6) + expect_error(qdm_calibrate(ref_design_bin2("B1"), bad, scen_bin2[2, ], + 0.1, 0.1), + "'scenario_go\\$rho_t' is outside the feasible range") +}) + +test_that("qdm_calibrate() matches the reference curves of design K1", { + # Python_reference/ref_continuous2_qdm.py, section D2 (simulation of 1e5 + # studies per scenario) + grid <- seq(0.05, 0.95, by = 0.05) + ref_go <- c(0.56469, 0.38736, 0.27739, 0.20361, 0.15047, 0.11072, 0.08202, + 0.05972, 0.04304, 0.03054, 0.02119, 0.01411, 0.0089, 0.00552, + 0.00307, 0.00146, 0.00058, 0.00019, 0) + ref_nogo <- c(0.7759, 0.63428, 0.52364, 0.43519, 0.36244, 0.30263, 0.25039, + 0.20524, 0.16722, 0.1336, 0.10499, 0.08139, 0.06218, 0.0451, + 0.031, 0.01991, 0.0115, 0.00557, 0.00147) + sc <- scen_cont2("K1") + # gamma_go + gamma_nogo < 1, so Miss decisions are possible + cal <- withCallingHandlers( + qdm_calibrate(ref_design_cont2("K1"), sc[1, ], sc[3, ], target_go = 0.05, + target_nogo = 0.2, grid = grid, nsim = 2000L, seed = 7), + warning = function(w) { + if (grepl("Miss", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + } + ) + tol <- function(ref) 4.5 * sqrt(ref * (1 - ref) * (1 / 2000 + 1 / 1e5)) + + 0.002 + expect_true(all(abs(cal$curve$prob_go - ref_go) <= tol(ref_go))) + expect_true(all(abs(cal$curve$prob_nogo - ref_nogo) <= tol(ref_nogo))) + # The chosen thresholds meet the targets on the grid + expect_lte(cal$prob_go, 0.05 + 1e-12) + expect_lte(cal$prob_nogo, 0.2 + 1e-12) + expect_s3_class(cal$design, "qdm_design_continuous2") +}) + +test_that("qdm_calibrate() handles a fixed control", { + # Probability that the Go criterion of design D8 is met under pi_t = 0.2 + # and that the NoGo criterion is met under pi_t = 0.6, from the Beta + # posterior probabilities and binomial weights of all outcomes; at + # gamma = 0.8 they are the exact references of + # Python_reference/ref_fixed_tte_qdm.py + grid <- seq(0.05, 0.95, by = 0.05) + cal <- qdm_calibrate(ref_design("D8"), data.frame(pi_t = 0.2), + data.frame(pi_t = 0.6), target_go = 0.05, + target_nogo = 0.01, grid = grid) + y <- 0:20 + p_go <- stats::pbeta(0.4, 1 + y, 21 - y, lower.tail = FALSE) + p_nogo <- stats::pbeta(0.25, 1 + y, 21 - y) + curve_go <- vapply(grid, function(g) { + sum(stats::dbinom(y, 20, 0.2)[meets_threshold(p_go, g)]) + }, numeric(1)) + curve_nogo <- vapply(grid, function(g) { + sum(stats::dbinom(y, 20, 0.6)[meets_threshold(p_nogo, g)]) + }, numeric(1)) + expect_equal(cal$curve$prob_go, curve_go, tolerance = 1e-12) + expect_equal(cal$curve$prob_nogo, curve_nogo, tolerance = 1e-12) + k <- which(abs(grid - 0.8) < 1e-12) + expect_equal(cal$curve$prob_go[k], 0.00259482740067, tolerance = 1e-9) + expect_equal(cal$curve$prob_nogo[k], 4.7344970692e-05, tolerance = 1e-9) + expect_equal(cal$gamma_go, grid[which(curve_go <= 0.05 + 1e-12)[1]]) + expect_equal(cal$gamma_nogo, grid[which(curve_nogo <= 0.01 + 1e-12)[1]]) + expect_identical(cal$design$fixed_c, 0.2) +}) + +test_that("qdm_calibrate() simulates time-to-event designs", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design T1 (Go + # criterion with gamma = 0.6 under a median of 12, NoGo criterion with + # gamma = 0.8 under a median of 9) + nsim <- 20000L + sc_go <- data.frame(median_t = 12) + sc_nogo <- data.frame(median_t = 9) + cal <- qdm_calibrate(ref_design_tte("T1"), sc_go, sc_nogo, + target_go = 0.1, target_nogo = 0.01, + grid = c(0.6, 0.8), nsim = nsim, seed = 9) + tol <- function(p) 4.5 * sqrt(p * (1 - p) / nsim) + 0.002 + expect_lte(abs(cal$curve$prob_go[1L] - 0.0642164668685), + tol(0.0642164668685)) + expect_lte(abs(cal$curve$prob_nogo[2L] - 0.00511165154121), + tol(0.00511165154121)) + oc <- qdm_oc(cal$design, rbind(sc_go, sc_nogo), nsim = nsim, seed = 9) + expect_equal(cal$oc$Go, oc$Go) + expect_equal(cal$oc$NoGo, oc$NoGo) + expect_identical(cal$method, attr(oc, "method")) +}) diff --git a/tests/testthat/test-qdm_decide.R b/tests/testthat/test-qdm_decide.R new file mode 100644 index 0000000..b0c7f8c --- /dev/null +++ b/tests/testthat/test-qdm_decide.R @@ -0,0 +1,310 @@ +# Exact references: Python_reference/ref_binary_qdm.py (rational arithmetic). +# In design D7 the probability of the Go region equals the threshold 0.5 +# exactly (a tie), which meets the Go criterion. +ref_decide <- data.frame( + design = c("D1", "D1", "D1", "D2", "D3", + "D4", "D5", "D5", "D6", "D7"), + n_t = c(12, 12, 12, 10, 12, 12, 10, 10, 8, 6), + y_t = c(9, 6, 3, 7, 9, 7, 8, 4, 1, 3), + n_c = c(12, 12, 12, 8, NA, NA, 10, 10, 8, 6), + y_c = c(4, 5, 6, 2, NA, NA, 3, 4, 0, 3), + a_t = c(10, 7, 4, 11, 10, 8, 9, 5, 2, 4), + b_t = c(4, 7, 10, 6, 4, 6, 3, 7, 8, 4), + a_c = c(5, 6, 7, 8, 5, 4, 4, 5, 1, 4), + b_c = c(9, 8, 7, 15, 9, 8, 8, 7, 9, 4), + prob_go = c(0.8207320756665553, 0.24509783589486162, 0.010407141009605608, + 0.7502162840687308, 0.8207320756665553, 0.5924430094360085, + 0.9402635338185402, 0.40597304686911645, 0.23621980701275141, + 0.5), + prob_nogo = c(0.07292664584103187, 0.5578589165230211, 0.9606462168290966, + 0.09572468725900227, 0.07292664584103187, 0.22499768661993003, + 0.059736466181459745, 0.5940269531308836, 0.5205968501563143, + 0.34098075320453497), + decision = c("Go", "Gray", "NoGo", "Go", "Go", + "Go", "Go", "Gray", "Miss", "Go") +) + +test_that("qdm_decide() matches the exact references", { + r <- ref_decide + for (i in seq_len(nrow(r))) { + des <- ref_design(r$design[i]) + data_c <- if (is.na(r$n_c[i])) NULL else data_binary(r$n_c[i], r$y_c[i]) + res <- qdm_decide(des, data_binary(r$n_t[i], r$y_t[i]), data_c) + info <- paste("case", i) + expect_equal(res$posterior_t, c(a = r$a_t[i], b = r$b_t[i]), info = info) + expect_equal(res$posterior_c, c(a = r$a_c[i], b = r$b_c[i]), info = info) + expect_equal(res$prob_go, r$prob_go[i], tolerance = 1e-10, info = info) + expect_equal(res$prob_nogo, r$prob_nogo[i], tolerance = 1e-10, + info = info) + expect_identical(res$decision, r$decision[i], info = info) + } +}) + +test_that("qdm_decide() matches high-precision references with Jeffreys priors", { + # Python_reference/ref_distributions_mpmath.py: Beta(7.5, 5.5) versus + # Beta(4.5, 8.5), the posteriors for 7/12 versus 4/12 responders + jeff <- prior_beta(0.5, 0.5) + d_post <- design_binary(12, 12, jeff, jeff, crit_post(tv = 0.2, mav = 0)) + res <- qdm_decide(d_post, data_binary(12, 7), data_binary(12, 4)) + expect_equal(res$prob_go, 0.57601763350543618, tolerance = 1e-10) + expect_identical(res$decision, "Go") + d_pred <- design_binary(12, 12, jeff, jeff, + criterion_predictive(0.05, m_t = 20, + gamma_go = 0.7, + gamma_nogo = 0.5)) + res <- qdm_decide(d_pred, data_binary(12, 7), data_binary(12, 4)) + expect_equal(res$prob_go, 0.74700508465629342, tolerance = 1e-12) + expect_equal(res$prob_nogo, 1 - 0.74700508465629342, tolerance = 1e-12) + expect_identical(res$decision, "Go") +}) + +test_that("qdm_decide() uses the sample sizes of the observed data", { + des <- ref_design("D1") + res <- qdm_decide(des, data_binary(20, 15), data_binary(5, 1)) + expect_equal(res$posterior_t, c(a = 16, b = 6)) + expect_equal(res$posterior_c, c(a = 2, b = 5)) + expect_equal(res$prob_go, pbetadiff(0.2, 16, 6, 2, 5, lower.tail = FALSE)) +}) + +test_that("qdm_decide() returns the inputs and the criteria met", { + des <- ref_design("D6") + d_t <- data_binary(8, 1) + d_c <- data_binary(8, 0) + res <- qdm_decide(des, d_t, d_c) + expect_s3_class(res, "qdm_decision", exact = TRUE) + expect_identical(res$decision, "Miss") + expect_true(res$met_go) + expect_true(res$met_nogo) + expect_identical(res$design, des) + expect_identical(res$data_t, d_t) + expect_identical(res$data_c, d_c) + res_u <- qdm_decide(ref_design("D3"), data_binary(12, 2)) + expect_null(res_u$data_c) + expect_identical(res_u$decision, "NoGo") +}) + +test_that("qdm_decide() validates the data", { + des <- ref_design("D1") + expect_error(qdm_decide(des, list(n = 12, y = 3), data_binary(12, 3)), + "'data_t' must be created by data_binary().") + expect_error(qdm_decide(des, data_binary(12, 3)), + "'data_c' must be created by data_binary\\(\\) for a design") + expect_error(qdm_decide(des, data_binary(12, 3), + data_continuous(12, 1, 1)), + "'data_c' must be created by data_binary\\(\\) for a design") + expect_error(qdm_decide(ref_design("D3"), data_binary(12, 3), + data_binary(12, 3)), + "'data_c' must be NULL for a design without a concurrent") + expect_error(qdm_decide("design", data_binary(12, 3)), + "'design' must be created by a design_\\*\\(\\) function") +}) + +# Continuous endpoint. References: Python_reference/ref_continuous_qdm.py +# (closed-form posterior parameters, two numerical integrations and the +# moment-matching formula); designs and data in +# helper-designs-continuous.R. +ref_decide_cont <- data.frame( + design = c("C1", "C2", "C3", "C4", "C5", "C6"), + mu_t = c(18, 19.3333333333, 25, 18.4615384615, 18, 9), + kappa_t = c(12, 15, 12, 13, 12, 15), + nu_t = c(11, 17, 11, 14, 11, 14), + sigma_t = c(25, 23.6610045699, 20, 22.2698238643, 25, 12), + mu_c = c(-12, -10.1428571429, -10, -12, -12, 0), + kappa_c = c(12, 21, 12, 12, 12, 15), + nu_c = c(11, 23, 11, 11, 11, 14), + sigma_c = c(25, 19.6574705664, 24.4948974278, 20.5382127221, 25, + 16.9705627485), + go_ni = c(0.5, 0.472868606954, 0.697142834497, 0.520435789904, + 0.938493080615, 0.7096513743), + nogo_ni = c(0.0878402872647, 0.0337620028253, 0.0248900866027, + 0.048372965683, 0.0615069193852, 0.2903486257), + go_mm = c(0.5, 0.472839814489, 0.697418373575, 0.520460570391, + 0.938485309768, 0.709872074443), + nogo_mm = c(0.0877885562533, 0.033819052643, 0.0249788420729, + 0.0484064726881, 0.0615146902318, 0.290127925557), + decision = c("Gray", "Gray", "Go", "Gray", "Go", "Go") +) + +test_that("qdm_decide() matches the references for continuous designs", { + r <- ref_decide_cont + for (i in seq_len(nrow(r))) { + d <- ref_data_cont[[r$design[i]]] + for (method in c("NI", "MM")) { + res <- qdm_decide(ref_design_cont(r$design[i], method), d$t, d$c) + info <- paste(r$design[i], method) + expect_equal(res$posterior_t, + c(mu = r$mu_t[i], kappa = r$kappa_t[i], nu = r$nu_t[i], + sigma = r$sigma_t[i]), tolerance = 1e-10, info = info) + expect_equal(res$posterior_c, + c(mu = r$mu_c[i], kappa = r$kappa_c[i], nu = r$nu_c[i], + sigma = r$sigma_c[i]), tolerance = 1e-10, info = info) + go <- if (method == "NI") r$go_ni[i] else r$go_mm[i] + nogo <- if (method == "NI") r$nogo_ni[i] else r$nogo_mm[i] + expect_equal(res$prob_go, go, tolerance = 1e-9, info = info) + expect_equal(res$prob_nogo, nogo, tolerance = 1e-9, info = info) + expect_identical(res$decision, r$decision[i], info = info) + } + } +}) + +test_that("qdm_decide() reproduces Yamaguchi et al. (submitted), Section 5.2", { + # Glaucoma example: P(Delta < 0 | data) = 0.9949 and + # P(Delta <= -2 | data) = 0.7011 (four decimals) with vague priors + des <- design_continuous(36, 31, prior_vague(), prior_vague(), + criterion_posterior(theta_tv = 0, theta_mav = -2, + gamma_go = 0.5, + gamma_nogo = 0.5)) + d_t <- data_continuous(36, -5.2, sqrt(15.62)) + d_c <- data_continuous(31, -2.7, sqrt(13.28)) + ni <- qdm_decide(des, d_t, d_c) + expect_equal(ni$prob_go, 0.00510195902552982, tolerance = 1e-9) + expect_equal(ni$prob_nogo, 0.701087911524607, tolerance = 1e-9) + des_mm <- design_continuous(36, 31, prior_vague(), prior_vague(), + des$criterion, method = "MM") + mm <- qdm_decide(des_mm, d_t, d_c) + expect_equal(mm$prob_go, 0.00510318693692072, tolerance = 1e-9) + expect_equal(mm$prob_nogo, 0.701095827640321, tolerance = 1e-9) + for (res in list(ni, mm)) { + expect_equal(round(1 - res$prob_go, 4), 0.9949) + expect_equal(round(res$prob_nogo, 4), 0.7011) + } +}) + +test_that("qdm_decide() reproduces Huang et al. (submitted), Table 3", { + # P(delta < -2 | data) = 0.928, 0.954 and 0.970 for a0 = 0.25, 0.5, 0.75 + # (vague priors, power priors with equal weights for both groups) + pub <- c(0.928, 0.954, 0.970) + a0 <- c(0.25, 0.5, 0.75) + for (i in seq_along(a0)) { + des <- design_continuous( + 30, 30, prior_vague(), prior_vague(), + criterion_posterior(theta_tv = 0, theta_mav = -2, gamma_go = 0.5, + gamma_nogo = 0.95), + external_t = borrow(data_continuous(60, -0.7, 3.8), a0[i]), + external_c = borrow(data_continuous(60, 2.5, 4), a0[i]) + ) + res <- qdm_decide(des, data_continuous(30, -0.5, 3.9), + data_continuous(30, 2.8, 4.3)) + expect_equal(round(res$prob_nogo, 3), pub[i], info = paste("a0", a0[i])) + } +}) + +test_that("qdm_decide() uses the seed for Monte Carlo probabilities", { + des <- ref_design_cont("C5", method = "MC", nMC = 20000L) + d <- ref_data_cont$C5 + set.seed(99) + before <- runif(1) + set.seed(99) + r1 <- qdm_decide(des, d$t, d$c, seed = 1) + expect_identical(runif(1), before) + r2 <- qdm_decide(des, d$t, d$c, seed = 1) + expect_identical(r1$prob_go, r2$prob_go) + expect_equal(r1$prob_go + r1$prob_nogo, 1, tolerance = 1e-14) + expect_lt(abs(r1$prob_go - 0.938493080615), + 4.5 * sqrt(0.9385 * 0.0615 / 20000)) + expect_identical(r1$decision, "Go") + expect_error(qdm_decide(des, d$t, d$c, seed = "a"), + "'seed' must be numeric.") + expect_error(qdm_decide(des, d$t, d$c, seed = -3e9), + "'seed' must be at least -2147483647 and at most 2147483647.") +}) + +test_that("qdm_decide() decides for two binary endpoints", { + # Predictive probabilities (exact): Python_reference/ref_binary2_qdm.py, + # case A1. With gamma_go = 0.4 and gamma_nogo = 0.3 (design B1) only the + # Go criterion is met. + d_t <- data_binary2(c(2, 1, 3, 4)) + d_c <- data_binary2(c(4, 2, 3, 1)) + res <- qdm_decide(ref_design_bin2("B1"), d_t, d_c) + expect_identical(res$decision, "Go") + expect_true(res$met_go) + expect_false(res$met_nogo) + expect_length(res$prob_regions, 4L) + # Marginal rule "and" (design B2): Go needs 0.643 >= 0.6 and 0.647 >= 0.5 + res2 <- qdm_decide(ref_design_bin2("B2"), d_t, d_c) + expect_identical(res2$decision, "Go") + # Posterior probabilities by Monte Carlo simulation with a seed + des <- ref_design_bin2("B5", nMC = 50000L) + set.seed(5) + before <- runif(1) + set.seed(5) + r1 <- qdm_decide(des, d_t, d_c, seed = 3) + expect_identical(runif(1), before) + r2 <- qdm_decide(des, d_t, d_c, seed = 3) + expect_identical(r1$prob_regions, r2$prob_regions) + expect_equal(sum(r1$prob_regions), 1, tolerance = 1e-12) + expect_identical(r1$prob_go, r1$prob_regions[["R1"]]) + expect_identical(r1$prob_nogo, r1$prob_regions[["R9"]]) + expect_lt(abs(r1$prob_go - 0.430209), 4.5 * sqrt(0.43 * 0.57 / 50000)) + expect_identical(r1$decision, "Go") +}) + +test_that("qdm_decide() decides for two continuous endpoints", { + # Moment matching: Python_reference/ref_continuous2_qdm.py, design K3 + # (predictive criterion), P(R1) = 0.626 and P(R4) = 0.0609 + d <- ref_data_cont2$K3 + res <- qdm_decide(ref_design_cont2("K3"), d$t, d$c) + expect_identical(res$decision, "Go") + expect_equal(res$prob_go, 0.626051840857435, tolerance = 1e-9) + expect_equal(res$prob_nogo, 0.060905364287987, tolerance = 1e-9) + expect_length(res$prob_regions, 4L) + # Monte Carlo probabilities depend on the seed only + des <- ref_design_cont2("K3", "MC", 4000L) + a <- qdm_decide(des, d$t, d$c, seed = 21) + b <- qdm_decide(des, d$t, d$c, seed = 21) + expect_identical(a$prob_regions, b$prob_regions) + expect_lt(abs(a$prob_go - 0.626051840857435), 0.04) +}) + +test_that("qdm_decide() decides with a fixed control for every endpoint", { + # References: Python_reference/ref_fixed_tte_qdm.py + res <- qdm_decide(ref_design("D8"), data_binary(20, 11)) + expect_identical(res$decision, "Go") + expect_equal(res$prob_go, 0.915075681321, tolerance = 1e-10) + expect_null(res$data_c) + res <- qdm_decide(ref_design("D9"), data_binary(10, 3)) + expect_identical(res$decision, "Gray") + expect_equal(res$prob_go, 283 / 646, tolerance = 1e-12) + res <- qdm_decide(ref_design_cont("C7"), ref_data_cont$C7$t) + expect_identical(res$decision, "Go") + expect_equal(res$prob_go, 0.797515237746, tolerance = 1e-10) + res <- qdm_decide(ref_design_cont("C8"), ref_data_cont$C8$t) + expect_identical(res$decision, "Go") + expect_equal(res$prob_go, 0.845153264581, tolerance = 1e-10) + res <- qdm_decide(ref_design_bin2("BF1"), data_binary2(c(1, 0, 1, 1))) + expect_identical(res$decision, "Gray") + expect_equal(res$prob_go, 0.204310825893, tolerance = 1e-10) + expect_equal(res$prob_nogo, 0.204310825893, tolerance = 1e-10) + res <- qdm_decide(ref_design_cont2("KF1"), ref_data_cont2$KF1$t) + expect_identical(res$decision, "Gray") + expect_equal(res$prob_go, 0.448613893688, tolerance = 1e-9) + res <- qdm_decide(ref_design_cont2("KF2"), ref_data_cont2$KF2$t) + expect_identical(res$decision, "Go") + expect_equal(res$prob_nogo, 0.13754578381, tolerance = 1e-9) + expect_error(qdm_decide(ref_design("D8"), data_binary(20, 11), + data_binary(20, 4)), + "'data_c' must be NULL for a design without a concurrent") +}) + +test_that("qdm_decide() decides for a time-to-event endpoint", { + for (name in c("T1", "T2", "T5", "T6")) { + d <- ref_data_tte[[name]] + res <- qdm_decide(ref_design_tte(name), d$t, d$c) + expect_identical(res$decision, "Go", info = name) + expect_equal(c(res$prob_go, res$prob_nogo), unname(ref_prob_tte[[name]]), + tolerance = 1e-10, info = name) + } + # Predictive probabilities: Monte Carlo estimates that depend on the seed + for (name in c("T3", "T4")) { + d <- ref_data_tte[[name]] + des <- ref_design_tte(name) + a <- qdm_decide(des, d$t, d$c, seed = 8) + b <- qdm_decide(des, d$t, d$c, seed = 8) + expect_identical(a$prob_go, b$prob_go, info = name) + ref <- ref_prob_tte[[name]][["go"]] + expect_lt(abs(a$prob_go - ref), 4.5 * sqrt(ref * (1 - ref) / 1e4) + 0.002) + expect_equal(a$prob_go + a$prob_nogo, 1) + } + expect_identical(qdm_decide(ref_design_tte("T3"), ref_data_tte$T3$t, + seed = 8)$decision, "Go") +}) diff --git a/tests/testthat/test-qdm_oc.R b/tests/testthat/test-qdm_oc.R new file mode 100644 index 0000000..723e8f2 --- /dev/null +++ b/tests/testthat/test-qdm_oc.R @@ -0,0 +1,570 @@ +# Exact references: Python_reference/ref_binary_qdm.py (rational arithmetic; +# the smallest distance between a probability of an outcome and a threshold +# is at least 3e-4, except for the intended ties of D7). +ref_oc <- list( + D1 = data.frame( + Go = c(0.012899294721250123, 0.14854199690661835, + 0.4890801931489531, 0.853069343654709), + NoGo = c(0.8087444110220947, 0.41767794351065546, + 0.11426515535993896, 0.009738702385720657), + Gray = c(0.1783562942566552, 0.4337800595827262, + 0.39665465149110796, 0.13719195395957035), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ), + D2 = data.frame( + Go = c(0.008284858893991935, 0.13864155130259045, + 0.5111211700731249, 0.8841751124361872), + NoGo = c(0.5935752005455708, 0.17640016449660517, + 0.023415970840182786, 0.000690132953071616), + Gray = c(0.3981399405604372, 0.6849582842008044, + 0.4654628590866923, 0.11513475461074124), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ), + D3 = data.frame( + Go = c(0.003903131648, 0.158212292608, + 0.665208557568, 0.980594720768), + NoGo = c(0.79456894976, 0.22533728256, + 0.01526726656, 6.219776e-05), + Gray = c(0.201527918592, 0.616450424832, + 0.319524175872, 0.019343081472), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ), + D4 = data.frame( + Go = c(0.003903131648, 0.158212292608, + 0.665208557568, 0.980594720768), + NoGo = c(0.55834574848, 0.08344332288, + 0.00281018368, 4.52608e-06), + Gray = c(0.437751119872, 0.758344384512, + 0.331981258752, 0.019400753152), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ), + D5 = data.frame( + Go = c(0.002175177111770235, 0.02824424826561626, + 0.1350357734374716, 0.42590770164544833), + NoGo = c(0.776219456280734, 0.41002224966905626, + 0.12752251421483599, 0.014808410228795638), + Gray = c(0.22160536660749583, 0.5617335020653275, + 0.7374417123476924, 0.559283888125756), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ), + D6 = data.frame( + Go = c(0.0290828790595584, 0.1295783505690624, + 0.3524185448054784, 0.7117744587669504), + NoGo = c(0.88082300796928, 0.600355270721536, + 0.283936647282688, 0.069097745711104), + Gray = c(0.0, 0.0, + 0.0, 0.0), + Miss = c(0.0900941129711616, 0.2700663787094016, + 0.3636448079118336, 0.2191277955219456) + ), + D7 = data.frame( + Go = c(0.321296601088, 0.615339200512, + 0.841787707392, 0.965405052928), + NoGo = c(0.20031995904, 0.06857588736, + 0.01526726656, 0.00126910464), + Gray = c(0.478383439872, 0.316084912128, + 0.142945026048, 0.033325842432), + Miss = c(0.0, 0.0, + 0.0, 0.0) + ) +) + +test_that("qdm_oc() matches the exact references for all control forms", { + for (name in names(ref_oc)) { + des <- ref_design(name) + scen <- if (des$n_c > 0) scen_c else scen_u + if (name == "D6") { + expect_warning(oc <- qdm_oc(des, scen), "both met \\(Miss\\)") + } else { + expect_silent(oc <- qdm_oc(des, scen)) + } + got <- as.data.frame(oc)[, c("Go", "NoGo", "Gray", "Miss")] + attr(got, "design") <- NULL + attr(got, "method") <- NULL + class(got) <- "data.frame" + expect_equal(got, ref_oc[[name]], tolerance = 1e-9, info = name) + } +}) + +test_that("qdm_oc() probabilities add up to 1", { + oc <- qdm_oc(ref_design("D2"), data.frame(pi_t = c(0, 0.33, 1), + pi_c = c(1, 0.5, 0))) + expect_equal(oc$Go + oc$NoGo + oc$Gray + oc$Miss, rep(1, 3), + tolerance = 1e-12) +}) + +test_that("qdm_oc() agrees with decisions for each outcome", { + # Independent route: qdm_decide() for every outcome and binomial weights + for (name in c("D2", "D3", "D5")) { + des <- ref_design(name) + pi_t <- 0.55 + pi_c <- 0.35 + y_c_all <- if (des$n_c > 0) 0:des$n_c else NA + tab <- expand.grid(y_t = 0:des$n_t, y_c = y_c_all) + tab$decision <- vapply(seq_len(nrow(tab)), function(k) { + data_c <- if (des$n_c > 0) data_binary(des$n_c, tab$y_c[k]) else NULL + qdm_decide(des, data_binary(des$n_t, tab$y_t[k]), data_c)$decision + }, character(1)) + tab$w <- stats::dbinom(tab$y_t, des$n_t, pi_t) * + (if (des$n_c > 0) stats::dbinom(tab$y_c, des$n_c, pi_c) else 1) + oc <- qdm_oc(des, data.frame(pi_t = pi_t, pi_c = pi_c)) + for (d in c("Go", "NoGo", "Gray", "Miss")) { + expect_equal(oc[[d]], sum(tab$w[tab$decision == d]), tolerance = 1e-12, + info = paste(name, d)) + } + } +}) + +test_that("qdm_oc() keeps extra columns and records the design", { + des <- ref_design("D1") + scen <- data.frame(label = c("null", "alt"), pi_t = c(0.4, 0.7), + pi_c = 0.4, extra = 1:2) + oc <- qdm_oc(des, scen) + expect_s3_class(oc, c("qdm_oc", "data.frame"), exact = TRUE) + expect_identical(names(oc), c("label", "pi_t", "pi_c", "extra", "Go", + "NoGo", "Gray", "Miss")) + expect_identical(oc$label, c("null", "alt")) + expect_identical(attr(oc, "design"), des) + expect_identical(attr(oc, "method"), "exact enumeration of the outcomes") + # The control rate is not needed without a concurrent control group + oc_u <- qdm_oc(ref_design("D3"), data.frame(pi_t = 0.5, pi_c = 0.9)) + expect_equal(oc_u$Go, qdm_oc(ref_design("D3"), + data.frame(pi_t = 0.5))$Go) +}) + +test_that("qdm_oc() probability of Go increases with the treatment rate", { + oc <- qdm_oc(ref_design("D1"), + data.frame(pi_t = seq(0, 1, by = 0.05), pi_c = 0.3)) + expect_true(all(diff(oc$Go) >= -1e-12)) + expect_true(all(diff(oc$NoGo) <= 1e-12)) + expect_equal(oc$NoGo[1], 1 - oc$Gray[1] - oc$Go[1], tolerance = 1e-12) +}) + +test_that("qdm_oc() leaves the random number stream unchanged", { + des <- ref_design("D1") + set.seed(3) + before <- .Random.seed + a <- qdm_oc(des, scen_c, nsim = 10, seed = 99) + expect_identical(.Random.seed, before) + b <- qdm_oc(des, scen_c) + expect_identical(a, b) +}) + +test_that("qdm_oc() validates its arguments", { + des <- ref_design("D1") + expect_error(qdm_oc(list(), scen_c), "'design' must be created by") + expect_error(qdm_oc(des, c(pi_t = 0.4, pi_c = 0.4)), + "'scenarios' must be a data frame with at least one row.") + expect_error(qdm_oc(des, data.frame(pi_t = 0.4)), + "'scenarios' must have the column\\(s\\) pi_t, pi_c.") + expect_error(qdm_oc(des, data.frame(pi_t = 1.2, pi_c = 0.4)), + "'scenarios\\$pi_t' must be at least 0 and at most 1.") + expect_error(qdm_oc(des, data.frame(pi_t = 0.4, pi_c = 0.4, Go = 1)), + "must not have columns named Go, NoGo, Gray or Miss.") + expect_error(qdm_oc(des, scen_c, nsim = 0), + "'nsim' must be at least 1 and at most 2147483647.") + expect_error(qdm_oc(des, scen_c, nsim = 3e9), + "'nsim' must be at least 1 and at most 2147483647.") + expect_error(qdm_oc(des, scen_c, seed = 1.5), + "'seed' must contain whole numbers only.") + expect_error(qdm_oc(des, scen_c, seed = 1e10), + "'seed' must be at least -2147483647 and at most 2147483647.") +}) + +test_that("qdm_oc() agrees with simulated trials", { + skip_on_cran() + des <- ref_design("D2") + set.seed(42) + nrep <- 4000 + y_t <- stats::rbinom(nrep, des$n_t, 0.6) + y_c <- stats::rbinom(nrep, des$n_c, 0.4) + dec <- vapply(seq_len(nrep), function(k) { + qdm_decide(des, data_binary(des$n_t, y_t[k]), + data_binary(des$n_c, y_c[k]))$decision + }, character(1)) + oc <- qdm_oc(des, data.frame(pi_t = 0.6, pi_c = 0.4)) + for (d in c("Go", "NoGo", "Gray")) { + p <- oc[[d]] + expect_lt(abs(mean(dec == d) - p), 4 * sqrt(p * (1 - p) / nrep) + 1e-12) + } +}) + +test_that("qdm_oc() reproduces Kang et al. (2026), Supplemental Table 2", { + # Beta(0.5, 0.5) priors, n_t = n_c = 12, pi_c = 0.4 and treatment effects + # -0.4, -0.2, 0, 0.4, 0.6. Published values (three decimals): + # inst/validation/kang2026_supplement.csv, rows 1, 10, 19, 28 and 37 of + # Table 2. The full comparison is in inst/validation/run_validation.R. + jeff <- prior_beta(0.5, 0.5) + scen <- data.frame(pi_t = c(0, 0.2, 0.4, 0.8, 1), pi_c = 0.4) + d_post <- design_binary(12, 12, jeff, jeff, crit_post()) + d_pred <- design_binary(12, 12, jeff, jeff, + criterion_predictive(0, m_t = 50, gamma_go = 0.9, + gamma_nogo = 0.7)) + pub_post <- rbind(c(0, 1, 0), c(0.013, 0.812, 0.175), + c(0.149, 0.418, 0.433), c(0.853, 0.010, 0.137), + c(0.997, 0, 0.003)) + pub_pred <- rbind(c(0, 0.998, 0.002), c(0.006, 0.677, 0.317), + c(0.076, 0.267, 0.657), c(0.739, 0.003, 0.258), + c(0.997, 0, 0.003)) + cols <- c("Go", "NoGo", "Gray") + post <- as.matrix(qdm_oc(d_post, scen)[, cols]) + pred <- as.matrix(qdm_oc(d_pred, scen)[, cols]) + expect_lt(max(abs(post - pub_post)), 0.0005 + 1e-9) + expect_lt(max(abs(pred - pub_pred)), 0.0005 + 1e-9) +}) + +# Continuous endpoint. Exact operating characteristics of the uncontrolled +# designs C3 and C6 (vague prior, hypothetical control): +# Python_reference/ref_continuous_qdm.py, where each criterion is a threshold +# on a statistic with a noncentral t distribution. The simulated +# probabilities are compared with a tolerance of 4.5 standard errors plus +# 0.002 (Python_reference/port_continuous_oc.py checks the same procedure). +exact_oc_cont <- list( + C3 = list( + scen = data.frame(mu_t = c(0, 20, 35), sd_t = c(20, 20, 25)), + NI = list(Go = c(5.59007059741e-05, 0.339921868611, 0.951288822042), + NoGo = c(0.502398874545, 0.000333627271368, 3.94025694328e-07)), + MM = list(Go = c(5.60512055178e-05, 0.340178784483, 0.9513624542), + NoGo = c(0.502915282701, 0.000335015391109, 3.96193102629e-07)) + ), + C6 = list( + scen = data.frame(mu_t = c(0, 5, 12), sd_t = c(12, 12, 15)), + NI = list(Go = c(0.00299458547153, 0.12035425217, 0.722001478), + NoGo = c(0.847885721764, 0.282128401915, 0.00881718335511)), + MM = list(Go = c(0.00300601509893, 0.120621873617, 0.722483043333), + NoGo = c(0.848072473479, 0.282387849867, 0.00883485467116)) + ) +) + +expect_oc_close <- function(oc, ref, nsim, info) { + for (d in c("Go", "NoGo")) { + p <- ref[[d]] + expect_true(all(abs(oc[[d]] - p) <= 4.5 * sqrt(p * (1 - p) / nsim) + + 0.002), info = paste(info, d)) + } + expect_identical(oc$Miss, c(0, 0, 0), info = info) +} + +test_that("qdm_oc() matches the exact references for continuous designs (MM)", { + for (name in c("C3", "C6")) { + ex <- exact_oc_cont[[name]] + oc <- qdm_oc(ref_design_cont(name, "MM"), ex$scen, nsim = 20000, + seed = 20261013) + expect_oc_close(oc, ex$MM, 20000, paste(name, "MM")) + } +}) + +test_that("qdm_oc() matches the exact references for design C3 (NI)", { + skip_on_cran() + ex <- exact_oc_cont$C3 + oc <- qdm_oc(ref_design_cont("C3"), ex$scen, nsim = 1000, seed = 1) + expect_oc_close(oc, ex$NI, 1000, "C3 NI") +}) + +test_that("qdm_oc() matches the exact references for design C6 (NI)", { + skip_on_cran() + ex <- exact_oc_cont$C6 + oc <- qdm_oc(ref_design_cont("C6"), ex$scen, nsim = 1000, seed = 2) + expect_oc_close(oc, ex$NI, 1000, "C6 NI") +}) + +test_that("qdm_oc() simulates continuous designs with a concurrent control", { + des <- ref_design_cont("C1", "MM") + set.seed(5) + before <- .Random.seed + oc <- qdm_oc(des, cbind(label = c("a", "b", "c"), scen_cont_c), + nsim = 500, seed = 7) + expect_identical(.Random.seed, before) + expect_s3_class(oc, c("qdm_oc", "data.frame"), exact = TRUE) + expect_identical(names(oc), c("label", "mu_t", "sd_t", "mu_c", "sd_c", + "Go", "NoGo", "Gray", "Miss")) + expect_equal(oc$Go + oc$NoGo + oc$Gray + oc$Miss, c(1, 1, 1)) + expect_identical(attr(oc, "method"), + paste("simulation of 500 studies; probabilities by", + "moment-matching approximation")) + # Common random numbers: the probability of Go increases with the effect + expect_true(all(diff(oc$Go) > 0)) + expect_true(all(diff(oc$NoGo) < 0)) + # The same seed gives the same result + expect_identical(qdm_oc(des, scen_cont_c, nsim = 500, seed = 7)$Go, oc$Go) +}) + +test_that("qdm_oc() works with Monte Carlo probabilities", { + # With the predictive criterion, the Monte Carlo probabilities of the Go + # and NoGo regions of each simulated study add up to 1, so both criteria + # cannot be met when gamma_go + gamma_nogo > 1 (0.7 + 0.6 in design C6) + des <- ref_design_cont("C6", "MC", 2000L) + oc <- qdm_oc(des, exact_oc_cont$C6$scen, nsim = 100, seed = 3) + expect_identical(oc$Miss, c(0, 0, 0)) + expect_equal(oc$Go + oc$NoGo + oc$Gray, c(1, 1, 1)) + expect_lt(abs(oc$Go[3] - 0.722), 4.5 * sqrt(0.722 * 0.278 / 100) + 0.02) +}) + +test_that("qdm_oc() validates the scenarios of continuous designs", { + des <- ref_design_cont("C1", "MM") + expect_error(qdm_oc(des, data.frame(mu_t = 1, sd_t = 1)), + paste("'scenarios' must have the column\\(s\\) mu_t, sd_t,", + "mu_c, sd_c.")) + expect_error(qdm_oc(des, data.frame(mu_t = 1, sd_t = 0, mu_c = 0, + sd_c = 1)), + "'scenarios\\$sd_t' must be greater than 0.") + expect_error(qdm_oc(ref_design_cont("C3", "MM"), data.frame(mu_t = 1)), + "'scenarios' must have the column\\(s\\) mu_t, sd_t.") +}) + +# Two binary endpoints. Exact references: Python_reference/ref_binary2_qdm.py +# (B: predictive criteria, rational arithmetic; D: posterior criteria on one +# endpoint at a time, differences of Beta variables). For designs B3 and B4 +# no outcome has a probability within 5 Monte Carlo standard errors +# (nMC = 20000) of a threshold, so the Monte Carlo error does not change any +# decision. The published tables of Yamaguchi et al. (submitted) need the +# enumeration of 286 x 286 pairs of outcomes and are reproduced in +# inst/validation/validate_yamaguchi_binary2.R instead. +ref_oc_bin2 <- list( + B1 = rbind(c(0.156029909046664, 0.558146336369747, 0.282478801684779, + 0.00334495289881015), + c(0.3312351, 0.2440805, 0.4199216, 0.0047628), + c(0.666686263299421, 0.0789967306310707, 0.249597442622606, + 0.00471956344690299)), + B2 = rbind(c(0.0743517888004001, 0.326426105367674, 0.599222105831926, 0), + c(0.2607633, 0.1627937, 0.576443, 0), + c(0.535900183423335, 0.0307251043879517, 0.433374712188714, 0)), + B3 = rbind(c(0.12022101, 0.406285269999998, 0.473493719999998, 0), + c(0.426958559999999, 0.11187472, 0.461166719999999, 0), + c(0.796917759999999, 0.01171712, 0.19136512, 0)), + B4 = rbind(c(0.121502195183722, 0.424358895183721, 0.454138909632553, 0), + c(0.465942411080158, 0.163130761080159, 0.370926827839682, 0), + c(0.766733348737193, 0.0171192987371942, 0.216147352525611, 0)) +) + +test_that("qdm_oc() matches the exact references for two binary endpoints", { + for (name in names(ref_oc_bin2)) { + scen <- if (name %in% c("B1", "B2")) scen_bin2 else scen_bin2_d + if (name == "B1") { + expect_warning(oc <- qdm_oc(ref_design_bin2(name), scen, seed = 1), + "Miss") + } else { + oc <- qdm_oc(ref_design_bin2(name), scen, seed = 1) + } + expect_equal(as.matrix(oc[, c("Go", "NoGo", "Gray", "Miss")]), + ref_oc_bin2[[name]], tolerance = 1e-9, + ignore_attr = TRUE, info = name) + } +}) + +test_that("qdm_oc() simulates studies with two binary endpoints", { + nsim <- 4000 + expect_warning(oc <- qdm_oc(ref_design_bin2("B1", enumerate = FALSE), + scen_bin2, nsim = nsim, seed = 11), "Miss") + ex <- ref_oc_bin2$B1 + tol <- 4.5 * sqrt(ex * (1 - ex) / nsim) + 0.002 + expect_true(all(abs(as.matrix(oc[, c("Go", "NoGo", "Gray", "Miss")]) - + ex) <= tol)) + expect_match(attr(oc, "method"), "^simulation of 4000 studies") +}) + +test_that("qdm_oc() enumerates the outcomes without a concurrent control", { + # Recompute the operating characteristics from the decisions for all + # outcomes of the treatment group + for (name in c("B7", "B8")) { + des <- ref_design_bin2(name) + x <- outcomes_binary2(3) + dec <- vapply(seq_len(nrow(x)), function(i) { + qdm_decide(des, data_binary2(x[i, ]))$decision + }, character(1)) + sc <- scen_bin2[2, c("pi_t1", "pi_t2", "rho_t")] + w <- dmultinom_counts(x, cellprob_binary2(0.6, 0.5, 0)) + oc <- suppressWarnings(qdm_oc(des, sc)) + for (d in c("Go", "NoGo", "Gray", "Miss")) { + expect_equal(oc[[d]], sum(w[dec == d]), tolerance = 1e-12, + info = paste(name, d)) + } + } +}) + +test_that("qdm_oc() reports scenarios that are not evaluable", { + sc <- rbind(scen_bin2[1, ], data.frame(pi_t1 = 0.35, pi_t2 = 0.15, + rho_t = 0.6, pi_c1 = 0.2, + pi_c2 = 0.15, rho_c = 0.6)) + for (enum in c(TRUE, FALSE)) { + w <- character(0) + oc <- withCallingHandlers( + qdm_oc(ref_design_bin2("B2", enumerate = enum), sc, nsim = 100, + seed = 1), + warning = function(e) { + w <<- c(w, conditionMessage(e)) + invokeRestart("muffleWarning") + } + ) + expect_true(any(grepl("Scenario\\(s\\) 2 are not evaluable", w))) + expect_true(all(is.na(oc[2, c("Go", "NoGo", "Gray", "Miss")]))) + expect_false(anyNA(oc[1, c("Go", "NoGo", "Gray", "Miss")])) + } +}) + +# Two continuous endpoints. References: Python_reference/ref_continuous2_qdm.py, +# section D (simulation of 1e5 studies per scenario from the raw data, moment +# matching). The tolerance is 4.5 standard errors of both simulations plus +# 0.002. +ref_oc_cont2 <- list( + K1 = rbind( + c(0.02988, 0.48772, 0.4824, 0), + c(0.22913, 0.32022, 0.45065, 0), + c(0.50278, 0.30381, 0.1934, 1e-05) + ), + K2 = rbind( + c(0.04448, 0.64277, 0.31275, 0), + c(0.44666, 0.29693, 0.25641, 0), + c(0.76227, 0.1782, 0.03907, 0.02046) + ), + K3 = rbind( + c(0.01007, 0.51147, 0.47846, 0), + c(0.31993, 0.02817, 0.6519, 0), + c(0.76923, 0.00082, 0.22995, 0) + ), + K4 = rbind( + c(0.03128, 0.86085, 0.10725, 0.00062), + c(0.55416, 0.14516, 0.29981, 0.00087), + c(0.9525, 0.00022, 0.04727, 1e-05) + ), + K5 = rbind( + c(0.04574, 0.41433, 0.53993, 0), + c(0.33466, 0.05605, 0.60929, 0), + c(0.66123, 0.00532, 0.33345, 0) + ), + K6 = rbind( + c(0, 0.51155, 0.48845, 0), + c(0.00027, 0.00192, 0.99781, 0), + c(0.24199, 0, 0.75801, 0) + ) +) + +oc_cont2_quiet <- function(...) { + withCallingHandlers(qdm_oc(...), warning = function(w) { + if (grepl("Miss", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + }) +} + +check_oc_cont2 <- function(name, nsim = 2000L) { + oc <- oc_cont2_quiet(ref_design_cont2(name), scen_cont2(name), + nsim = nsim, seed = 2026) + got <- as.matrix(oc[, c("Go", "NoGo", "Gray", "Miss")]) + ref <- ref_oc_cont2[[name]] + se <- sqrt(ref * (1 - ref) * (1 / nsim + 1 / 1e5)) + expect_true(all(abs(got - ref) <= 4.5 * se + 0.002), info = name) + expect_equal(unname(rowSums(got)), rep(1, 3), tolerance = 1e-12) +} + +test_that("qdm_oc() matches the references for two continuous endpoints", { + check_oc_cont2("K1") + check_oc_cont2("K6") +}) + +test_that("qdm_oc() matches the references for designs K2 and K3", { + skip_on_cran() + check_oc_cont2("K2") + check_oc_cont2("K3") +}) + +test_that("qdm_oc() matches the references for designs K4 and K5", { + skip_on_cran() + check_oc_cont2("K4") + check_oc_cont2("K5") +}) + +test_that("qdm_oc() simulates two continuous endpoints with Monte Carlo", { + oc <- oc_cont2_quiet(ref_design_cont2("K1", "MC", 2000L), + scen_cont2("K1")[2, ], nsim = 400L, seed = 5) + ref <- ref_oc_cont2$K1[2, ] + got <- unlist(oc[, c("Go", "NoGo", "Gray", "Miss")]) + se <- sqrt(ref * (1 - ref) / 400) + expect_true(all(abs(got - ref) <= 4.5 * se + 0.02)) + expect_match(attr(oc, "method"), + "simulation of 400 studies; .*Monte Carlo simulation") +}) + +test_that("qdm_oc() matches the exact references with a fixed control", { + # References: Python_reference/ref_fixed_tte_qdm.py (enumeration of the + # outcomes) + oc <- qdm_oc(ref_design("D8"), scen_u) + expect_identical(attr(oc, "method"), "exact enumeration of the outcomes") + expect_equal(oc$Go, c(0.00259482740067, 0.244662796684, 0.872478753853, + 0.999436586302), tolerance = 1e-9) + expect_equal(oc$NoGo, c(0.411448861957, 0.01596116279, 4.7344970692e-05, + 7.9776710656e-10), tolerance = 1e-9) + expect_equal(oc$Miss, rep(0, 4L)) + oc9 <- qdm_oc(ref_design("D9"), data.frame(pi_t = c(0.2, 0.4, 0.6))) + expect_equal(oc9$Go, c(0.1208738816, 0.6177193984, 0.9452381184), + tolerance = 1e-9) + expect_equal(oc9$NoGo, c(0.6777995264, 0.1672897536, 0.0122945536), + tolerance = 1e-9) + expect_equal(oc9$Gray, c(0.201326592, 0.214990848, 0.042467328), + tolerance = 1e-9) + sc <- data.frame(pi_t1 = c(0.3, 0.5, 0.7), pi_t2 = c(0.4, 0.6, 0.7), + rho_t = c(0.2, 0, 0.3)) + ocb <- qdm_oc(ref_design_bin2("BF1"), sc) + expect_equal(ocb$Go, c(0.0726080130921, 0.216, 0.579202246), + tolerance = 1e-9) + expect_equal(ocb$NoGo, c(0.721260675859, 0.338, 0.167444577), + tolerance = 1e-9) + expect_equal(ocb$Gray, c(0.206131311049, 0.446, 0.253353177), + tolerance = 1e-9) +}) + +test_that("qdm_oc() agrees with the exact references for a fixed continuous control", { + # References: Python_reference/ref_fixed_tte_qdm.py (noncentral t + # distributions) + nsim <- 20000L + tol <- function(p) 4.5 * sqrt(p * (1 - p) / nsim) + 0.002 + oc7 <- qdm_oc(ref_design_cont("C7"), scen_cont_u, nsim = nsim, seed = 3) + ref_go <- c(0.000102665519772, 0.4, 0.999325919193) + ref_nogo <- c(0.63159677607, 0.000947098825199, 2.8762586985e-11) + expect_true(all(abs(oc7$Go - ref_go) <= tol(ref_go))) + expect_true(all(abs(oc7$NoGo - ref_nogo) <= tol(ref_nogo))) + expect_identical(attr(oc7, "method"), + paste("simulation of 20000 studies; probabilities by", + "exact computation (fixed control)")) + oc8 <- qdm_oc(ref_design_cont("C8"), + data.frame(mu_t = c(0, 5, 12), sd_t = c(12, 12, 15)), + nsim = nsim, seed = 4) + ref_go <- c(0.0124614836728, 0.26087426553, 0.875577271217) + ref_nogo <- c(0.903337893177, 0.378241335701, 0.0172420544481) + expect_true(all(abs(oc8$Go - ref_go) <= tol(ref_go))) + expect_true(all(abs(oc8$NoGo - ref_nogo) <= tol(ref_nogo))) +}) + +test_that("qdm_oc() simulates time-to-event designs", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, design T1 + nsim <- 20000L + tol <- function(p) 4.5 * sqrt(p * (1 - p) / nsim) + 0.002 + oc <- qdm_oc(ref_design_tte("T1"), data.frame(median_t = c(6.3, 20)), + nsim = nsim, seed = 2) + expect_identical(names(oc), c("median_t", "Go", "NoGo", "Gray", "Miss")) + ref_go <- c(2.48918966507e-09, 0.899733183632) + ref_nogo <- c(0.205961280815, 2.15285582264e-09) + expect_true(all(abs(oc$Go - ref_go) <= tol(ref_go))) + expect_true(all(abs(oc$NoGo - ref_nogo) <= tol(ref_nogo))) + oc2 <- qdm_oc(ref_design_tte("T2"), + data.frame(median_t = c(6, 12), median_c = 6), nsim = 200, + seed = 1) + expect_identical(names(oc2), c("median_t", "median_c", "Go", "NoGo", + "Gray", "Miss")) + expect_identical(attr(oc2, "method"), + paste("simulation of 200 studies; probabilities by", + "numerical integration")) + expect_equal(oc2$Go + oc2$NoGo + oc2$Gray + oc2$Miss, c(1, 1)) + expect_gt(oc2$Go[2L], oc2$Go[1L]) + expect_error(qdm_oc(ref_design_tte("T2"), data.frame(median_t = 6), + nsim = 10), + "'scenarios' must have the column\\(s\\) median_t, median_c.") + expect_error(qdm_oc(ref_design_tte("T1"), data.frame(median_t = 0), + nsim = 10), + "'scenarios\\$median_t' must be greater than 0.") +}) diff --git a/tests/testthat/test-qdm_regions.R b/tests/testthat/test-qdm_regions.R new file mode 100644 index 0000000..3082e4e --- /dev/null +++ b/tests/testthat/test-qdm_regions.R @@ -0,0 +1,25 @@ +test_that("qdm_regions() follows Table 1 of Yamaguchi et al.", { + r <- qdm_regions("posterior") + expect_s3_class(r, "noquote") + expect_identical(dim(r), c(3L, 3L)) + # R1 to R3 run down the first column (theta1 > TV1) + expect_identical(unclass(r)[, 1], c("theta2 > TV2" = "R1", + "MAV2 < theta2 <= TV2" = "R2", + "theta2 <= MAV2" = "R3")) + expect_identical(unclass(r)["theta2 <= MAV2", "theta1 <= MAV1"], "R9") +}) + +test_that("qdm_regions() follows Table 2 of Yamaguchi et al.", { + r <- unclass(qdm_regions("predictive")) + expect_identical(dim(r), c(2L, 2L)) + expect_identical(r["theta2 <= NULL2", "theta1 > NULL1"], "R2") + expect_identical(r["theta2 > NULL2", "theta1 <= NULL1"], "R3") + expect_error(qdm_regions("other"), "'arg' should be one of") +}) + +test_that("qdm_regions() shows the posterior regions by default", { + expect_identical(qdm_regions(), qdm_regions("posterior")) + expect_identical(sort(as.vector(unclass(qdm_regions()))), paste0("R", 1:9)) + expect_identical(sort(as.vector(unclass(qdm_regions("predictive")))), + paste0("R", 1:4)) +}) diff --git a/tests/testthat/test-rdirichlet.R b/tests/testthat/test-rdirichlet.R new file mode 100644 index 0000000..439c681 --- /dev/null +++ b/tests/testthat/test-rdirichlet.R @@ -0,0 +1,49 @@ +test_that("rdirichlet() returns a matrix of probability vectors", { + set.seed(1) + x <- rdirichlet(5, c(a = 1, b = 2, c = 3)) + expect_identical(dim(x), c(5L, 3L)) + expect_identical(colnames(x), c("a", "b", "c")) + expect_equal(rowSums(x), rep(1, 5), tolerance = 1e-12) + expect_true(all(x > 0)) + expect_identical(dim(rdirichlet(1, c(1, 1))), c(1L, 2L)) +}) + +test_that("rdirichlet() has the Dirichlet means and variances", { + set.seed(2) + alpha <- c(1.5, 0.5, 2, 1) + a0 <- sum(alpha) + x <- rdirichlet(4e4, alpha) + mean_true <- alpha / a0 + var_true <- alpha * (a0 - alpha) / (a0 ^ 2 * (a0 + 1)) + expect_true(all(abs(colMeans(x) - mean_true) < 4 * sqrt(var_true / 4e4))) + expect_equal(apply(x, 2, stats::var), var_true, tolerance = 0.05) +}) + +test_that("rdirichlet() validates its arguments", { + expect_error(rdirichlet(0, c(1, 1)), "'n' must be at least 1.") + expect_error(rdirichlet(2, 1), "'alpha' must have length 2 or more.") + expect_error(rdirichlet(2, c(1, 0)), "'alpha' must be greater than 0.") +}) + +test_that("rdirichlet() has Beta margins and the Dirichlet covariance", { + set.seed(3) + alpha <- c(2, 3, 1.5) + a0 <- sum(alpha) + x <- rdirichlet(2e4, alpha) + # The first component follows Beta(alpha_1, a0 - alpha_1) + ks <- stats::ks.test(x[, 1], "pbeta", alpha[1], a0 - alpha[1]) + expect_gt(ks$p.value, 1e-3) + # Cov(X_1, X_2) = -alpha_1 alpha_2 / (a0^2 (a0 + 1)) + expect_equal(stats::cov(x[, 1], x[, 2]), + -alpha[1] * alpha[2] / (a0 ^ 2 * (a0 + 1)), tolerance = 0.1) +}) + +test_that("rdirichlet() is reproducible and does not name unnamed columns", { + set.seed(9) + a <- rdirichlet(3, c(1, 1)) + set.seed(9) + b <- rdirichlet(3, c(1, 1)) + expect_identical(a, b) + expect_null(colnames(a)) + expect_error(rdirichlet(2.5, c(1, 1)), "whole numbers") +}) diff --git a/tests/testthat/test-recycle_common.R b/tests/testthat/test-recycle_common.R new file mode 100644 index 0000000..004d6a1 --- /dev/null +++ b/tests/testthat/test-recycle_common.R @@ -0,0 +1,16 @@ +test_that("recycle_common() recycles length-1 arguments", { + out <- recycle_common(list(a = 1, b = c(2, 3, 4))) + expect_identical(out, list(a = c(1, 1, 1), b = c(2, 3, 4))) +}) + +test_that("recycle_common() rejects incompatible lengths", { + expect_error(recycle_common(list(a = 1:2, b = 1:3)), + "'a' must have length 1 or 3.") +}) + +test_that("recycle_common() keeps equal lengths and lists every bad argument", { + out <- recycle_common(list(a = 1, b = 2)) + expect_identical(out, list(a = 1, b = 2)) + expect_error(recycle_common(list(a = 1:2, b = 1:4, c = 1:3)), + "'a', 'c' must have length 1 or 4.") +}) diff --git a/tests/testthat/test-region_cells.R b/tests/testthat/test-region_cells.R new file mode 100644 index 0000000..1d15a1f --- /dev/null +++ b/tests/testthat/test-region_cells.R @@ -0,0 +1,5 @@ +test_that("region_cells() maps the regions to the nine-region grid", { + expect_identical(region_cells(c(1, 5, 9), "posterior"), c(1L, 5L, 9L)) + expect_identical(region_cells(1:4, "predictive"), c(1L, 3L, 7L, 9L)) + expect_identical(region_cells(c(2, 4), "predictive"), c(3L, 9L)) +}) diff --git a/tests/testthat/test-region_mask.R b/tests/testthat/test-region_mask.R new file mode 100644 index 0000000..45a35d7 --- /dev/null +++ b/tests/testthat/test-region_mask.R @@ -0,0 +1,6 @@ +test_that("region_mask() sets one bit per region", { + expect_identical(region_mask(1L), 1L) + expect_identical(region_mask(c(1L, 2L)), 3L) + expect_identical(region_mask(9L), 256L) + expect_identical(region_mask(c(3L, 6L, 9L, 3L)), 4L + 32L + 256L) +}) diff --git a/tests/testthat/test-region_prob_binary.R b/tests/testthat/test-region_prob_binary.R new file mode 100644 index 0000000..8fd1f2c --- /dev/null +++ b/tests/testthat/test-region_prob_binary.R @@ -0,0 +1,39 @@ +test_that("region_prob_binary() uses pbetadiff() for posterior criteria", { + cr <- crit_post(tv = 0.15, mav = -0.05) + p <- region_prob_binary(cr, c(7.5, 3), c(5.5, 9), 4.5, 8.5) + expect_equal(p$go, pbetadiff(0.15, c(7.5, 3), c(5.5, 9), 4.5, 8.5, + lower.tail = FALSE)) + expect_equal(p$nogo, pbetadiff(-0.05, c(7.5, 3), c(5.5, 9), 4.5, 8.5)) +}) + +test_that("region_prob_binary() uses pbetabinomdiff() for predictive criteria", { + cr <- criterion_predictive(0.1, m_t = 30, m_c = 20, gamma_go = 0.8, + gamma_nogo = 0.6) + p <- region_prob_binary(cr, 7.5, 5.5, c(4.5, 2), c(8.5, 3)) + expect_equal(p$go, pbetabinomdiff(0.1, 30, 7.5, 5.5, 20, c(4.5, 2), + c(8.5, 3), lower.tail = FALSE)) + expect_equal(p$go + p$nogo, c(1, 1), tolerance = 1e-12) +}) + +test_that("region_prob_binary() uses the Beta distribution for a fixed control", { + cr <- crit_post(tv = 0.2, mav = 0.05) + # P(pi_t > 0.4) and P(pi_t <= 0.25) for Beta(12, 10) and Beta(3, 19) + p <- region_prob_binary(cr, c(12, 3), c(10, 19), NULL, NULL, fixed = 0.2) + expect_equal(p$go, stats::pbeta(0.4, c(12, 3), c(10, 19), + lower.tail = FALSE)) + expect_equal(p$nogo, stats::pbeta(0.25, c(12, 3), c(10, 19))) + # Reference: Python_reference/ref_fixed_tte_qdm.py (design D8, y = 11) + expect_equal(p$go[1], 0.915075681321, tolerance = 1e-10) + expect_equal(p$nogo[1], 0.00168707910052, tolerance = 1e-10) + # Thresholds beyond the range of the response rate + q <- region_prob_binary(crit_post(tv = 0.9, mav = -0.5), 2, 3, NULL, NULL, + fixed = 0.2) + expect_identical(c(q$go, q$nogo), c(0, 0)) +}) + +test_that("region_prob_binary() gives exact predictive probabilities for a fixed control", { + cr <- criterion_predictive(0, m_t = 10, gamma_go = 0.6, gamma_nogo = 0.6) + p <- region_prob_binary(cr, 4, 8, NULL, NULL, fixed = 0.3) + expect_equal(p$go, 283 / 646, tolerance = 1e-12) + expect_equal(p$go + p$nogo, 1, tolerance = 1e-12) +}) diff --git a/tests/testthat/test-region_prob_binary2.R b/tests/testthat/test-region_prob_binary2.R new file mode 100644 index 0000000..6bd64fc --- /dev/null +++ b/tests/testthat/test-region_prob_binary2.R @@ -0,0 +1,100 @@ +# References: Python_reference/ref_binary2_qdm.py (A: rational arithmetic +# over all future count vectors; C: Monte Carlo with 2e7 draws). +alpha_a1 <- rbind(c(2, 1, 3, 4) + 0.25, c(4, 2, 3, 1) + 0.25) + +test_that("region_prob_binary2() computes predictive probabilities exactly", { + cases <- list( + list(t = c(2, 1, 3, 4), c = c(4, 2, 3, 1), m = c(4, 3), q = c(0.1, 0), + ref = c(0.421763759173932, 0.221546787701068, 0.225275968676342, + 0.131413484448658)), + # Ties of the future effects with the null values 0 and 0.25 + list(t = c(1, 2, 2, 1), c = c(2, 1, 1, 2), m = c(4, 4), q = c(0, 0.25), + ref = c(0.0734282326698303, 0.312585561275482, 0.116701772212982, + 0.497284433841705)), + list(t = c(0, 0, 0, 3), c = c(3, 0, 0, 0), m = c(2, 5), + q = c(-0.2, 0.4), + ref = c(0.838421426500593, 0.143884481702532, 0.00752583912440709, + 0.0101682526724679)) + ) + for (k in seq_along(cases)) { + cs <- cases[[k]] + cr <- criterion_predictive(cs$q, m_t = cs$m[1], m_c = cs$m[2], + gamma_go = 0.5, gamma_nogo = 0.5) + p <- region_prob_binary2(cr, matrix(cs$t + 0.25, 1L), + matrix(cs$c + 0.25, 1L), 1L, 1L, as.list(1:4), + 10L) + expect_equal(p[1L, ], cs$ref, tolerance = 1e-12, info = paste("case", k)) + } + # Unions of regions and several pairs at once + cr <- criterion_predictive(c(0.1, 0), m_t = 4, m_c = 3, gamma_go = 0.5, + gamma_nogo = 0.5) + p2 <- region_prob_binary2(cr, alpha_a1, alpha_a1[2:1, ], c(1L, 2L), + c(1L, 1L), list(1:2, 1:4), 10L) + expect_identical(dim(p2), c(2L, 2L)) + expect_equal(p2[1L, ], c(0.421763759173932 + 0.221546787701068, 1), + tolerance = 1e-12) + # Many pairs (the C++ code checks for user interrupts every 10000 pairs) + p3 <- region_prob_binary2(cr, alpha_a1, alpha_a1, rep(1L, 10000L), + rep(2L, 10000L), list(1L), 10L) + expect_equal(range(p3), rep(0.421763759173932, 2), tolerance = 1e-12) + # Null values far outside [-1, 1]: every future effect on endpoint 1 is + # larger and none on endpoint 2 + far <- criterion_predictive(c(-1e17, 1e17), m_t = 4, m_c = 3, + gamma_go = 0.5, gamma_nogo = 0.5) + p4 <- region_prob_binary2(far, alpha_a1, alpha_a1, 1L, 2L, as.list(1:4), + 10L) + expect_equal(p4[1L, ], c(0, 1, 0, 0), tolerance = 1e-12) +}) + +test_that("region_prob_binary2() estimates posterior probabilities", { + ref <- c(0.430209, 0.068027, 0.239321, 0.039777, 0.006862, 0.025173, + 0.101228, 0.018258, 0.071145) + n_mc <- 200000L + set.seed(2026) + p <- region_prob_binary2(criterion_posterior(c(0.15, 0.15), c(0.1, 0.1), + 0.5, 0.5), + alpha_a1[1L, , drop = FALSE], + alpha_a1[2L, , drop = FALSE], 1L, 1L, + c(as.list(1:9), list(1:3, c(1L, 4L, 7L))), n_mc) + se <- sqrt(ref * (1 - ref) * (1 / n_mc + 1 / 2e7)) + expect_true(all(abs(p[1L, 1:9] - ref) <= 4.5 * se)) + expect_equal(sum(p[1L, 1:9]), 1, tolerance = 1e-12) + # The unions use the same draws as the regions + expect_equal(p[1L, 10], sum(p[1L, 1:3]), tolerance = 1e-12) + # Marginal probabilities: differences of two Beta variables + exact1 <- pbetadiff(0.15, 7.5, 3.5, 4.5, 6.5, lower.tail = FALSE) + exact2 <- pbetadiff(0.15, 5.5, 5.5, 3.5, 7.5, lower.tail = FALSE) + expect_equal(exact1, 0.737498698318608, tolerance = 1e-9) + expect_lt(abs(p[1L, 10] - exact1), 4.5 * sqrt(exact1 * (1 - exact1) / n_mc)) + expect_lt(abs(p[1L, 11] - exact2), 4.5 * sqrt(exact2 * (1 - exact2) / n_mc)) +}) + +test_that("region_prob_binary2() handles a fixed control", { + # Python_reference/ref_fixed_tte_qdm.py (design BF1): exact enumeration of + # the future cell counts of the treatment group + cr <- criterion_predictive(c(0.1, 0), m_t = 4, gamma_go = 0.4, + gamma_nogo = 0.3) + p <- region_prob_binary2(cr, matrix(c(1, 0, 1, 1) + 0.25, 1L), NULL, 1L, + NULL, as.list(1:4), 10L, fixed = c(0.25, 0.5)) + expect_equal(p[1L, ], c(0.204310825893, 0.569126674107, 0.0222516741071, + 0.204310825893), tolerance = 1e-10) + # Posterior probabilities from draws of the treatment distribution only: + # with fixed values 0, the regions are those of the treatment rates + set.seed(2) + cp <- criterion_posterior(c(0.5, 0.5), c(0.3, 0.3), 0.5, 0.5) + a <- matrix(c(2, 1, 3, 4) + 0.25, 1L) + p2 <- region_prob_binary2(cp, a, NULL, c(1L, 1L), NULL, as.list(1:9), + 20000L, fixed = c(0, 0)) + # Both pairs use the same draws + expect_identical(p2[1L, ], p2[2L, ]) + expect_equal(sum(p2[1L, ]), 1) + set.seed(3) + p3 <- region_prob_binary2(cp, a, NULL, 1L, NULL, list(1L), 20000L, + fixed = c(0, 0)) + set.seed(3) + g <- matrix(stats::rgamma(4 * 20000, rep(a[1L, ], 20000)), ncol = 4, + byrow = TRUE) + pi1 <- (g[, 3] + g[, 4]) / rowSums(g) + pi2 <- (g[, 2] + g[, 4]) / rowSums(g) + expect_equal(p3[1L, 1L], mean(pi1 > 0.5 & pi2 > 0.5)) +}) diff --git a/tests/testthat/test-region_prob_continuous.R b/tests/testthat/test-region_prob_continuous.R new file mode 100644 index 0000000..6ed45f6 --- /dev/null +++ b/tests/testthat/test-region_prob_continuous.R @@ -0,0 +1,92 @@ +# References: Python_reference/ref_continuous_qdm.py (two numerical +# integrations of the whole real line, and the moment-matching formula). +post <- function(mu, kappa, nu, sigma2) { + list(mu = mu, kappa = kappa, nu = nu, sigma2 = sigma2) +} +crit_c5 <- function() { + criterion_predictive(10, m_t = 40, m_c = 30, gamma_go = 0.8, + gamma_nogo = 0.7) +} +crit_c6 <- function() { + criterion_predictive(5, m_t = 30, m_c = 20, gamma_go = 0.7, + gamma_nogo = 0.6) +} + +test_that("region_prob_continuous() matches the references (posterior)", { + # Designs C1 and C3, as one vectorized call + pt <- post(c(18, 25), 12, 11, c(625, 400)) + pc <- post(c(-12, -10), 12, 11, c(625, 600)) + ni <- region_prob_continuous(crit_cont(), pt, pc, "NI") + expect_equal(ni$go, c(0.5, 0.697142834497), tolerance = 1e-9) + expect_equal(ni$nogo, c(0.0878402872647, 0.0248900866027), + tolerance = 1e-9) + mm <- region_prob_continuous(crit_cont(), pt, pc, "MM") + expect_equal(mm$go, c(0.5, 0.697418373575), tolerance = 1e-9) + expect_equal(mm$nogo, c(0.0877885562533, 0.0249788420729), + tolerance = 1e-9) +}) + +test_that("region_prob_continuous() matches the references (predictive)", { + # The squared scale of the predictive distribution of the mean of m + # future subjects is sigma^2 (1 / kappa + 1 / m) + c5 <- region_prob_continuous(crit_c5(), post(18, 12, 11, 625), + post(-12, 12, 11, 625), "NI") + expect_equal(c5$go, 0.938493080615, tolerance = 1e-9) + expect_equal(c5$nogo, 0.0615069193852, tolerance = 1e-9) + # Hypothetical control of design C6: sigma^2 = r sigma_nt^2 = 2 * 144 + c6 <- region_prob_continuous(crit_c6(), post(9, 15, 14, 144), + post(0, 15, 14, 288), "NI") + expect_equal(c6$go, 0.7096513743, tolerance = 1e-9) + expect_equal(c6$nogo, 0.2903486257, tolerance = 1e-9) + mm <- region_prob_continuous(crit_c6(), post(9, 15, 14, 144), + post(0, 15, 14, 288), "MM") + expect_equal(mm$go, 0.709872074443, tolerance = 1e-9) + expect_equal(mm$nogo, 0.290127925557, tolerance = 1e-9) +}) + +test_that("region_prob_continuous() estimates both regions from the same draws", { + n_mc <- 20000L + se <- function(p) sqrt(p * (1 - p) / n_mc) + set.seed(11) + pred <- region_prob_continuous(crit_c5(), post(c(18, 18), 12, 11, 625), + post(-12, 12, 11, 625), "MC", n_mc) + # Predictive criterion: the two probabilities add up to 1 for every draw + expect_equal(pred$go + pred$nogo, c(1, 1), tolerance = 1e-14) + expect_lt(max(abs(pred$go - 0.938493080615)), 4.5 * se(0.9385)) + # Posterior criterion: the regions are disjoint + set.seed(12) + pst <- region_prob_continuous(crit_cont(), post(c(18, 25), 12, 11, + c(625, 400)), + post(c(-12, -10), 12, 11, c(625, 600)), "MC", + n_mc) + expect_true(all(pst$go + pst$nogo <= 1)) + expect_lt(max(abs(pst$go - c(0.5, 0.697142834497))), 4.5 * se(0.5)) + expect_lt(max(abs(pst$nogo - c(0.0878402872647, 0.0248900866027))), + 4.5 * se(0.0878)) + # Reproducible with the seed + set.seed(12) + again <- region_prob_continuous(crit_cont(), post(c(18, 25), 12, 11, + c(625, 400)), + post(c(-12, -10), 12, 11, c(625, 600)), + "MC", n_mc) + expect_identical(again, pst) +}) + +test_that("region_prob_continuous() uses the t distribution for a fixed control", { + # Reference: Python_reference/ref_fixed_tte_qdm.py, designs C7 and C8 + p <- region_prob_continuous(crit_cont(), post(25, 12, 11, 400), NULL, + "NI", fixed = -10) + expect_equal(p$go, 0.797515237746, tolerance = 1e-10) + expect_equal(p$nogo, 0.00264736615439, tolerance = 1e-10) + # The method is not used + expect_identical(region_prob_continuous(crit_cont(), post(25, 12, 11, 400), + NULL, "MC", nMC = 10L, + fixed = -10), p) + cr <- criterion_predictive(5, m_t = 30, gamma_go = 0.7, gamma_nogo = 0.6) + q <- region_prob_continuous(cr, post(c(9, 0), 15, 14, 144), NULL, "MM", + fixed = 0) + expect_equal(q$go[1], 0.845153264581, tolerance = 1e-10) + expect_equal(q$go + q$nogo, c(1, 1), tolerance = 1e-12) + expect_equal(q$go[2], stats::pt(5 / sqrt(144 * (1 / 15 + 1 / 30)), 14, + lower.tail = FALSE)) +}) diff --git a/tests/testthat/test-region_prob_continuous2.R b/tests/testthat/test-region_prob_continuous2.R new file mode 100644 index 0000000..7ca9031 --- /dev/null +++ b/tests/testthat/test-region_prob_continuous2.R @@ -0,0 +1,152 @@ +# References: Python_reference/ref_continuous2_qdm.py, section C (moment +# matching: Theorem 3 of Yamaguchi, Homma, Takeda and Maruo (submitted) with +# rectangle probabilities of the bivariate t distribution by adaptive +# quadrature; +# exact probabilities by Monte Carlo simulation with 2e7 draws). Regions +# R1 to R9 of the nine-region grid; the predictive designs K3 and K6 use +# R1, R3, R7 and R9. +ref_dist_cont2 <- list( + K1_t = list( + loc = matrix(c(18, 2.5), 1L), df = 10, + scale = matrix(c(330, 11, 2.29166666666667), 1L) + ), + K1_c = list( + loc = matrix(c(-10, -1), 1L), df = 10, + scale = matrix(c(449.166666666667, 7.7, 3.3), 1L) + ), + K2_t = list( + loc = matrix(c(4.98338870431894, 1.99667774086379), 1L), df = 33, + scale = matrix(c(193.297585517318, 5.62116011161827, 1.08738514826748), 1L) + ), + K2_c = list( + loc = matrix(c(-10, -1), 1L), df = 33, + scale = matrix(c(170.668478808014, 4.28495922681969, 1.26975737440854), 1L) + ), + K3_t = list( + loc = matrix(c(2.37257142857143, 1.00118633540373), 1L), df = 19, + scale = matrix(c(1.67795549308551, 0.263590024497268, 0.60288915604117), 1L) + ), + K3_c = list( + loc = matrix(c(-0.67910447761194, -1.32089552238806), 1L), df = 23, + scale = matrix(c(1.30581977910577, 0.095846627989191, + 0.600695357734365), 1L) + ), + K4_t = list( + loc = matrix(c(4, 1.5), 1L), df = 13, + scale = matrix(c(64.6153846153846, 3.23076923076923, 0.646153846153846), 1L) + ), + K4_c = list( + loc = matrix(c(-10, -1), 1L), df = 13, + scale = matrix(c(96.9230769230769, 4.84615384615385, 0.969230769230769), 1L) + ), + K5_t = list( + loc = matrix(c(2.97520661157025, 1), 1L), df = 15, + scale = matrix(c(376.17571659495, 10.0826446280992, 2.03168044077135), 1L) + ), + K5_c = list( + loc = matrix(c(-10, -1), 1L), df = 8, + scale = matrix(c(581.875, 12.46875, 2.96875), 1L) + ), + K6_t = list( + loc = matrix(c(7, 2), 1L), df = 13, + scale = matrix(c(9.87179487179487, -0.592307692307692, + 0.394871794871795), 1L) + ), + K6_c = list( + loc = matrix(c(0, 0), 1L), df = 13, + scale = matrix(c(21.5384615384615, -1.29230769230769, + 0.861538461538462), 1L) + ) +) + +ref_mm_cont2 <- list( + K1 = c(0.560892392845125, 0.0741296786423965, 0.0922152459136311, + 0.034539315250446, 0.00700495838687196, 0.0104135124279007, + 0.128560384036125, 0.0316286768388945, 0.0606158356586099), + K2 = c(0.487770318626615, 0.0761832877719272, 0.0371748442271904, + 0.0670087840509609, 0.0173111723035729, 0.0105685362428432, + 0.182835577836786, 0.0664713667612531, 0.0546761121788512), + K3 = c(0.626051840857435, 0, 0.0991345612327038, 0, 0, 0, 0.213908233621874, + 0, 0.060905364287987), + K4 = c(0.475440903771989, 0.104478331943068, 0.0380887134173634, + 0.0739441049062476, 0.0374467301236908, 0.0200135306654595, + 0.0968179703715022, 0.0784964605938997, 0.0752732542067799), + K5 = c(0.320405184954998, 0.0837818501873882, 0.132197515292659, + 0.0286780743996835, 0.0109233687877224, 0.0206147670294312, + 0.150916740645318, 0.0694518911782248, 0.183030607524575), + K6 = c(0.478623343701189, -6.93889390390723e-18, 0.154954023476356, 0, 0, 0, + 0.322812062562545, 0, 0.0436105702599108) +) + +test_that("region_prob_continuous2() computes moment-matching probabilities", { + for (name in names(ref_mm_cont2)) { + crit <- ref_design_cont2(name)$criterion + dt <- ref_dist_cont2[[paste0(name, "_t")]] + dc <- ref_dist_cont2[[paste0(name, "_c")]] + if (crit$type == "posterior") { + p <- region_prob_continuous2(crit, dt, dc, as.list(1:9), "MM") + expect_equal(p[1L, ], ref_mm_cont2[[name]], tolerance = 1e-9, + info = name) + } else { + p <- region_prob_continuous2(crit, dt, dc, as.list(1:4), "MM") + expect_equal(p[1L, ], ref_mm_cont2[[name]][c(1, 3, 7, 9)], + tolerance = 1e-9, info = name) + } + } + # Unions of regions, and one-row distributions recycled + crit <- ref_design_cont2("K1")$criterion + dt <- ref_dist_cont2$K1_t + dt2 <- list(loc = rbind(dt$loc, dt$loc + c(5, 1)), + scale = rbind(dt$scale, dt$scale), df = dt$df) + p <- region_prob_continuous2(crit, dt2, ref_dist_cont2$K1_c, + list(1:3, c(1L, 4L, 7L), 1:9), "MM") + expect_identical(dim(p), c(2L, 3L)) + expect_equal(p[1L, ], c(sum(ref_mm_cont2$K1[1:3]), + sum(ref_mm_cont2$K1[c(1, 4, 7)]), 1), + tolerance = 1e-9) + # A larger treatment mean makes P(theta_1 > TV_1) larger + expect_gt(p[2L, 1L], p[1L, 1L]) +}) + +test_that("region_prob_continuous2() estimates probabilities by Monte Carlo", { + ref_mc <- list( + K1 = c(0.5604494, 0.0740703, 0.0923529, 0.034412, 0.007025, 0.01048045, + 0.12867035, 0.03174825, 0.06079135), + K3 = c(0.62616815, 0, 0.09916835, 0, 0, 0, 0.2137463, 0, 0.0609172) + ) + n_mc <- 200000L + for (name in names(ref_mc)) { + crit <- ref_design_cont2(name)$criterion + dt <- ref_dist_cont2[[paste0(name, "_t")]] + dc <- ref_dist_cont2[[paste0(name, "_c")]] + n_reg <- if (crit$type == "posterior") 9L else 4L + set.seed(11) + p <- region_prob_continuous2(crit, dt, dc, as.list(seq_len(n_reg)), "MC", + n_mc)[1L, ] + ref <- ref_mc[[name]] + if (n_reg == 4L) { + ref <- ref[c(1, 3, 7, 9)] + } + se <- sqrt(ref * (1 - ref) * (1 / n_mc + 1 / 2e7)) + expect_true(all(abs(p - ref) <= 4.5 * se + 1e-12), info = name) + expect_equal(sum(p), 1, tolerance = 1e-12) + } +}) + +test_that("region_prob_continuous2() is exact for a fixed control", { + # Python_reference/ref_fixed_tte_qdm.py, design KF1: the treatment mean has + # the distribution t_8((5, 2), 9 S / 80); the control is fixed at (-10, -1) + crit <- ref_design_cont2("KF1")$criterion + S <- c(6400, 190, 36) + dt <- list(loc = matrix(c(5, 2), 1L), scale = matrix(9 * S / 80, 1L), + df = 8) + ref <- c(0.448613893688, 0.0645842074429, 0.0583932223851, 0.04589185081, + 0.0113918100151, 0.0115909475048, 0.189182932775, + 0.0656248379891, 0.104726297391) + p <- region_prob_continuous2(crit, dt, NULL, as.list(1:9), "MM", + fixed = c(-10, -1)) + expect_equal(p[1L, ], ref, tolerance = 1e-9) + # The method is not used + expect_identical(region_prob_continuous2(crit, dt, NULL, as.list(1:9), + "MC", 10L, fixed = c(-10, -1)), p) +}) diff --git a/tests/testthat/test-region_prob_tte.R b/tests/testthat/test-region_prob_tte.R new file mode 100644 index 0000000..5a63a13 --- /dev/null +++ b/tests/testthat/test-region_prob_tte.R @@ -0,0 +1,36 @@ +test_that("region_prob_tte() matches the references (posterior)", { + # Python_reference/ref_fixed_tte_qdm.py, designs T1 and T2 + p1 <- region_prob_tte(ref_design_tte("T1"), list(shape = 6.1, rate = 151), + NULL) + expect_equal(c(p1$go, p1$nogo), unname(ref_prob_tte$T1), tolerance = 1e-10) + p2 <- region_prob_tte(ref_design_tte("T2"), + list(shape = c(5.1, 5.1), rate = c(41, 41)), + list(shape = 9.1, rate = 36)) + expect_equal(p2$go, rep(ref_prob_tte$T2[["go"]], 2), tolerance = 1e-10) + expect_equal(p2$nogo, rep(ref_prob_tte$T2[["nogo"]], 2), tolerance = 1e-10) +}) + +test_that("region_prob_tte() estimates predictive probabilities", { + # Complete follow-up of the future study: closed forms + # (Python_reference/ref_fixed_tte_qdm.py, designs T3 and T4) + n_mc <- 20000L + set.seed(1) + p3 <- region_prob_tte(ref_design_tte("T3", nMC = n_mc), + list(shape = 6.1, rate = 71), NULL) + ref3 <- ref_prob_tte$T3[["go"]] + expect_lt(abs(p3$go - ref3), 4.5 * sqrt(ref3 * (1 - ref3) / n_mc)) + expect_identical(p3$nogo, 1 - p3$go) + set.seed(2) + p4 <- region_prob_tte(ref_design_tte("T4", nMC = n_mc), + list(shape = 6.1, rate = 71), + list(shape = 9.1, rate = 61)) + ref4 <- ref_prob_tte$T4[["go"]] + expect_lt(abs(p4$go - ref4), 4.5 * sqrt(ref4 * (1 - ref4) / n_mc)) + # Several distributions; the control parameters are recycled + set.seed(3) + p5 <- region_prob_tte(ref_design_tte("T4", nMC = 200L), + list(shape = c(6.1, 30.1), rate = c(71, 71)), + list(shape = 9.1, rate = 61)) + expect_length(p5$go, 2L) + expect_gt(p5$go[1], p5$go[2]) +}) diff --git a/tests/testthat/test-region_sets.R b/tests/testthat/test-region_sets.R new file mode 100644 index 0000000..89f51f2 --- /dev/null +++ b/tests/testthat/test-region_sets.R @@ -0,0 +1,14 @@ +test_that("region_sets() gives the regions of the criteria", { + cr <- criterion_posterior(c(0.2, 0.1), c(0, 0), 0.5, 0.5, + go_regions = c(1, 2), nogo_regions = 9) + expect_identical(region_sets(cr), list(go = list(1:2), nogo = list(9L))) + mp <- criterion_posterior(c(0.2, 0.1), c(0, 0), 0.5, 0.5, rule = "or") + expect_identical(region_sets(mp), + list(go = list(1:3, c(1L, 4L, 7L)), + nogo = list(7:9, c(3L, 6L, 9L)))) + mq <- criterion_predictive(c(0, 0), m_t = 10, gamma_go = 0.5, + gamma_nogo = 0.5, rule = "and") + expect_identical(region_sets(mq), + list(go = list(1:2, c(1L, 3L)), + nogo = list(3:4, c(2L, 4L)))) +}) diff --git a/tests/testthat/test-sample_column.R b/tests/testthat/test-sample_column.R new file mode 100644 index 0000000..8b4f549 --- /dev/null +++ b/tests/testthat/test-sample_column.R @@ -0,0 +1,14 @@ +test_that("sample_column() selects the column of a scenario", { + expect_identical(sample_column(c(0.1, 0.2), 2L), c(0.1, 0.2)) + m <- cbind(c(1, 2), c(3, 4)) + expect_identical(sample_column(m, 2L), c(3, 4)) +}) + +test_that("sample_column() handles lists and shared matrices", { + m <- cbind(c(1, 2), c(3, 4)) + expect_identical(sample_column(m, 2L, per_scenario = FALSE), m) + expect_identical(sample_column(list(m, m * 2), 2L, per_scenario = TRUE), + list(c(3, 4), c(6, 8))) + expect_identical(sample_column(list(m, m), 1L, per_scenario = FALSE), + list(m, m)) +}) diff --git a/tests/testthat/test-sample_weights.R b/tests/testthat/test-sample_weights.R new file mode 100644 index 0000000..32b6883 --- /dev/null +++ b/tests/testthat/test-sample_weights.R @@ -0,0 +1,5 @@ +test_that("sample_weights() returns the weights of one scenario", { + expect_identical(sample_weights(list(weights = cbind(1:2, 3:4)), 2L), 3:4) + s <- list(weights_t = cbind(1:2, 3:4), weights_c = cbind(5:6, 7:8)) + expect_identical(sample_weights(s, 1L), list(t = 1:2, c = 5:6)) +}) diff --git a/tests/testthat/test-scenario_columns.R b/tests/testthat/test-scenario_columns.R new file mode 100644 index 0000000..800b704 --- /dev/null +++ b/tests/testthat/test-scenario_columns.R @@ -0,0 +1,55 @@ +test_that("scenario_columns() lists the columns required by a binary design", { + expect_identical(scenario_columns(ref_design("D1")), + list(names = c("pi_t", "pi_c"), lower = c(0, 0), + upper = c(1, 1), lower_open = c(FALSE, FALSE), + upper_open = c(FALSE, FALSE))) + expect_identical(scenario_columns(ref_design("D3")), + list(names = "pi_t", lower = 0, upper = 1, + lower_open = FALSE, upper_open = FALSE)) + expect_identical(scenario_columns(ref_design("D4"))$names, "pi_t") +}) + +test_that("scenario_columns() lists the columns required by a continuous design", { + expect_identical(scenario_columns(ref_design_cont("C1")), + list(names = c("mu_t", "sd_t", "mu_c", "sd_c"), + lower = c(-Inf, 0, -Inf, 0), upper = rep(Inf, 4), + lower_open = c(FALSE, TRUE, FALSE, TRUE), + upper_open = rep(FALSE, 4))) + expect_identical(scenario_columns(ref_design_cont("C3")), + list(names = c("mu_t", "sd_t"), lower = c(-Inf, 0), + upper = c(Inf, Inf), lower_open = c(FALSE, TRUE), + upper_open = c(FALSE, FALSE))) + expect_identical(scenario_columns(ref_design_cont("C4"))$names, + c("mu_t", "sd_t")) +}) + +test_that("scenario_columns() lists the columns for two binary endpoints", { + cols <- scenario_columns(ref_design_bin2("B1")) + expect_identical(cols$names, c("pi_t1", "pi_t2", "rho_t", "pi_c1", + "pi_c2", "rho_c")) + expect_identical(cols$lower, rep(c(0, 0, -1), 2)) + expect_identical(cols$upper_open, rep(c(TRUE, TRUE, FALSE), 2)) + expect_identical(scenario_columns(ref_design_bin2("B7"))$names, + c("pi_t1", "pi_t2", "rho_t")) +}) + +test_that("scenario_columns() lists the columns for two continuous endpoints", { + cols <- scenario_columns(ref_design_cont2("K1")) + expect_identical(cols$names, c("mu_t1", "mu_t2", "sd_t1", "sd_t2", "rho_t", + "mu_c1", "mu_c2", "sd_c1", "sd_c2", + "rho_c")) + expect_identical(cols$lower, rep(c(-Inf, -Inf, 0, 0, -1), 2)) + expect_identical(cols$lower_open, rep(c(FALSE, FALSE, TRUE, TRUE, TRUE), 2)) + expect_identical(cols$upper_open, + rep(c(FALSE, FALSE, FALSE, FALSE, TRUE), 2)) + expect_identical(scenario_columns(ref_design_cont2("K4"))$names, + c("mu_t1", "mu_t2", "sd_t1", "sd_t2", "rho_t")) +}) + +test_that("scenario_columns() lists the columns for a time-to-event design", { + expect_identical(scenario_columns(ref_design_tte("T2")), + list(names = c("median_t", "median_c"), lower = c(0, 0), + upper = c(Inf, Inf), lower_open = c(TRUE, TRUE), + upper_open = c(FALSE, FALSE))) + expect_identical(scenario_columns(ref_design_tte("T1"))$names, "median_t") +}) diff --git a/tests/testthat/test-select_gamma.R b/tests/testthat/test-select_gamma.R new file mode 100644 index 0000000..e404f12 --- /dev/null +++ b/tests/testthat/test-select_gamma.R @@ -0,0 +1,9 @@ +test_that("select_gamma() returns the smallest threshold meeting the target", { + grid <- c(0.1, 0.2, 0.3, 0.4) + expect_identical(select_gamma(grid, c(0.5, 0.2, 0.05, 0.01), 0.05), 0.3) + expect_identical(select_gamma(grid, c(0.5, 0.2, 0.05 + 1e-13, 0.01), 0.05), + 0.3) + expect_identical(select_gamma(grid, c(0.5, 0.2, 0.1, 0.06), 0.05), + NA_real_) + expect_identical(select_gamma(grid, c(0.01, 0, 0, 0), 0.05), 0.1) +}) diff --git a/tests/testthat/test-shade_color.R b/tests/testthat/test-shade_color.R new file mode 100644 index 0000000..2290cd3 --- /dev/null +++ b/tests/testthat/test-shade_color.R @@ -0,0 +1,30 @@ +# Expected values from Python_reference/ref_plot_colors.py: linear +# interpolation in RGB between white (probability 0) and the color +# (probability 1), rounded to integers. +test_that("shade_color() interpolates between white and the color", { + p <- c(0, 0.2, 0.55, 0.8, 1) + expect_identical(shade_color(p, "#658D1B"), + c("#FFFFFF", "#E0E8D1", "#AAC082", "#84A449", "#658D1B")) + expect_identical(shade_color(p, "#D91E49"), + c("#FFFFFF", "#F7D2DB", "#EA839B", "#E14B6D", "#D91E49")) + expect_identical(shade_color(p, "#939597"), + c("#FFFFFF", "#E9EAEA", "#C4C5C6", "#A9AAAC", "#939597")) + expect_identical(shade_color(p, "#E69F00"), + c("#FFFFFF", "#FAECCC", "#F1CA73", "#EBB233", "#E69F00")) + expect_identical(shade_color(p, "black"), + c("#FFFFFF", "#CCCCCC", "#737373", "#333333", "#000000")) + expect_identical(shade_color(p, "darkgreen"), + c("#FFFFFF", "#CCE0CC", "#73AA73", "#338333", "#006400")) +}) + +test_that("shade_color() takes one color per probability", { + expect_identical( + shade_color(c(0.2, NA, 0.8, 1), + c("#658D1B", "#D91E49", "black", "darkgreen")), + c("#E0E8D1", "#FFFFFF", "#333333", "#006400") + ) + # Probabilities outside [0, 1] are clipped (without clipping, -0.2 and + # 1.3 would give the channel values 306 and -77) + expect_identical(shade_color(c(-0.2, 1.3), "black"), + c("#FFFFFF", "#000000")) +}) diff --git a/tests/testthat/test-simulate_counts_binary2.R b/tests/testthat/test-simulate_counts_binary2.R new file mode 100644 index 0000000..92dd0d0 --- /dev/null +++ b/tests/testthat/test-simulate_counts_binary2.R @@ -0,0 +1,11 @@ +test_that("simulate_counts_binary2() assigns subjects to the cells", { + u <- rbind(c(0.05, 0.25, 0.55, 0.95), c(0.1, 0.1, 0.1, 0.1)) + x <- simulate_counts_binary2(u, c(0.2, 0.3, 0.4, 0.1)) + expect_identical(x, matrix(c(1L, 4L, 1L, 0L, 1L, 0L, 1L, 0L), 2L, + dimnames = list(NULL, c("00", "01", "10", + "11")))) + set.seed(1) + big <- simulate_counts_binary2(matrix(runif(4e4), 1L), c(0.1, 0.2, 0.3, + 0.4)) + expect_equal(as.numeric(big) / 4e4, c(0.1, 0.2, 0.3, 0.4), tolerance = 0.03) +}) diff --git a/tests/testthat/test-single-endpoint.R b/tests/testthat/test-single-endpoint.R deleted file mode 100644 index 3b4f90a..0000000 --- a/tests/testthat/test-single-endpoint.R +++ /dev/null @@ -1,682 +0,0 @@ -# Tests for single-endpoint functions (binary and continuous) - -# --------------------------------------------------------------------------- -# pbayespostpred1bin -# Signature: pbayespostpred1bin(prob, design, theta0, n_t, n_c, y_t, y_c, -# a_t, a_c, b_t, b_c, m_t, m_c, z, ne_t, ne_c, ye_t, ye_c, alpha0e_t, alpha0e_c, -# lower.tail) -# Note: no nMC argument; y_t and y_c must have the same length -# --------------------------------------------------------------------------- - -test_that("pbayespostpred1bin posterior controlled returns scalar in [0, 1]", { - result <- pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 12, y_c = 8, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1bin predictive controlled returns scalar in [0, 1]", { - result <- pbayespostpred1bin( - prob = 'predictive', design = 'controlled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 12, y_c = 8, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = 30, m_c = 30, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1bin posterior uncontrolled returns scalar in [0, 1]", { - result <- pbayespostpred1bin( - prob = 'posterior', design = 'uncontrolled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 12, y_c = NULL, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = 5L, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1bin posterior external returns scalar in [0, 1]", { - result <- pbayespostpred1bin( - prob = 'posterior', design = 'external', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 12, y_c = 8, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = 30, ne_c = 30, ye_t = 10, ye_c = 6, alpha0e_t = 0.5, alpha0e_c = 0.5, - lower.tail = FALSE - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1bin vectorised y_t and y_c returns correct length", { - result <- pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 8:12, y_c = rep(6, 5), - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE - ) - expect_length(result, 5L) - expect_true(all(result >= 0 & result <= 1)) -}) - -test_that("pbayespostpred1bin input validation works", { - # y_t > n_t - expect_error(pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 25, y_c = 8, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - )) - # m_t missing for predictive - expect_error(pbayespostpred1bin( - prob = 'predictive', design = 'controlled', theta0 = 0.15, - n_t = 20, n_c = 20, y_t = 12, y_c = 8, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - )) -}) - -# --------------------------------------------------------------------------- -# pbayespostpred1cont -# --------------------------------------------------------------------------- - -test_that("pbayespostpred1cont posterior vague NI returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont posterior vague MM returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'MM', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont NI and MM agree closely", { - p_ni <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - p_mm <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', CalcMethod = 'MM', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_equal(p_ni, p_mm, tolerance = 0.02) -}) - -test_that("pbayespostpred1cont predictive NI returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'predictive', design = 'controlled', prior = 'vague', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = 30, m_c = 30, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont N-Inv-Chisq prior returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'N-Inv-Chisq', - CalcMethod = 'NI', theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 3, mu0_c = 1, sigma0_t = 1.5, sigma0_c = 1.2, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont input validation works", { - # m_t missing for predictive - expect_error(pbayespostpred1cont( - prob = 'predictive', design = 'controlled', prior = 'vague', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - )) -}) - -test_that("pbayespostpred1cont external N-Inv-Chisq posterior returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'external', prior = 'N-Inv-Chisq', - CalcMethod = 'MM', theta0 = 1, nMC = NULL, - n_t = 20, n_c = 10, m_t = NULL, m_c = NULL, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 0, mu0_c = 0, sigma0_t = 30, sigma0_c = 30, - bar_y_t = 5, s_t = 20, bar_y_c = 2, s_c = 18, r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = -2, se_c = 25 - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont external N-Inv-Chisq predictive returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'predictive', design = 'external', prior = 'N-Inv-Chisq', - CalcMethod = 'MM', theta0 = 0, nMC = NULL, - n_t = 20, n_c = 10, m_t = 30, m_c = 30, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 0, mu0_c = 0, sigma0_t = 30, sigma0_c = 30, - bar_y_t = 5, s_t = 20, bar_y_c = 2, s_c = 18, r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = -2, se_c = 25 - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont external N-Inv-Chisq with both arms returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'external', prior = 'N-Inv-Chisq', - CalcMethod = 'NI', theta0 = 1, nMC = NULL, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = 5, kappa0_c = 5, nu0_t = 5, nu0_c = 5, - mu0_t = 3, mu0_c = 1, sigma0_t = 1.5, sigma0_c = 1.2, - bar_y_t = 3, s_t = 1.5, bar_y_c = 1, s_c = 1.2, r = NULL, - ne_t = 20L, ne_c = 20L, alpha0e_t = 0.5, alpha0e_c = 0.5, - bar_ye_t = 3, se_t = 1.5, bar_ye_c = 1, se_c = 1.2 - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont posterior uncontrolled vague MM returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', CalcMethod = 'MM', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 1.0, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = NULL, s_c = NULL, r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont posterior uncontrolled N-Inv-Chisq NI returns scalar in [0, 1]", { - result <- pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Chisq', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = 2, kappa0_c = NULL, nu0_t = 5, nu0_c = NULL, - mu0_t = 3.0, mu0_c = 1.0, sigma0_t = 1.5, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = NULL, s_c = NULL, r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbayespostpred1cont uncontrolled NI and MM agree closely", { - p_ni <- pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', CalcMethod = 'NI', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 1.0, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = NULL, s_c = NULL, r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - p_mm <- pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', CalcMethod = 'MM', - theta0 = 1, nMC = NULL, - n_t = 15, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 1.0, sigma0_t = NULL, sigma0_c = NULL, - bar_y_t = 3, s_t = 1.5, bar_y_c = NULL, s_c = NULL, r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL - ) - expect_equal(p_ni, p_mm, tolerance = 0.02) -}) - -# --------------------------------------------------------------------------- -# pbayesdecisionprob1bin -# Note: no nMC argument -# --------------------------------------------------------------------------- - -test_that("pbayesdecisionprob1bin posterior controlled returns correct class", { - result <- pbayesdecisionprob1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.2, theta_MAV = 0.05, theta_NULL = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = c(0.3, 0.5), pi_c = rep(0.2, 2), - n_t = 15, n_c = 15, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "pbayesdecisionprob1bin") - df <- as.data.frame(result) - expect_true(all(c("pi_t", "Go", "Gray", "NoGo") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob1bin predictive controlled returns correct class", { - result <- pbayesdecisionprob1bin( - prob = 'predictive', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.15, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = c(0.3, 0.5), pi_c = rep(0.2, 2), - n_t = 15, n_c = 15, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = 40, m_c = 40, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "pbayesdecisionprob1bin") - df <- as.data.frame(result) - expect_equal(nrow(df), 2L) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob1bin input validation works", { - # theta_TV missing for posterior - expect_error(pbayesdecisionprob1bin( - prob = 'posterior', design = 'controlled', - theta_TV = NULL, theta_MAV = 0.05, theta_NULL = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = 0.3, pi_c = 0.2, n_t = 15, n_c = 15, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - )) -}) - -test_that("pbayesdecisionprob1bin posterior uncontrolled returns correct class", { - result <- pbayesdecisionprob1bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV = 0.2, theta_MAV = 0.05, theta_NULL = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - pi_t = c(0.3, 0.5), pi_c = NULL, - n_t = 15, n_c = 15, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = 3L, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "pbayesdecisionprob1bin") - df <- as.data.frame(result) - expect_true(all(c("pi_t", "Go", "Gray", "NoGo") %in% names(df))) - expect_false("pi_c" %in% names(df)) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -# --------------------------------------------------------------------------- -# pbayesdecisionprob1cont -# --------------------------------------------------------------------------- - -test_that("pbayesdecisionprob1cont posterior vague MM returns correct class", { - set.seed(1) - result <- pbayesdecisionprob1cont( - nsim = 20L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.5, theta_MAV = 0.5, theta_NULL = NULL, nMC = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = c(2, 3), mu_c = c(0, 0), sigma_t = 1.5, sigma_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 1 - ) - expect_s3_class(result, "pbayesdecisionprob1cont") - df <- as.data.frame(result) - expect_true(all(c("mu_t", "mu_c", "Go", "Gray", "NoGo") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob1cont predictive vague MM returns correct class", { - set.seed(2) - result <- pbayesdecisionprob1cont( - nsim = 20L, prob = 'predictive', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 1, nMC = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 15, n_c = 15, m_t = 30, m_c = 30, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = c(2, 3), mu_c = c(0, 0), sigma_t = 1.5, sigma_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 2 - ) - expect_s3_class(result, "pbayesdecisionprob1cont") - df <- as.data.frame(result) - expect_equal(nrow(df), 2L) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob1cont input validation works", { - # theta_TV missing for posterior - expect_error(pbayesdecisionprob1cont( - nsim = 10L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = 0.5, theta_NULL = NULL, nMC = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 15, n_c = 15, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = 2, mu_c = 0, sigma_t = 1.5, sigma_c = 1.2, r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 1 - )) -}) - - -test_that("pbayesdecisionprob1cont posterior uncontrolled vague MM returns correct class", { - result <- pbayesdecisionprob1cont( - nsim = 20L, prob = 'posterior', design = 'uncontrolled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.5, theta_MAV = 0.5, theta_NULL = NULL, nMC = NULL, - gamma_go = 0.8, gamma_nogo = 0.2, - n_t = 15, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 0.0, sigma0_t = NULL, sigma0_c = NULL, - mu_t = c(2, 3), mu_c = NULL, sigma_t = 1.5, sigma_c = NULL, r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 1 - ) - expect_s3_class(result, "pbayesdecisionprob1cont") - df <- as.data.frame(result) - expect_true(all(c("mu_t", "Go", "Gray", "NoGo") %in% names(df))) - expect_false("mu_c" %in% names(df)) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -# --------------------------------------------------------------------------- -# getgamma1bin -# --------------------------------------------------------------------------- - -test_that("getgamma1bin posterior controlled returns correct class and structure", { - result <- getgamma1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "getgamma1bin") - expect_true(all(c("gamma_go", "gamma_nogo", "PrGo_opt", "PrNoGo_opt", - "target_go", "target_nogo", "grid_results") %in% names(result))) - expect_true(all(c("gamma_grid", "PrGo_grid", "PrNoGo_grid") %in% - names(result$grid_results))) -}) - -test_that("getgamma1bin posterior controlled gamma values in (0, 1) or NA", { - result <- getgamma1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - if (!is.na(result$gamma_go)) expect_true(result$gamma_go > 0 && result$gamma_go < 1) - if (!is.na(result$gamma_nogo)) expect_true(result$gamma_nogo > 0 && result$gamma_nogo < 1) - expect_equal(length(result$grid_results$PrGo_grid), length(result$grid_results$gamma_grid)) - expect_equal(length(result$grid_results$PrNoGo_grid), length(result$grid_results$gamma_grid)) -}) - -test_that("getgamma1bin posterior uncontrolled returns correct class", { - result <- getgamma1bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = NULL, - pi_t_nogo = 0.15, pi_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = 3L, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "getgamma1bin") -}) - -test_that("getgamma1bin predictive controlled returns correct class", { - result <- getgamma1bin( - prob = 'predictive', design = 'controlled', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.10, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = 30L, m_c = 30L, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_s3_class(result, "getgamma1bin") - if (!is.na(result$PrGo_opt)) - expect_true(result$PrGo_opt >= 0 && result$PrGo_opt <= 1) - if (!is.na(result$PrNoGo_opt)) - expect_true(result$PrNoGo_opt >= 0 && result$PrNoGo_opt <= 1) -}) - -test_that("getgamma1bin external design returns correct class", { - result <- getgamma1bin( - prob = 'posterior', design = 'external', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = 15L, ne_c = 15L, ye_t = 6L, ye_c = 4L, alpha0e_t = 0.5, alpha0e_c = 0.5 - ) - expect_s3_class(result, "getgamma1bin") -}) - -test_that("getgamma1bin PrGo_grid and PrNoGo_grid values in [0, 1]", { - result <- getgamma1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL - ) - expect_true(all(result$grid_results$PrGo_grid >= 0 & result$grid_results$PrGo_grid <= 1)) - expect_true(all(result$grid_results$PrNoGo_grid >= 0 & result$grid_results$PrNoGo_grid <= 1)) -}) - -test_that("getgamma1bin input validation: invalid prob", { - expect_error(getgamma1bin( - prob = 'bayes', design = 'controlled', - theta_TV = 0.20, theta_MAV = 0.05, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.15, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, a_c = 0.5, b_t = 0.5, b_c = 0.5 - )) -}) - -# --------------------------------------------------------------------------- -# getgamma1cont -# --------------------------------------------------------------------------- - -test_that("getgamma1cont posterior vague MM controlled returns correct class and structure", { - result <- getgamma1cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 0.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 1.0, mu_c_nogo = 0.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 1L - ) - expect_s3_class(result, "getgamma1cont") - expect_true(all(c("gamma_go", "gamma_nogo", "PrGo_opt", "PrNoGo_opt", - "target_go", "target_nogo", "grid_results") %in% names(result))) - expect_true(all(c("gamma_grid", "PrGo_grid", "PrNoGo_grid") %in% - names(result$grid_results))) -}) - -test_that("getgamma1cont posterior vague MM grid values in [0, 1]", { - result <- getgamma1cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 0.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 1.0, mu_c_nogo = 0.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 1L - ) - expect_true(all(result$grid_results$PrGo_grid >= 0 & result$grid_results$PrGo_grid <= 1)) - expect_true(all(result$grid_results$PrNoGo_grid >= 0 & result$grid_results$PrNoGo_grid <= 1)) - expect_equal(length(result$grid_results$PrGo_grid), length(result$grid_results$gamma_grid)) -}) - -test_that("getgamma1cont posterior uncontrolled vague MM returns correct class", { - result <- getgamma1cont( - nsim = 50L, prob = 'posterior', design = 'uncontrolled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = NULL, sigma_t_go = 1.5, sigma_c_go = NULL, - mu_t_nogo = 1.0, mu_c_nogo = NULL, sigma_t_nogo = 1.5, sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = NULL, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 0.0, sigma0_t = NULL, sigma0_c = NULL, - r = 1.0, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 2L - ) - expect_s3_class(result, "getgamma1cont") -}) - -test_that("getgamma1cont predictive vague MM returns correct class", { - result <- getgamma1cont( - nsim = 50L, prob = 'predictive', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = NULL, theta_MAV = NULL, theta_NULL = 0.0, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 0.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 1.0, mu_c_nogo = 0.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, m_t = 30L, m_c = 30L, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, seed = 3L - ) - expect_s3_class(result, "getgamma1cont") - if (!is.na(result$PrGo_opt)) - expect_true(result$PrGo_opt >= 0 && result$PrGo_opt <= 1) - if (!is.na(result$PrNoGo_opt)) - expect_true(result$PrNoGo_opt >= 0 && result$PrNoGo_opt <= 1) -}) - -test_that("getgamma1cont input validation: invalid nsim", { - expect_error(getgamma1cont( - nsim = -1L, prob = 'posterior', design = 'controlled', - prior = 'vague', CalcMethod = 'MM', - theta_TV = 1.0, theta_MAV = 0.0, theta_NULL = NULL, nMC = NULL, - mu_t_go = 1.0, mu_c_go = 0.0, sigma_t_go = 1.5, sigma_c_go = 1.5, - mu_t_nogo = 1.0, mu_c_nogo = 0.0, sigma_t_nogo = 1.5, sigma_c_nogo = 1.5, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, seed = 1L - )) -}) diff --git a/tests/testthat/test-split_sets.R b/tests/testthat/test-split_sets.R new file mode 100644 index 0000000..e77ffac --- /dev/null +++ b/tests/testthat/test-split_sets.R @@ -0,0 +1,8 @@ +test_that("split_sets() separates the Go and NoGo probabilities", { + p <- cbind(1:4, 5:8) + expect_identical(split_sets(p, 1L), list(go = 1:4, nogo = 5:8)) + expect_identical(split_sets(p, 1L, dim = c(2L, 2L))$go, matrix(1:4, 2L)) + p4 <- cbind(1:2, 3:4, 5:6, 7:8) + expect_identical(split_sets(p4, 2L), + list(go = list(1:2, 3:4), nogo = list(5:6, 7:8))) +}) diff --git a/tests/testthat/test-stats_continuous2.R b/tests/testthat/test-stats_continuous2.R new file mode 100644 index 0000000..daf42b5 --- /dev/null +++ b/tests/testthat/test-stats_continuous2.R @@ -0,0 +1,32 @@ +test_that("stats_continuous2() builds the means and covariances", { + # One study: compare with L z / sqrt(n) and L A A^T L^T / (n - 1) + d <- list(z1 = 0.3, z2 = -1.2, x1 = 7.5, x2 = 4.1, z12 = 0.8) + sd <- c(3, 2) + rho <- 0.4 + s <- stats_continuous2(d, 9, c(1, -1), sd, rho) + L <- t(chol(cov2(sd[1], sd[2], rho))) + A <- matrix(c(sqrt(7.5), 0.8, 0, sqrt(4.1)), 2L) + expect_equal(s$mean[1L, ], c(1, -1) + drop(L %*% c(0.3, -1.2)) / 3, + tolerance = 1e-14) + S <- L %*% A %*% t(A) %*% t(L) / 8 + expect_equal(unname(s$cov[1L, ]), c(S[1, 1], S[1, 2], S[2, 2]), + tolerance = 1e-14) + expect_identical(colnames(s$cov), c("c11", "c12", "c22")) +}) + +test_that("stats_continuous2() has the sampling distribution of the data", { + set.seed(8) + n <- 6 + d <- draws_continuous2(40000L, n) + sig <- cov2(3, 2, -0.6) + s <- stats_continuous2(d, n, c(5, 1), c(3, 2), -0.6) + # Means: N(mu, Sigma / n); covariances: unbiased for Sigma, with + # Var(c11) = 2 sigma1^4 / (n - 1) (Wishart) + expect_equal(colMeans(s$mean), c(5, 1), tolerance = 0.03) + expect_equal(c(stats::cov(s$mean)), c(sig / n), tolerance = 0.05) + expect_equal(unname(colMeans(s$cov)), c(9, -3.6, 4), tolerance = 0.03) + expect_equal(stats::var(s$cov[, "c11"]), 2 * 81 / (n - 1), + tolerance = 0.05) + # The sample means and covariances are independent + expect_lt(abs(stats::cor(s$mean[, 1L], s$cov[, "c11"])), 0.03) +}) diff --git a/tests/testthat/test-tte_method_label.R b/tests/testthat/test-tte_method_label.R new file mode 100644 index 0000000..b92342b --- /dev/null +++ b/tests/testthat/test-tte_method_label.R @@ -0,0 +1,8 @@ +test_that("tte_method_label() describes the computation", { + expect_identical(tte_method_label(ref_design_tte("T1")), + "exact computation (fixed control)") + expect_identical(tte_method_label(ref_design_tte("T2")), + "numerical integration") + expect_identical(tte_method_label(ref_design_tte("T3", nMC = 400L)), + "simulation of future studies (nMC = 400)") +}) diff --git a/tests/testthat/test-two-binary.R b/tests/testthat/test-two-binary.R deleted file mode 100644 index d7c2490..0000000 --- a/tests/testthat/test-two-binary.R +++ /dev/null @@ -1,385 +0,0 @@ -# Tests for two binary endpoint functions -# Note: pbayesdecisionprob2bin is computationally intensive. -# nsim is not applicable (uses exact enumeration); nMC is minimised. -# skip_on_cran() is applied to the most expensive tests. - -# --------------------------------------------------------------------------- -# pbayespostpred2bin -# --------------------------------------------------------------------------- - -test_that("pbayespostpred2bin posterior controlled returns 9 named probs", { - result <- pbayespostpred2bin( - prob = 'posterior', design = 'controlled', - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.15, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 3L, x_t_01 = 2L, x_t_10 = 3L, x_t_11 = 4L, - x_c_00 = 5L, x_c_01 = 2L, x_c_10 = 2L, x_c_11 = 3L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L - ) - expect_type(result, "double") - expect_length(result, 9L) - expect_named(result, paste0("R", 1:9)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2bin predictive controlled returns 4 named probs", { - set.seed(1) - result <- pbayespostpred2bin( - prob = 'predictive', design = 'controlled', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.15, theta_NULL2 = 0.15, - x_t_00 = 3L, x_t_01 = 2L, x_t_10 = 3L, x_t_11 = 4L, - x_c_00 = 5L, x_c_01 = 2L, x_c_10 = 2L, x_c_11 = 3L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 30L, m_c = 30L, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L - ) - expect_type(result, "double") - expect_length(result, 4L) - expect_named(result, paste0("R", 1:4)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2bin posterior uncontrolled returns 9 named probs", { - result <- pbayespostpred2bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.15, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 3L, x_t_01 = 2L, x_t_10 = 3L, x_t_11 = 4L, - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L - ) - expect_type(result, "double") - expect_length(result, 9L) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2bin input validation works", { - # TV > MAV violated for posterior - expect_error(pbayespostpred2bin( - prob = 'posterior', design = 'controlled', - theta_TV1 = 0.05, theta_MAV1 = 0.15, - theta_TV2 = 0.15, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 3L, x_t_01 = 2L, x_t_10 = 3L, x_t_11 = 4L, - x_c_00 = 5L, x_c_01 = 2L, x_c_10 = 2L, x_c_11 = 3L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L - )) -}) - -# --------------------------------------------------------------------------- -# pbayesdecisionprob2bin -# --------------------------------------------------------------------------- - -test_that("pbayesdecisionprob2bin posterior controlled returns data.frame", { - skip_on_cran() - result <- pbayesdecisionprob2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.60, gamma_nogo = 0.60, - pi_t1 = c(0.30, 0.40), pi_t2 = c(0.35, 0.45), - rho_t = rep(0.0, 2), - pi_c1 = rep(0.15, 2), pi_c2 = rep(0.20, 2), - rho_c = rep(0.0, 2), - n_t = 10L, n_c = 10L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.10, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE - ) - expect_s3_class(result, "pbayesdecisionprob2bin") - df <- as.data.frame(result) - expect_true(all(c("pi_t1", "pi_t2", "Go", "Gray", "NoGo") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob2bin predictive controlled returns data.frame", { - skip_on_cran() - result <- pbayesdecisionprob2bin( - prob = 'predictive', design = 'controlled', - GoRegions = 1L, NoGoRegions = 4L, - gamma_go = 0.60, gamma_nogo = 0.60, - pi_t1 = c(0.30, 0.40), pi_t2 = c(0.35, 0.45), - rho_t = rep(0.0, 2), - pi_c1 = rep(0.15, 2), pi_c2 = rep(0.20, 2), - rho_c = rep(0.0, 2), - n_t = 10L, n_c = 10L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 30L, m_c = 30L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE - ) - expect_s3_class(result, "pbayesdecisionprob2bin") - df <- as.data.frame(result) - expect_equal(nrow(df), 2L) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob2bin input validation works", { - # GoRegions and NoGoRegions overlap - expect_error(pbayesdecisionprob2bin( - prob = 'posterior', design = 'controlled', - GoRegions = c(1L, 2L), NoGoRegions = c(2L, 9L), - gamma_go = 0.60, gamma_nogo = 0.60, - pi_t1 = 0.30, pi_t2 = 0.35, rho_t = 0.0, - pi_c1 = 0.15, pi_c2 = 0.20, rho_c = 0.0, - n_t = 10L, n_c = 10L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.10, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE - )) -}) - -test_that("pbayesdecisionprob2bin posterior uncontrolled returns correct class", { - skip_on_cran() - result <- pbayesdecisionprob2bin( - prob = 'posterior', design = 'uncontrolled', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.60, gamma_nogo = 0.60, - pi_t1 = c(0.30, 0.40), pi_t2 = c(0.35, 0.45), - rho_t = rep(0.0, 2), - pi_c1 = NULL, pi_c2 = NULL, rho_c = NULL, - n_t = 10L, n_c = NULL, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.10, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.05, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, nMC = 50L, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE - ) - expect_s3_class(result, "pbayesdecisionprob2bin") - df <- as.data.frame(result) - expect_true(all(c("pi_t1", "pi_t2", "Go", "Gray", "NoGo") %in% names(df))) - expect_false(any(c("pi_c1", "pi_c2") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -# --------------------------------------------------------------------------- -# getgamma2bin -# Note: n_t = n_c = 4L keeps allmultinom() at C(7,3) = 35 rows per arm, -# giving 35 x 35 = 1225 combinations vs 165^2 = 27225 for n=8, -# which is necessary to keep test runtime under 10s for CRAN. -# --------------------------------------------------------------------------- - -test_that("getgamma2bin posterior controlled returns correct class and structure", { - result <- getgamma2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.15, rho_c_go = 0.0, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.15, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.03, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 50L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) - ) - expect_s3_class(result, "getgamma2bin") - expect_true(all(c("gamma_go", "gamma_nogo", "PrGo_opt", "PrNoGo_opt", - "target_go", "target_nogo", "grid_results") %in% names(result))) - expect_true(all(c("gamma_grid", "PrGo_grid", "PrNoGo_grid") %in% - names(result$grid_results))) -}) - -test_that("getgamma2bin posterior controlled PrGo_grid and PrNoGo_grid in [0, 1]", { - result <- getgamma2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.15, rho_c_go = 0.0, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.15, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.03, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 50L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) - ) - expect_true(all(result$grid_results$PrGo_grid >= 0 & result$grid_results$PrGo_grid <= 1)) - expect_true(all(result$grid_results$PrNoGo_grid >= 0 & result$grid_results$PrNoGo_grid <= 1)) - expect_equal(length(result$grid_results$PrGo_grid), length(result$grid_results$gamma_grid)) -}) - -test_that("getgamma2bin posterior controlled gamma values in (0, 1) or NA", { - result <- getgamma2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.15, rho_c_go = 0.0, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.15, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.03, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 50L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) - ) - if (!is.na(result$gamma_go)) expect_true(result$gamma_go > 0 && result$gamma_go < 1) - if (!is.na(result$gamma_nogo)) expect_true(result$gamma_nogo > 0 && result$gamma_nogo < 1) -}) - -test_that("getgamma2bin predictive controlled returns correct class", { - result <- getgamma2bin( - prob = 'predictive', design = 'controlled', - GoRegions = 1L, NoGoRegions = 4L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.15, rho_c_go = 0.0, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.15, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.10, theta_NULL2 = 0.10, - m_t = 20L, m_c = 20L, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 50L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) - ) - expect_s3_class(result, "getgamma2bin") -}) - -test_that("getgamma2bin posterior uncontrolled returns correct class", { - result <- getgamma2bin( - prob = 'posterior', design = 'uncontrolled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = NULL, pi_c2_go = NULL, rho_c_go = NULL, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = NULL, pi_c2_nogo = NULL, rho_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.03, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = 1L, z01 = 1L, z10 = 1L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 50L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) - ) - expect_s3_class(result, "getgamma2bin") - expect_true(all(c("gamma_go", "gamma_nogo", "PrGo_opt", "PrNoGo_opt", - "target_go", "target_nogo", "grid_results") %in% names(result))) - expect_true(all(result$grid_results$PrGo_grid >= 0 & result$grid_results$PrGo_grid <= 1)) - expect_true(all(result$grid_results$PrNoGo_grid >= 0 & result$grid_results$PrNoGo_grid <= 1)) -}) - -test_that("getgamma2bin input validation: invalid prob", { - expect_error(getgamma2bin( - prob = 'invalid', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.30, pi_t2_go = 0.25, rho_t_go = 0.0, - pi_c1_go = 0.15, pi_c2_go = 0.15, rho_c_go = 0.0, - pi_t1_nogo = 0.30, pi_t2_nogo = 0.25, rho_t_nogo = 0.0, - pi_c1_nogo = 0.15, pi_c2_nogo = 0.15, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 4L, n_c = 4L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.15, theta_MAV1 = 0.05, - theta_TV2 = 0.10, theta_MAV2 = 0.03 - )) -}) diff --git a/tests/testthat/test-two-continuous.R b/tests/testthat/test-two-continuous.R deleted file mode 100644 index 1290913..0000000 --- a/tests/testthat/test-two-continuous.R +++ /dev/null @@ -1,484 +0,0 @@ -# Tests for two continuous endpoint functions -# Note: pbayespostpred2cont and pbayesdecisionprob2cont are computationally -# intensive. nMC is required even for CalcMethod = 'MM' (used internally -# for predictive or validation); set to minimum values. -# skip_on_cran() is applied to the most expensive tests. - -# Shared test data -.S_small <- matrix(c(15, 3, 3, 8), 2, 2) -.Sigma <- matrix(c(4.0, 1.2, 1.2, 2.0), 2, 2) - -# --------------------------------------------------------------------------- -# pbayespostpred2cont -# nMC is always required (default = 10000L); CalcMethod = 'MM' also uses nMC -# --------------------------------------------------------------------------- - -test_that("pbayespostpred2cont posterior vague MC returns 9 named probs", { - set.seed(1) - result <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = 15L, - ybar_t = c(3.0, 2.0), S_t = .S_small, - ybar_c = c(1.0, 0.8), S_c = .S_small, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 100L, CalcMethod = 'MC' - ) - expect_type(result, "double") - expect_length(result, 9L) - expect_named(result, paste0("R", 1:9)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2cont posterior vague MM returns 9 named probs", { - result <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = 15L, - ybar_t = c(3.0, 2.0), S_t = .S_small, - ybar_c = c(1.0, 0.8), S_c = .S_small, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 100L, CalcMethod = 'MM' - ) - expect_type(result, "double") - expect_length(result, 9L) - expect_named(result, paste0("R", 1:9)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2cont MC and MM posterior results are close", { - set.seed(2) - p_mc <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.0, 2.0), S_t = .S_small * 1.5, - ybar_c = c(1.0, 0.8), S_c = .S_small * 1.5, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 2000L, CalcMethod = 'MC' - ) - p_mm <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.0, 2.0), S_t = .S_small * 1.5, - ybar_c = c(1.0, 0.8), S_c = .S_small * 1.5, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 2000L, CalcMethod = 'MM' - ) - # R1 (best region) should agree within 10% - expect_equal(p_mc["R1"], p_mm["R1"], tolerance = 0.10) -}) - -test_that("pbayespostpred2cont predictive vague MC returns 4 named probs", { - set.seed(3) - result <- pbayespostpred2cont( - prob = 'predictive', design = 'controlled', prior = 'vague', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 1.0, theta_NULL2 = 0.5, - n_t = 15L, n_c = 15L, - ybar_t = c(3.0, 2.0), S_t = .S_small, - ybar_c = c(1.0, 0.8), S_c = .S_small, - m_t = 30L, m_c = 30L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 100L, CalcMethod = 'MC' - ) - expect_type(result, "double") - expect_length(result, 4L) - expect_named(result, paste0("R", 1:4)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -test_that("pbayespostpred2cont input validation works", { - # TV1 <= MAV1 for posterior - expect_error(pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 0.5, theta_MAV1 = 1.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = 15L, - ybar_t = c(3.0, 2.0), S_t = .S_small, - ybar_c = c(1.0, 0.8), S_c = .S_small, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 100L, CalcMethod = 'MC' - )) -}) - -test_that("pbayespostpred2cont posterior uncontrolled vague MM returns 9 named probs", { - result <- pbayespostpred2cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = NULL, - ybar_t = c(3.0, 2.0), S_t = .S_small, - ybar_c = NULL, S_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.8), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - nMC = 100L, CalcMethod = 'MM' - ) - expect_type(result, "double") - expect_length(result, 9L) - expect_named(result, paste0("R", 1:9)) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-6) -}) - -# --------------------------------------------------------------------------- -# pbayesdecisionprob2cont -# --------------------------------------------------------------------------- - -test_that("pbayesdecisionprob2cont posterior vague MM returns correct class", { - skip_on_cran() - set.seed(1) - result <- pbayesdecisionprob2cont( - nsim = 5L, - prob = 'posterior', design = 'controlled', prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.60, gamma_nogo = 0.60, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, - mu_t = matrix(c(3.0, 2.0, 3.5, 2.5), nrow = 2, byrow = TRUE), - Sigma_t = .Sigma, - mu_c = matrix(c(1.0, 0.8, 1.0, 0.8), nrow = 2, byrow = TRUE), - Sigma_c = .Sigma, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - CalcMethod = 'MM', nMC = 100L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 1 - ) - expect_s3_class(result, "pbayesdecisionprob2cont") - df <- as.data.frame(result) - expect_true(all(c("mu_t1", "mu_t2", "Go", "Gray", "NoGo") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob2cont predictive vague MM returns correct class", { - skip_on_cran() - set.seed(2) - result <- pbayesdecisionprob2cont( - nsim = 5L, - prob = 'predictive', design = 'controlled', prior = 'vague', - GoRegions = 1L, NoGoRegions = 4L, - gamma_go = 0.60, gamma_nogo = 0.60, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 1.0, theta_NULL2 = 0.5, - n_t = 15L, n_c = 15L, m_t = 30L, m_c = 30L, - mu_t = matrix(c(3.0, 2.0, 3.5, 2.5), nrow = 2, byrow = TRUE), - Sigma_t = .Sigma, - mu_c = matrix(c(1.0, 0.8, 1.0, 0.8), nrow = 2, byrow = TRUE), - Sigma_c = .Sigma, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - CalcMethod = 'MM', nMC = 100L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 2 - ) - expect_s3_class(result, "pbayesdecisionprob2cont") - df <- as.data.frame(result) - expect_equal(nrow(df), 2L) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -test_that("pbayesdecisionprob2cont input validation works", { - # GoRegions and NoGoRegions overlap - expect_error(pbayesdecisionprob2cont( - nsim = 5L, - prob = 'posterior', design = 'controlled', prior = 'vague', - GoRegions = c(1L, 2L), NoGoRegions = c(2L, 9L), - gamma_go = 0.60, gamma_nogo = 0.60, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, - mu_t = c(3.0, 2.0), Sigma_t = .Sigma, - mu_c = c(1.0, 0.8), Sigma_c = .Sigma, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - CalcMethod = 'MM', nMC = 100L, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 1 - )) -}) - -test_that("pbayesdecisionprob2cont posterior uncontrolled vague MM returns correct class", { - skip_on_cran() - result <- pbayesdecisionprob2cont( - nsim = 5L, - prob = 'posterior', design = 'uncontrolled', prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.60, gamma_nogo = 0.60, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 15L, n_c = NULL, m_t = NULL, m_c = NULL, - mu_t = matrix(c(3.0, 2.0, 3.5, 2.5), nrow = 2, byrow = TRUE), - Sigma_t = .Sigma, - mu_c = NULL, Sigma_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(1.0, 0.8), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - CalcMethod = 'MM', nMC = 100L, - error_if_Miss = FALSE, Gray_inc_Miss = FALSE, seed = 1 - ) - expect_s3_class(result, "pbayesdecisionprob2cont") - df <- as.data.frame(result) - expect_true(all(c("mu_t1", "mu_t2", "Go", "Gray", "NoGo") %in% names(df))) - expect_false(any(c("mu2_ep1", "mu2_ep2") %in% names(df))) - expect_equal(nrow(df), 2L) - expect_true(all(df$Go >= 0 & df$Go <= 1)) - expect_true(all(df$NoGo >= 0 & df$NoGo <= 1)) - expect_true(all(abs(df$Go + df$Gray + df$NoGo - 1) < 1e-6)) -}) - -# --------------------------------------------------------------------------- -# getgamma2cont -# --------------------------------------------------------------------------- - -.Sigma_gc <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) - -test_that("getgamma2cont posterior vague MM controlled returns correct class and structure", { - result <- getgamma2cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = NULL, CalcMethod = 'MM', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 1L - ) - expect_s3_class(result, "getgamma2cont") - expect_true(all(c("gamma_go", "gamma_nogo", "PrGo_opt", "PrNoGo_opt", - "target_go", "target_nogo", "grid_results") %in% names(result))) - expect_true(all(c("gamma_grid", "PrGo_grid", "PrNoGo_grid") %in% - names(result$grid_results))) -}) - -test_that("getgamma2cont posterior vague MM PrGo_grid and PrNoGo_grid in [0, 1]", { - result <- getgamma2cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = NULL, CalcMethod = 'MM', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 1L - ) - expect_true(all(result$grid_results$PrGo_grid >= 0 & result$grid_results$PrGo_grid <= 1)) - expect_true(all(result$grid_results$PrNoGo_grid >= 0 & result$grid_results$PrNoGo_grid <= 1)) - expect_equal(length(result$grid_results$PrGo_grid), length(result$grid_results$gamma_grid)) -}) - -test_that("getgamma2cont posterior vague MM gamma values in (0, 1) or NA", { - result <- getgamma2cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = NULL, CalcMethod = 'MM', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 1L - ) - if (!is.na(result$gamma_go)) expect_true(result$gamma_go > 0 && result$gamma_go < 1) - if (!is.na(result$gamma_nogo)) expect_true(result$gamma_nogo > 0 && result$gamma_nogo < 1) -}) - -test_that("getgamma2cont posterior uncontrolled vague MM returns correct class", { - result <- getgamma2cont( - nsim = 50L, prob = 'posterior', design = 'uncontrolled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = NULL, Sigma_c_go = NULL, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = NULL, Sigma_c_nogo = NULL, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = NULL, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = NULL, CalcMethod = 'MM', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 2L - ) - expect_s3_class(result, "getgamma2cont") -}) - -test_that("getgamma2cont predictive vague MC returns correct class", { - result <- getgamma2cont( - nsim = 30L, prob = 'predictive', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 4L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 1.0, theta_NULL2 = 0.5, - m_t = 20L, m_c = 20L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 50L, CalcMethod = 'MC', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 3L - ) - expect_s3_class(result, "getgamma2cont") - if (!is.na(result$PrGo_opt)) - expect_true(result$PrGo_opt >= 0 && result$PrGo_opt <= 1) - if (!is.na(result$PrNoGo_opt)) - expect_true(result$PrNoGo_opt >= 0 && result$PrNoGo_opt <= 1) -}) - -test_that("getgamma2cont input validation: invalid nsim", { - expect_error(getgamma2cont( - nsim = 0L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - seed = 1L - )) -}) - -test_that("getgamma2cont input validation: overlapping GoRegions and NoGoRegions", { - expect_error(getgamma2cont( - nsim = 50L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = c(1L, 2L), NoGoRegions = c(2L, 9L), - mu_t_go = c(2.0, 1.0), Sigma_t_go = .Sigma_gc, - mu_c_go = c(0.0, 0.0), Sigma_c_go = .Sigma_gc, - mu_t_nogo = c(2.0, 1.0), Sigma_t_nogo = .Sigma_gc, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = .Sigma_gc, - target_go = 0.05, target_nogo = 0.20, - n_t = 10L, n_c = 10L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - seed = 1L - )) -}) diff --git a/tests/testthat/test-utilities-distributions.R b/tests/testthat/test-utilities-distributions.R deleted file mode 100644 index 8f62595..0000000 --- a/tests/testthat/test-utilities-distributions.R +++ /dev/null @@ -1,274 +0,0 @@ -# Tests for utility, sampling, and distribution functions - -# --------------------------------------------------------------------------- -# rdirichlet -# --------------------------------------------------------------------------- - -test_that("rdirichlet returns correct structure", { - set.seed(1) - result <- rdirichlet(n = 10L, alpha = c(1, 2, 3)) - expect_true(is.matrix(result)) - expect_equal(dim(result), c(10L, 3L)) - expect_true(all(result >= 0)) - expect_true(all(abs(rowSums(result) - 1) < 1e-10)) -}) - -test_that("rdirichlet row sums are 1 for various alpha", { - set.seed(2) - result <- rdirichlet(n = 100L, alpha = c(0.5, 0.5, 0.5, 0.5)) - expect_true(all(abs(rowSums(result) - 1) < 1e-10)) -}) - -test_that("rdirichlet input validation works", { - expect_error(rdirichlet(n = 0L, alpha = c(1, 1, 1))) - expect_error(rdirichlet(n = 10L, alpha = c(-1, 1, 1))) - expect_error(rdirichlet(n = 10L, alpha = c(0, 1, 1))) -}) - -# --------------------------------------------------------------------------- -# getjointbin -# Returns a named numeric vector of length 4: (p00, p01, p10, p11) -# --------------------------------------------------------------------------- - -test_that("getjointbin returns a named vector of length 4", { - result <- getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.0) - expect_type(result, "double") - expect_length(result, 4L) - expect_named(result, c("p00", "p01", "p10", "p11")) -}) - -test_that("getjointbin elements are non-negative and sum to 1", { - result <- getjointbin(pi1 = 0.3, pi2 = 0.4, rho = 0.0) - expect_true(all(result >= 0)) - expect_equal(sum(result), 1, tolerance = 1e-10) -}) - -test_that("getjointbin with rho = 0: p11 equals product of marginals", { - pi1 <- 0.3; pi2 <- 0.4 - result <- getjointbin(pi1 = pi1, pi2 = pi2, rho = 0.0) - expect_equal(unname(result["p11"]), pi1 * pi2, tolerance = 1e-10) -}) - -test_that("getjointbin marginals are consistent with pi1 and pi2", { - pi1 <- 0.3; pi2 <- 0.4 - result <- getjointbin(pi1 = pi1, pi2 = pi2, rho = 0.0) - # P(Y1 = 1) = p10 + p11 - expect_equal(unname(result["p10"] + result["p11"]), pi1, tolerance = 1e-10) - # P(Y2 = 1) = p01 + p11 - expect_equal(unname(result["p01"] + result["p11"]), pi2, tolerance = 1e-10) -}) - -test_that("getjointbin input validation works", { - expect_error(getjointbin(pi1 = -0.1, pi2 = 0.3, rho = 0)) - expect_error(getjointbin(pi1 = 0.3, pi2 = 1.1, rho = 0)) - expect_error(getjointbin(pi1 = 0.5, pi2 = 0.5, rho = 2)) -}) - -# --------------------------------------------------------------------------- -# allmultinom -# Signature: allmultinom(n) — always returns a 4-column matrix -# --------------------------------------------------------------------------- - -test_that("allmultinom returns correct structure", { - result <- allmultinom(n = 5L) - expect_true(is.matrix(result)) - expect_equal(ncol(result), 4L) - expect_named(result[1L, ], c("x00", "x01", "x10", "x11")) - expect_true(all(rowSums(result) == 5L)) - expect_true(all(result >= 0L)) -}) - -test_that("allmultinom row count matches stars-and-bars formula", { - # C(n+3, 3) = (n+1)(n+2)(n+3)/6 - n <- 5L - result <- allmultinom(n) - expect_equal(nrow(result), choose(n + 3L, 3L)) -}) - -test_that("allmultinom n = 0 returns 1 row of zeros", { - result <- allmultinom(0L) - expect_equal(nrow(result), 1L) - expect_true(all(result == 0L)) -}) - -test_that("allmultinom input validation works", { - expect_error(allmultinom(-1L)) -}) - -# --------------------------------------------------------------------------- -# pbetadiff -# --------------------------------------------------------------------------- - -test_that("pbetadiff returns a value in [0, 1]", { - result <- pbetadiff(q = 0.1, alpha_t = 6, beta_t = 5, alpha_c = 3, beta_c = 8) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbetadiff lower.tail = TRUE and FALSE sum to 1", { - q <- 0.1; a1 <- 6; b1 <- 5; a2 <- 3; b2 <- 8 - p_u <- pbetadiff(q, a1, b1, a2, b2, lower.tail = FALSE) - p_l <- pbetadiff(q, a1, b1, a2, b2, lower.tail = TRUE) - expect_equal(p_u + p_l, 1, tolerance = 1e-6) -}) - -test_that("pbetadiff at q = 0 with equal beta params gives ~0.5", { - result <- pbetadiff(q = 0, alpha_t = 5, beta_t = 5, alpha_c = 5, beta_c = 5, - lower.tail = FALSE) - expect_equal(result, 0.5, tolerance = 0.01) -}) - -test_that("pbetadiff input validation works", { - expect_error(pbetadiff(q = 0.1, alpha_t = -1, beta_t = 5, alpha_c = 3, beta_c = 8)) - expect_error(pbetadiff(q = 0.1, alpha_t = 6, beta_t = 0, alpha_c = 3, beta_c = 8)) - expect_error(pbetadiff(q = 0.1, alpha_t = 6, beta_t = 5, alpha_c = 3, beta_c = -1)) -}) - -# --------------------------------------------------------------------------- -# pbetabinomdiff -# Signature: pbetabinomdiff(q, m_t, m_c, alpha_t, alpha_c, beta_t, beta_c, lower.tail) -# Posterior predictive: Y_k ~ BetaBinomial(m_k, alpha_k, beta_k) -# --------------------------------------------------------------------------- - -test_that("pbetabinomdiff returns a value in [0, 1]", { - result <- pbetabinomdiff(q = 0.1, m_t = 30, m_c = 30, - alpha_t = 10.5, alpha_c = 6.5, - beta_t = 10.5, beta_c = 14.5) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("pbetabinomdiff lower.tail = TRUE and FALSE sum to 1", { - p_u <- pbetabinomdiff(q = 0.1, m_t = 30, m_c = 30, - alpha_t = 10.5, alpha_c = 6.5, - beta_t = 10.5, beta_c = 14.5, lower.tail = FALSE) - p_l <- pbetabinomdiff(q = 0.1, m_t = 30, m_c = 30, - alpha_t = 10.5, alpha_c = 6.5, - beta_t = 10.5, beta_c = 14.5, lower.tail = TRUE) - expect_equal(p_u + p_l, 1, tolerance = 1e-10) -}) - -test_that("pbetabinomdiff input validation works", { - expect_error(pbetabinomdiff(q = 0.1, m_t = 0, m_c = 30, - alpha_t = 1, alpha_c = 1, beta_t = 1, beta_c = 1)) - expect_error(pbetabinomdiff(q = 0.1, m_t = 30, m_c = 30, - alpha_t = -1, alpha_c = 1, beta_t = 1, beta_c = 1)) -}) - -# --------------------------------------------------------------------------- -# ptdiff_NI -# --------------------------------------------------------------------------- - -test_that("ptdiff_NI returns a value in [0, 1]", { - result <- ptdiff_NI(q = 1, mu_t = 3, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 15, nu_c = 15, lower.tail = FALSE) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("ptdiff_NI symmetric case returns ~0.5", { - result <- ptdiff_NI(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 20, nu_c = 20, lower.tail = FALSE) - expect_equal(result, 0.5, tolerance = 0.01) -}) - -test_that("ptdiff_NI lower.tail = TRUE and FALSE sum to 1", { - p_u <- ptdiff_NI(q = 2, mu_t = 3, mu_c = 1, sd_t = 1.5, sd_c = 1.2, - nu_t = 15, nu_c = 18, lower.tail = FALSE) - p_l <- ptdiff_NI(q = 2, mu_t = 3, mu_c = 1, sd_t = 1.5, sd_c = 1.2, - nu_t = 15, nu_c = 18, lower.tail = TRUE) - expect_equal(p_u + p_l, 1, tolerance = 1e-6) -}) - -test_that("ptdiff_NI input validation works", { - expect_error(ptdiff_NI(q = 1, mu_t = 3, mu_c = 1, sd_t = -1, sd_c = 1, - nu_t = 15, nu_c = 15)) - expect_error(ptdiff_NI(q = 1, mu_t = 3, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 1, nu_c = 15)) -}) - -# --------------------------------------------------------------------------- -# ptdiff_MC -# --------------------------------------------------------------------------- - -test_that("ptdiff_MC returns a value in [0, 1]", { - set.seed(1) - result <- ptdiff_MC(nMC = 1000L, q = 1, mu_t = 3, mu_c = 1, - sd_t = 1, sd_c = 1, nu_t = 15, nu_c = 15, - lower.tail = FALSE) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("ptdiff_MC symmetric case returns ~0.5", { - set.seed(2) - result <- ptdiff_MC(nMC = 5000L, q = 0, mu_t = 1, mu_c = 1, - sd_t = 1, sd_c = 1, nu_t = 20, nu_c = 20, - lower.tail = FALSE) - expect_equal(result, 0.5, tolerance = 0.05) -}) - -test_that("ptdiff_MC and ptdiff_NI agree closely", { - set.seed(3) - p_mc <- ptdiff_MC(nMC = 10000L, q = 2, mu_t = 3, mu_c = 1, - sd_t = 1.5, sd_c = 1.2, nu_t = 15, nu_c = 18, - lower.tail = FALSE) - p_ni <- ptdiff_NI(q = 2, mu_t = 3, mu_c = 1, - sd_t = 1.5, sd_c = 1.2, nu_t = 15, nu_c = 18, - lower.tail = FALSE) - expect_equal(p_mc, p_ni, tolerance = 0.03) -}) - -test_that("ptdiff_MC input validation works", { - expect_error(ptdiff_MC(nMC = 0L, q = 1, mu_t = 1, mu_c = 0, - sd_t = 1, sd_c = 1, nu_t = 10, nu_c = 10)) - expect_error(ptdiff_MC(nMC = 1000L, q = 1, mu_t = 1, mu_c = 0, - sd_t = 1, sd_c = 1, nu_t = 1, nu_c = 10)) -}) - -# --------------------------------------------------------------------------- -# ptdiff_MM -# --------------------------------------------------------------------------- - -test_that("ptdiff_MM returns a value in [0, 1]", { - result <- ptdiff_MM(q = 1, mu_t = 3, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 15, nu_c = 15, lower.tail = FALSE) - expect_type(result, "double") - expect_length(result, 1L) - expect_true(result >= 0 && result <= 1) -}) - -test_that("ptdiff_MM symmetric case returns ~0.5", { - result <- ptdiff_MM(q = 0, mu_t = 1, mu_c = 1, sd_t = 1, sd_c = 1, - nu_t = 20, nu_c = 20, lower.tail = FALSE) - expect_equal(result, 0.5, tolerance = 0.01) -}) - -test_that("ptdiff_MM and ptdiff_NI agree closely", { - p_mm <- ptdiff_MM(q = 2, mu_t = 3, mu_c = 1, - sd_t = 1.5, sd_c = 1.2, nu_t = 15, nu_c = 18, - lower.tail = FALSE) - p_ni <- ptdiff_NI(q = 2, mu_t = 3, mu_c = 1, - sd_t = 1.5, sd_c = 1.2, nu_t = 15, nu_c = 18, - lower.tail = FALSE) - expect_equal(p_mm, p_ni, tolerance = 0.02) -}) - -test_that("ptdiff_MM vectorised input returns correct length", { - result <- ptdiff_MM(q = 1, mu_t = c(2, 3, 4), mu_c = c(0, 1, 2), - sd_t = c(1, 1.2, 1.5), sd_c = c(1, 1.1, 1.3), - nu_t = 10, nu_c = 10, lower.tail = FALSE) - expect_length(result, 3L) - expect_true(all(result >= 0 & result <= 1)) -}) - -test_that("ptdiff_MM input validation works", { - expect_error(ptdiff_MM(q = 1, mu_t = 1, mu_c = 0, sd_t = 1, sd_c = 1, - nu_t = 4, nu_c = 10)) - expect_error(ptdiff_MM(q = 1, mu_t = 1, mu_c = 0, sd_t = -1, sd_c = 1, - nu_t = 10, nu_c = 10)) -}) diff --git a/tests/testthat/test-warn_miss.R b/tests/testthat/test-warn_miss.R new file mode 100644 index 0000000..348758a --- /dev/null +++ b/tests/testthat/test-warn_miss.R @@ -0,0 +1,15 @@ +test_that("warn_miss() warns only for positive probabilities", { + expect_silent(warn_miss(c(0, 0))) + expect_warning(warn_miss(c(0, 0.1, 0.2)), "in 2 scenario\\(s\\)") + expect_warning(warn_miss(1e-20), "gamma_go \\+ gamma_nogo > 1\\.$") + expect_warning(warn_miss(1e-20, "joint"), "gamma_go \\+ gamma_nogo > 1\\.$") + expect_warning(warn_miss(0.1, "and"), + "gamma_go \\+ gamma_nogo > 1 for at least one endpoint\\.$") + expect_warning(warn_miss(0.1, "or"), + "With rule = \"or\", a Miss decision can occur for any") +}) + +test_that("warn_miss() ignores scenarios that are not evaluable", { + expect_silent(warn_miss(c(0, NA))) + expect_warning(warn_miss(c(NA, 0.1)), "in 1 scenario\\(s\\)") +}) diff --git a/tests/testthat/test-warn_unused_dots.R b/tests/testthat/test-warn_unused_dots.R new file mode 100644 index 0000000..00128d2 --- /dev/null +++ b/tests/testthat/test-warn_unused_dots.R @@ -0,0 +1,19 @@ +test_that("warn_unused_dots() is silent without arguments", { + expect_silent(warn_unused_dots(list(), "plot.qdm_oc")) +}) + +test_that("warn_unused_dots() names the ignored arguments", { + expect_warning( + warn_unused_dots(list(point_size = 2), "plot.qdm_boundary"), + "Ignoring unknown argument(s) of plot.qdm_boundary(): point_size.", + fixed = TRUE + ) + expect_warning( + warn_unused_dots(list(linewidth = 2, 3), "plot.qdm_calibration"), + paste("Ignoring unknown argument(s) of plot.qdm_calibration():", + "linewidth, an unnamed argument."), + fixed = TRUE + ) + expect_warning(warn_unused_dots(list(3), "plot.qdm_oc"), + "plot.qdm_oc(): an unnamed argument.", fixed = TRUE) +}) diff --git a/tests/testthat/test-with_seed.R b/tests/testthat/test-with_seed.R new file mode 100644 index 0000000..57ab79d --- /dev/null +++ b/tests/testthat/test-with_seed.R @@ -0,0 +1,47 @@ +test_that("with_seed() gives reproducible results", { + x1 <- with_seed(123, stats::runif(3)) + x2 <- with_seed(123, stats::runif(3)) + expect_identical(x1, x2) +}) + +test_that("with_seed() restores the random number state", { + set.seed(42) + state <- get(".Random.seed", envir = globalenv()) + with_seed(1, stats::runif(5)) + expect_identical(get(".Random.seed", envir = globalenv()), state) +}) + +test_that("with_seed() with NULL uses the current random number stream", { + set.seed(7) + x1 <- with_seed(NULL, stats::runif(2)) + set.seed(7) + x2 <- stats::runif(2) + expect_identical(x1, x2) +}) + +test_that("with_seed() removes .Random.seed if none existed before", { + env <- globalenv() + stats::runif(1) + saved <- get(".Random.seed", envir = env) + rm(".Random.seed", envir = env) + with_seed(1, stats::runif(1)) + expect_false(exists(".Random.seed", envir = env, inherits = FALSE)) + assign(".Random.seed", saved, envir = env) +}) + +test_that("with_seed() validates the seed", { + expect_error(with_seed(1.5, 1), "'seed' must contain whole numbers only.") +}) + +test_that("with_seed() restores the state when the expression fails", { + set.seed(3) + state <- get(".Random.seed", envir = globalenv()) + expect_error(with_seed(1, stop("boom")), "boom") + expect_identical(get(".Random.seed", envir = globalenv()), state) +}) + +test_that("with_seed() does not change the random number generator kind", { + kind <- RNGkind() + with_seed(10, stats::rnorm(1)) + expect_identical(RNGkind(), kind) +}) diff --git a/vignettes/figures/2bin-getgamma-ctrl-1.png b/vignettes/figures/2bin-getgamma-ctrl-1.png deleted file mode 100644 index ef11149..0000000 Binary files a/vignettes/figures/2bin-getgamma-ctrl-1.png and /dev/null differ diff --git a/vignettes/figures/2bin-oc-controlled-1.png b/vignettes/figures/2bin-oc-controlled-1.png deleted file mode 100644 index b3ff6e3..0000000 Binary files a/vignettes/figures/2bin-oc-controlled-1.png and /dev/null differ diff --git a/vignettes/figures/2cont-getgamma-ctrl-1.png b/vignettes/figures/2cont-getgamma-ctrl-1.png deleted file mode 100644 index ae06bd7..0000000 Binary files a/vignettes/figures/2cont-getgamma-ctrl-1.png and /dev/null differ diff --git a/vignettes/figures/2cont-oc-controlled-1.png b/vignettes/figures/2cont-oc-controlled-1.png deleted file mode 100644 index 923c530..0000000 Binary files a/vignettes/figures/2cont-oc-controlled-1.png and /dev/null differ diff --git a/vignettes/figures/overview-qs-gamma-1.png b/vignettes/figures/overview-qs-gamma-1.png deleted file mode 100644 index 660fb5d..0000000 Binary files a/vignettes/figures/overview-qs-gamma-1.png and /dev/null differ diff --git a/vignettes/figures/overview-qs-oc-1.png b/vignettes/figures/overview-qs-oc-1.png deleted file mode 100644 index d547339..0000000 Binary files a/vignettes/figures/overview-qs-oc-1.png and /dev/null differ diff --git a/vignettes/figures/single-bin-getgamma-ctrl-1.png b/vignettes/figures/single-bin-getgamma-ctrl-1.png deleted file mode 100644 index da11cc3..0000000 Binary files a/vignettes/figures/single-bin-getgamma-ctrl-1.png and /dev/null differ diff --git a/vignettes/figures/single-bin-oc-controlled-1.png b/vignettes/figures/single-bin-oc-controlled-1.png deleted file mode 100644 index 04ab7e4..0000000 Binary files a/vignettes/figures/single-bin-oc-controlled-1.png and /dev/null differ diff --git a/vignettes/figures/single-cont-getgamma-ctrl-1.png b/vignettes/figures/single-cont-getgamma-ctrl-1.png deleted file mode 100644 index 9ed333b..0000000 Binary files a/vignettes/figures/single-cont-getgamma-ctrl-1.png and /dev/null differ diff --git a/vignettes/figures/single-cont-oc-controlled-1.png b/vignettes/figures/single-cont-oc-controlled-1.png deleted file mode 100644 index d3a60b7..0000000 Binary files a/vignettes/figures/single-cont-oc-controlled-1.png and /dev/null differ diff --git a/vignettes/migration.Rmd b/vignettes/migration.Rmd new file mode 100644 index 0000000..2418929 --- /dev/null +++ b/vignettes/migration.Rmd @@ -0,0 +1,222 @@ +--- +title: "Migrating from version 0.1.0" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Migrating from version 0.1.0} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) +library(BayesianQDM) +``` + +Version 1.0.0 of BayesianQDM is a redesign of version 0.1.0 and is not +backward compatible. In version 0.1.0, each combination of endpoint and +operation had its own function with up to about 50 arguments. In version +1.0.0, a study is described by small specification objects that are +combined into a design, and three functions work with any design. This +vignette shows how to translate code written for version 0.1.0 and lists +the changes in the results. The code for version 0.1.0 is shown but not run. + +## Correspondence of the functions + +| Version 0.1.0 | Version 1.0.0 | +|---|---| +| `pbayespostpred1bin()`, `pbayespostpred1cont()`, `pbayespostpred2bin()`, `pbayespostpred2cont()` | `qdm_decide()` with a design and observed data | +| `pbayesdecisionprob1bin()`, `pbayesdecisionprob1cont()`, `pbayesdecisionprob2bin()`, `pbayesdecisionprob2cont()` | `qdm_oc()` | +| `getgamma1bin()`, `getgamma1cont()`, `getgamma2bin()`, `getgamma2cont()` | `qdm_calibrate()` | +| `ptdiff_NI()`, `ptdiff_MC()`, `ptdiff_MM()` | `ptdiff()` with `method = "NI"`, `"MC"` or `"MM"` | +| `pbetadiff()`, `pbetabinomdiff()` | Same names, with the arguments ordered by group | +| `getjointbin()` | `cellprob_binary2()` | +| `rdirichlet()` | Same name | +| `allmultinom()` | Internal function | + +## Correspondence of the arguments + +| Version 0.1.0 | Version 1.0.0 | +|---|---| +| `prob = 'posterior'` with `theta_TV`, `theta_MAV`, `gamma_go`, `gamma_nogo` | `criterion_posterior(theta_tv, theta_mav, gamma_go, gamma_nogo)` | +| `prob = 'predictive'` with `theta_NULL`, `m_t`, `m_c` | `criterion_predictive(theta_null, m_t, m_c, gamma_go, gamma_nogo)` | +| `a_t`, `b_t`, `a_c`, `b_c` | `prior_beta(a, b)` for each group | +| `prior = 'vague'` | `prior_vague()` | +| `prior = 'N-Inv-Chisq'` with `mu0_*`, `kappa0_*`, `nu0_*`, `sigma0_*` | `prior_nix(mu0, kappa0, nu0, sigma0)` for each group | +| `CalcMethod` | `method` of `design_continuous()` and `design_continuous2()` | +| `design = 'controlled'` | `n_c` of at least 1 (binary endpoints), 2 (one continuous endpoint) or 3 (two continuous endpoints) | +| `design = 'external'` with `ne_*`, `ye_*` (or `bar_ye_*`, `se_*`) and `alpha0e_*` | `borrow(data_*(...), a0)` as `external_t` or `external_c` | +| `design = 'uncontrolled'` with `z` (binary) or `mu0_c` and `r` (continuous) | `n_c = 0` and `hypothetical_c = hypothetical(...)` | +| `pi_t`, `pi_c` and similar vectors of true parameters | A data frame of scenarios | +| `error_if_Miss`, `Gray_inc_Miss` | Removed; Miss decisions are reported in their own column | +| `col_go`, `col_nogo`, `col_gray` and `base_size` of the `plot()` methods | Same names, with `col_miss`, `linewidth`, `point_size`, `label_size` and `legend_position` where they apply; `base_size` is 11 by default instead of 28 | +| `title`, `xlab` and `ylab` of the `plot()` methods | `ggplot2::labs()` added to the plot | +| `which` of the `plot()` methods for two endpoints | Removed; the plot has one panel per decision | + +The meaning of `gamma_nogo` is unchanged: the NoGo criterion is +$\Pr(\theta \le \theta_{MAV} \mid D) \ge \gamma_{nogo}$. + +## Posterior probability for observed data + +Version 0.1.0: + +```{r old-post, eval = FALSE} +pbayespostpred1bin( + prob = 'posterior', design = 'controlled', theta0 = 0.05, + n_t = 10, n_c = 10, y_t = 7, y_c = 3, + a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, + m_t = NULL, m_c = NULL, z = NULL, + ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, + alpha0e_t = NULL, alpha0e_c = NULL, + lower.tail = FALSE +) +``` + +Version 1.0.0 computes the probability directly from the posterior +distributions $\textrm{Beta}(7.5, 3.5)$ and $\textrm{Beta}(3.5, 7.5)$, or as +the probability of the Go region of a design whose target value is 0.05: + +```{r new-post} +pbetadiff(0.05, a_t = 7.5, b_t = 3.5, a_c = 3.5, b_c = 7.5, + lower.tail = FALSE) + +des <- design_binary( + n_t = 10, n_c = 10, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.05, theta_mav = 0, + gamma_go = 0.8, gamma_nogo = 0.8) +) +qdm_decide(des, data_t = data_binary(10, 7), data_c = data_binary(10, 3)) +``` + +## Operating characteristics + +Version 0.1.0: + +```{r old-oc, eval = FALSE} +pbayesdecisionprob1bin( + prob = 'posterior', design = 'controlled', + theta_TV = 0.30, theta_MAV = 0.10, theta_NULL = NULL, + gamma_go = 0.80, gamma_nogo = 0.20, + pi_t = seq(0.15, 0.9, l = 10), pi_c = rep(0.15, 10), + n_t = 10, n_c = 10, + a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, + z = NULL, m_t = NULL, m_c = NULL, + ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, + alpha0e_t = NULL, alpha0e_c = NULL +) +``` + +Version 1.0.0: + +```{r new-oc} +des <- design_binary( + n_t = 10, n_c = 10, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.30, theta_mav = 0.10, + gamma_go = 0.80, gamma_nogo = 0.20) +) +oc <- qdm_oc(des, data.frame(pi_t = seq(0.15, 0.9, length.out = 10), + pi_c = 0.15)) +oc +``` + +## Calibration of the thresholds + +Version 0.1.0: + +```{r old-cal, eval = FALSE} +getgamma1bin( + prob = 'posterior', design = 'controlled', + theta_TV = 0.30, theta_MAV = 0.10, theta_NULL = NULL, + pi_t_go = 0.15, pi_c_go = 0.15, pi_t_nogo = 0.35, pi_c_nogo = 0.15, + target_go = 0.05, target_nogo = 0.20, + n_t = 12L, n_c = 12L, + a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, + z = NULL, m_t = NULL, m_c = NULL, + ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, + alpha0e_t = NULL, alpha0e_c = NULL +) +``` + +Version 1.0.0 (the thresholds of the design are replaced by the calibrated +ones): + +```{r new-cal} +des12 <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.30, theta_mav = 0.10, + gamma_go = 0.80, gamma_nogo = 0.20) +) +cal <- qdm_calibrate(des12, + scenario_go = data.frame(pi_t = 0.15, pi_c = 0.15), + scenario_nogo = data.frame(pi_t = 0.35, pi_c = 0.15), + target_go = 0.05, target_nogo = 0.20) +cal +``` + +Version 0.1.0 required the probabilities to be less than the targets; +version 1.0.0 requires them to be at most the targets. + +## External data and hypothetical controls + +External data given in version 0.1.0 by `ne_c = 20, ye_c = 5, +alpha0e_c = 0.5` are given in version 1.0.0 by +`external_c = borrow(data_binary(n = 20, y = 5), a0 = 0.5)`. For a +continuous endpoint, `ne_c`, `bar_ye_c`, `se_c` and `alpha0e_c` become +`borrow(data_continuous(n, mean, sd), a0)`. + +The uncontrolled design of version 0.1.0 with `z` hypothetical responders +among `n_c` control subjects and control prior $\textrm{Beta}(a_c, b_c)$ +corresponds to `n_c = 0`, `prior_c = prior_beta(a_c, b_c)` and +`hypothetical_c = hypothetical(data = data_binary(n_c, z))`; for example: + +```{r hypothetical} +design_binary( + n_t = 12, n_c = 0, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.30, theta_mav = 0.10, + gamma_go = 0.80, gamma_nogo = 0.20), + hypothetical_c = hypothetical(data = data_binary(n = 12, y = 2)) +) +``` + +For a continuous endpoint, `mu0_c` and `r` become +`hypothetical(mean = mu0_c, r = r)`. + +## Changes in the results + +Formulas and numerical methods that were wrong in version 0.1.0 have been +corrected, so some results differ. + +- The posterior predictive distribution of the mean of $m$ future subjects + of a continuous endpoint has the squared scale + $\sigma_n^2 (1 / \kappa_n + 1 / m)$ (one endpoint) and the scale matrix + $(1 / \kappa_n + 1 / m) \Lambda_n / (\nu_n - 1)$ (two endpoints). + Version 0.1.0 treated the future subjects as independent draws from the + predictive distribution of one subject, which understates the + uncertainty. +- With the vague prior and external data for a continuous endpoint, the + posterior distribution of the mean has $a_0 n_e + n - 1$ degrees of + freedom, and its scale uses the same denominator (version 0.1.0 used + $a_0 n_e + n$). +- For two binary endpoints, the predictive probabilities are computed + exactly instead of by Monte Carlo simulation. +- For two continuous endpoints, the moment-matching approximation uses the + real degrees of freedom (version 0.1.0 rounded them to an integer), and + with Monte Carlo simulation each simulated study has its own draws + (version 0.1.0 used the same draws for all simulated studies). +- Numerical integration for one continuous endpoint covers the whole real + line (version 0.1.0 truncated the range). +- Probabilities are no longer set to 0 below `.Machine$double.eps^0.25`. +- Miss decisions (both criteria met) are reported in their own column with a + warning, instead of an error or being counted as Gray. +- `qdm_decide()`, `qdm_oc()` and `qdm_calibrate()` have a `seed` argument and + restore the state of the random number generator when a seed is given. + +Version 1.0.0 also has features without a counterpart in version 0.1.0: a +fixed control (`fixed_c` of the design functions) for single-arm studies +compared with a known value, one time-to-event endpoint (`design_tte()`, +see `vignette("time-to-event")`) and decision boundaries +(`qdm_boundary()`). `NEWS.md` lists all changes. diff --git a/vignettes/overview.Rmd b/vignettes/overview.Rmd index 594c713..1d00e1f 100644 --- a/vignettes/overview.Rmd +++ b/vignettes/overview.Rmd @@ -8,213 +8,235 @@ vignette: > --- ```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.path = "figures/overview-" -) +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) library(BayesianQDM) ``` -## Introduction - -The **BayesianQDM** package provides a Bayesian Quantitative Decision-Making -(QDM) framework for proof-of-concept (PoC) clinical trials. -The framework supports a three-zone Go/NoGo/Gray decision rule, in which -a Go decision recommends proceeding to the next development phase, a NoGo -decision recommends stopping development, and a Gray decision indicates -insufficient evidence to make a definitive recommendation. - -The primary use case is the evaluation of operating characteristics for a -PoC trial under a specified decision rule and sample size. -Specifically, the package can answer the following practical questions: - -- What is the probability of making a Go, NoGo, or Gray decision under a - given true treatment effect? -- What decision thresholds best control the false Go rate and false NoGo rate - simultaneously? - ---- - -## Covered Scenarios - -The package supports a wide range of PoC trial configurations through the -combination of the following dimensions. - -### Endpoint Type - -- **Binary endpoint**: e.g., response rate, where the treatment effect is - the difference in response rates $\theta = \pi_t - \pi_c$. -- **Continuous endpoint**: e.g., a biomarker or clinical score, where the - treatment effect is the difference in means $\theta = \mu_t - \mu_c$. - -Both single-endpoint and two co-primary endpoint settings are available. - -### Probability Metric - -Two complementary metrics are implemented to quantify evidence from the -PoC data: - -- **Posterior probability**: the probability, given the observed PoC data, - that the true treatment effect exceeds a clinically meaningful threshold. - This metric directly reflects the evidence accumulated in the PoC trial. -- **Posterior predictive probability**: the probability that a future - (e.g., Phase III) trial would achieve a pre-specified success criterion, - given the observed PoC data. This metric is forward-looking and accounts - for uncertainty in future trial outcomes. - -### Study Design - -Three study designs are supported: +## Decisions in a proof-of-concept study + +BayesianQDM implements the Bayesian quantitative decision-making framework +of Kang, Yamaguchi and Han (2026) for proof-of-concept (PoC) studies. The +data of a PoC study lead to one of three decisions: Go (proceed to the next +phase of development), NoGo (stop the development) or Gray (the evidence is +not sufficient for either decision). + +Let $\theta$ be the treatment effect, the difference between the treatment +and control groups in the response rate (binary endpoint), the mean +(continuous endpoint) or the survival probability at a milestone time +(time-to-event endpoint). The decision criteria use two values of the effect +chosen by the study team: the target value $\theta_{TV}$, an effect worth +pursuing, and the minimum acceptable value $\theta_{MAV} < \theta_{TV}$, +below which the treatment is not of interest. Given the PoC data $D$, the +criteria based on the posterior probability are + +- Go criterion: $\Pr(\theta > \theta_{TV} \mid D) \ge \gamma_{go}$, +- NoGo criterion: $\Pr(\theta \le \theta_{MAV} \mid D) \ge \gamma_{nogo}$. + +The decision is Go if only the Go criterion is met, NoGo if only the NoGo +criterion is met, and Gray if neither is met. If both are met, which for one +endpoint is possible only when $\gamma_{go} + \gamma_{nogo} \le 1$, the +decision is called Miss; the package reports Miss decisions separately and +warns when they have positive probability. + +Kang et al. (2026) write the NoGo criterion as +$\Pr(\theta > \theta_{MAV} \mid D) \le \gamma_2$. This is the same criterion +with $\gamma_{nogo} = 1 - \gamma_2$, so a threshold $\gamma_2 = 0.2$ of the +article corresponds to `gamma_nogo = 0.8`. + +The criteria can instead be based on the posterior predictive probability of +the effect $\tilde\theta$ that will be observed in a future study with $m_t$ +and $m_c$ subjects. With a null value $\theta_{NULL}$, the Go criterion is +$\Pr(\tilde\theta > \theta_{NULL} \mid D) \ge \gamma_{go}$ and the NoGo +criterion is $\Pr(\tilde\theta \le \theta_{NULL} \mid D) \ge \gamma_{nogo}$. + +For two endpoints, the target values and minimum acceptable values divide +the plane of $(\theta_1, \theta_2)$ into nine regions, and the criteria are +based on the probabilities of unions of regions or on each endpoint +separately (see `vignette("two-binary")` and `vignette("two-continuous")`). + +## Specifying a study + +A study is described by small specification objects, which are combined into +a design. + +| Function | Specifies | +|---|---| +| `prior_beta()`, `prior_nix()`, `prior_dirichlet()`, `prior_niw()`, `prior_gamma()`, `prior_vague()` | Prior distribution of one group | +| `data_binary()`, `data_continuous()`, `data_binary2()`, `data_continuous2()`, `data_tte()` | Summary of the data of one group | +| `borrow()` | External data and the weight $a_0$ of the power prior | +| `hypothetical()` | Hypothetical control for a study without a concurrent control group | +| `criterion_posterior()`, `criterion_predictive()` | Decision criterion | +| `conduct_tte()` | Enrollment, dropout and time of the analysis of a study with a time-to-event endpoint | +| `design_binary()`, `design_continuous()`, `design_binary2()`, `design_continuous2()`, `design_tte()` | Design of the study | + +The control group of a design takes one of four forms: a concurrent control +group (`n_c` of at least 1 for binary and time-to-event endpoints, 2 for one +continuous endpoint and 3 for two continuous endpoints), external control +data only (`n_c = 0` and `external_c`), a hypothetical control (`n_c = 0` +and `hypothetical_c`), or a fixed control (`n_c = 0` and `fixed_c`), a known +value of the control parameter as in a single-arm study compared with a +benchmark. +External data can also be borrowed for the treatment group (`external_t`). + +Four functions work with the designs. + +| Function | Computes | +|---|---| +| `qdm_decide()` | The probabilities of the Go and NoGo regions and the decision for observed data | +| `qdm_oc()` | The operating characteristics: the probabilities of Go, NoGo, Gray and Miss decisions under scenarios for the true parameters | +| `qdm_calibrate()` | The thresholds $\gamma_{go}$ and $\gamma_{nogo}$ that control the probabilities of a false Go and a false NoGo decision | +| `qdm_boundary()` | The decision for each point of a grid of possible observed data, which shows the decision boundaries (not available for two binary endpoints) | + +## A first example + +Consider a PoC study with one binary endpoint, 12 subjects in each group and +Jeffreys priors $\textrm{Beta}(0.5, 0.5)$. The team chooses +$\theta_{TV} = 0.2$, $\theta_{MAV} = 0.1$, $\gamma_{go} = 0.5$ and +$\gamma_{nogo} = 0.8$. + +```{r design} +des <- design_binary( + n_t = 12, n_c = 12, + prior_t = prior_beta(0.5, 0.5), prior_c = prior_beta(0.5, 0.5), + criterion = criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +) +des +``` -- **Controlled design**: a standard parallel-group trial with concurrent - treatment and control groups. -- **Uncontrolled design**: a single-arm trial in which the control - distribution is specified from prior knowledge rather than observed data. -- **External design**: a design that incorporates historical or external - data for the treatment group, the control group, or both, via a power - prior with a user-specified borrowing weight $\alpha_{0e} \in (0, 1]$. +If 9 of 12 subjects respond in the treatment group and 4 of 12 in the control +group, the decision is: -### Prior Distribution +```{r decide} +dec <- qdm_decide(des, data_t = data_binary(12, 9), + data_c = data_binary(12, 4)) +dec +``` -- **Vague prior** (Jeffreys prior): a non-informative prior that allows the - observed PoC data to dominate the posterior. -- **Conjugate prior**: an informative prior specified through - hyperparameters, combined with the likelihood in closed form. +The posterior probability that the effect exceeds the target value is +`r format(dec$prob_go, digits = 3)`, and the decision is +`r dec$decision`. ---- +The operating characteristics show how often the design leads to each +decision. For a binary endpoint all outcomes of the study are enumerated, so +the probabilities are exact. -## Package Structure and Function Overview - -```{r function-table, echo = FALSE} -knitr::kable(data.frame( - Function = c( - "pbayespostpred1bin()", "pbayespostpred1cont()", - "pbayespostpred2bin()", "pbayespostpred2cont()", - "pbayesdecisionprob1bin()", "pbayesdecisionprob1cont()", - "pbayesdecisionprob2bin()", "pbayesdecisionprob2cont()", - "getgamma1bin()", "getgamma1cont()", - "getgamma2bin()", "getgamma2cont()", - "pbetadiff()", "pbetabinomdiff()", - "ptdiff_NI()", "ptdiff_MC()", "ptdiff_MM()", - "rdirichlet()", - "getjointbin()", "allmultinom()" - ), - Description = c( - "Posterior/predictive probability, single binary endpoint", - "Posterior/predictive probability, single continuous endpoint", - "Region probabilities, two binary endpoints", - "Region probabilities, two continuous endpoints", - "Go/NoGo/Gray decision probabilities, single binary endpoint", - "Go/NoGo/Gray decision probabilities, single continuous endpoint", - "Go/NoGo/Gray decision probabilities, two binary endpoints", - "Go/NoGo/Gray decision probabilities, two continuous endpoints", - "Optimal Go/NoGo thresholds, single binary endpoint", - "Optimal Go/NoGo thresholds, single continuous endpoint", - "Optimal Go/NoGo thresholds, two binary endpoints", - "Optimal Go/NoGo thresholds, two continuous endpoints", - "CDF of difference of two Beta distributions", - "Beta-binomial posterior predictive probability", - "CDF of difference of two t-distributions (numerical integration)", - "CDF of difference of two t-distributions (Monte Carlo)", - "CDF of difference of two t-distributions (moment-matching)", - "Random sampler for the Dirichlet distribution", - "Joint binary probability from marginals and correlation", - "Enumerate all multinomial outcome combinations" - ) -), col.names = c("Function", "Description")) +```{r oc} +oc <- qdm_oc(des, data.frame(pi_t = seq(0.3, 0.7, by = 0.05), pi_c = 0.3)) +oc +plot(oc) ``` ---- - -## Quick-Start Examples - -### Posterior Probability: Single Binary Endpoint - -```{r qs-bin-post} -# P(pi_treat - pi_ctrl > 0.05 | data) -# Observed: 7/10 responders (treatment), 3/10 (control) -pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.05, - n_t = 10, n_c = 10, y_t = 7, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE -) +When the treatment has no effect ($\pi_t = \pi_c = 0.3$), the probability of +a Go decision is `r format(oc$Go[1], digits = 3)`. The thresholds can be +calibrated so that the probability of meeting the Go criterion is at most +0.05 under no effect, and the probability of meeting the NoGo criterion is at +most 0.2 when the effect is 0.3: + +```{r calibrate} +cal <- qdm_calibrate(des, + scenario_go = data.frame(pi_t = 0.3, pi_c = 0.3), + scenario_nogo = data.frame(pi_t = 0.6, pi_c = 0.3), + target_go = 0.05, target_nogo = 0.2) +cal +plot(cal) ``` -### Posterior Probability: Single Continuous Endpoint - -```{r qs-cont-post} -# P(mu_treat - mu_ctrl > 1.0 | data) using MM method -# Observed: mean 3.5 (treatment), 1.2 (control); SD ~ 2.0 -pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.0, nMC = NULL, - n_t = 10, n_c = 10, - bar_y_t = 3.5, s_t = 2.0, - bar_y_c = 1.2, s_c = 2.0, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL -) +The calibrated thresholds are $\gamma_{go} =$ `r cal$gamma_go` and +$\gamma_{nogo} =$ `r cal$gamma_nogo`, and `cal$design` is the design with +these thresholds, which can be passed to `qdm_decide()` and `qdm_oc()`. + +## Plots + +The `plot()` methods return ggplot2 objects. Depending on the plot, their +arguments set the colors of the decisions (`col_go`, `col_nogo`, `col_gray` +and `col_miss`), the width of the lines (`linewidth`), the size of the points +(`point_size`), the size of the text drawn in the plot (`label_size`), the +base font size (`base_size`) and the position of the legend +(`legend_position`); the help pages of `plot.qdm_oc()`, +`plot.qdm_calibration()` and `plot.qdm_boundary()` list them. Anything else +can be changed by adding ggplot2 functions, as for any other ggplot2 plot: + +```{r plot-style} +plot(oc, col_go = "darkgreen", col_nogo = "firebrick", linewidth = 0.7, + base_size = 13, legend_position = "right") + + ggplot2::labs(title = "Operating characteristics of the design") ``` -### Go/NoGo Decision: Operating Characteristics - -```{r qs-oc, fig.width = 8, fig.height = 6} -# Operating characteristics for single binary endpoint -oc_res <- pbayesdecisionprob1bin( - prob = 'posterior', - design = 'controlled', - theta_TV = 0.30, theta_MAV = 0.10, theta_NULL = NULL, - gamma_go = 0.80, gamma_nogo = 0.20, - pi_t = seq(0.15, 0.9, l = 10), - pi_c = rep(0.15, 10), - n_t = 10, n_c = 10, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) -print(oc_res) -plot(oc_res, base_size = 20) +## Endpoints and computation + +| Endpoints | Design | Model | Probabilities of the regions | Operating characteristics | +|---|---|---|---|---| +| One binary | `design_binary()` | Beta-binomial | Numerical integration (posterior), exact sum (predictive) | Exact enumeration | +| One continuous | `design_continuous()` | Normal-Inverse-chi-squared or vague | Numerical integration (`"NI"`), moment matching (`"MM"`) or Monte Carlo (`"MC"`) | Simulation of `nsim` studies | +| Two binary | `design_binary2()` | Dirichlet-multinomial | Monte Carlo with `nMC` draws (posterior), exact sum (predictive) | Exact enumeration or simulation | +| Two continuous | `design_continuous2()` | Normal-Inverse-Wishart or vague | Moment matching (`"MM"`) or Monte Carlo (`"MC"`) | Simulation of `nsim` studies | +| One time-to-event | `design_tte()` | Exponential with Gamma prior | Numerical integration (posterior), simulation of `nMC` future studies (predictive) | Simulation of `nsim` studies | + +The posterior distributions have closed forms, including those with external +data borrowed through a power prior, so Markov chain Monte Carlo sampling is +not needed. With a fixed control, the probabilities depend only on the +posterior distribution of the treatment group and are computed from closed +forms or by numerical integration, except for the posterior probabilities of +two binary endpoints and the predictive probabilities of a time-to-event +endpoint, which are Monte Carlo estimates. For one continuous endpoint, numerical integration is exact up +to a small numerical error; the moment-matching approximation is faster by +about two orders of magnitude and is suited to exploring designs, and the +chosen design can then be checked with numerical integration. For two +continuous endpoints, the moment-matching approximation can be checked with +Monte Carlo estimates. The computing time of +Monte Carlo estimates is proportional to the number of draws, and that of +simulated operating characteristics to `nsim`. + +## Random numbers + +`qdm_decide()`, `qdm_oc()`, `qdm_calibrate()` and `qdm_boundary()` have a +`seed` argument for +the random numbers they use (simulated studies and Monte Carlo estimates of +probabilities). With `seed = NULL` (the default) they use the current random +number stream, so `set.seed()` makes the results reproducible. With a given +seed, the computation uses that seed and the previous state of the random +number generator is restored on exit. `ptdiff()` with `method = "MC"` and +`rdirichlet()` always use the current random number stream. + +## Validation + +The scripts in the folder `validation` of the installed package compare +BayesianQDM with published and submitted results (Kang et al., 2026; Huang +et al., submitted; Yamaguchi, Homma, Takeda and Maruo, submitted; Yamaguchi +et al., submitted). The file +`results/summary.md` in that folder reports the comparisons, with a +registered reason for every difference beyond rounding: + +```{r validation, eval = FALSE} +system.file("validation", "results", "summary.md", package = "BayesianQDM") ``` -### Optimal Threshold Search - -```{r qs-gamma, fig.width = 8, fig.height = 6} -# Find gamma_go : smallest gamma s.t. Pr(Go) < 0.05 under Null (pi_t = pi_c = 0.15) -# Find gamma_nogo: smallest gamma s.t. Pr(NoGo) < 0.20 under Alt (pi_t = 0.35, pi_c = 0.15) -gg_res <- getgamma1bin( - prob = 'posterior', design = 'controlled', - theta_TV = 0.30, theta_MAV = 0.10, theta_NULL = NULL, - pi_t_go = 0.15, pi_c_go = 0.15, - pi_t_nogo = 0.35, pi_c_nogo = 0.15, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL -) -plot(gg_res, base_size = 20) -``` +## Further reading ---- +- `vignette("single-binary")`: one binary endpoint. +- `vignette("single-continuous")`: one continuous endpoint. +- `vignette("two-binary")`: two binary endpoints. +- `vignette("two-continuous")`: two continuous endpoints. +- `vignette("time-to-event")`: one time-to-event endpoint. +- `vignette("migration")`: translating code written for version 0.1.0. + +## References + +Huang, Y., Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Conjugate representation of power priors for efficient Bayesian analysis of +normal data. + +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. *Journal of Biopharmaceutical Statistics*. + -## Further Reading +Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Moment-matching approximation for t-differences in clinical trials with +continuous endpoints. -- `vignette("single-binary")` — detailed examples for a single binary - endpoint, covering all three designs and prior specifications. -- `vignette("single-continuous")` — detailed examples for a single - continuous endpoint, covering all three designs and calculation methods. -- `vignette("two-binary")` — detailed examples for two binary co-primary - endpoints. -- `vignette("two-continuous")` — detailed examples for two continuous - co-primary endpoints. +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. diff --git a/vignettes/single-binary.Rmd b/vignettes/single-binary.Rmd index d56ec16..2c6d7ef 100644 --- a/vignettes/single-binary.Rmd +++ b/vignettes/single-binary.Rmd @@ -1,484 +1,263 @@ --- -title: "Single Binary Endpoint" +title: "Single binary endpoint" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Single Binary Endpoint} + %\VignetteIndexEntry{Single binary endpoint} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.width = 7, - fig.height = 4.5, - fig.path = "figures/single-bin-" -) +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) library(BayesianQDM) ``` -## Motivating Scenario - -We use a hypothetical Phase IIa proof-of-concept (PoC) trial in -moderate-to-severe rheumatoid arthritis (RA). The investigational drug -is compared with placebo in a 1:1 randomised controlled trial with -$n_t = n_c = 12$ patients per group. - -Endpoint: ACR20 response rate (proportion of patients achieving -$\ge 20\%$ improvement in ACR criteria). - -Clinically meaningful thresholds (posterior probability): - -- Target Value (TV) = 0.20 (treatment–control difference) -- Minimum Acceptable Value (MAV) = 0.05 - -Null hypothesis threshold (predictive probability): -$\theta_{\mathrm{NULL}} = 0.10$. - -Decision thresholds: $\gamma_{\mathrm{go}} = 0.80$ (Go), $\gamma_{\mathrm{nogo}} = 0.20$ (NoGo). - -Observed data (used in Sections 2–4): -$y_t = 8$ responders out of $n_t = 12$ (treatment); -$y_c = 3$ responders out of $n_c = 12$ (control). - ---- - -## 1. Bayesian Model: Beta-Binomial Conjugate - -### 1.1 Prior Distribution - -Let $\pi_j$ denote the true response rate in group $j$ -($j = t$: treatment, $j = c$: control). We model the number of -responders as - -$$y_j \mid \pi_j \;\sim\; \mathrm{Binomial}(n_j,\, \pi_j),$$ - -and place independent Beta priors on each rate: - -$$\pi_j \;\sim\; \mathrm{Beta}(a_j,\, b_j),$$ - -where $a_j > 0$ and $b_j > 0$ are the shape parameters. - -The Jeffreys prior corresponds to $a_j = b_j = 0.5$, giving a -weakly informative, symmetric prior on $(0, 1)$. -The uniform prior corresponds to $a_j = b_j = 1$. - -### 1.2 Posterior Distribution - -By conjugacy of the Beta-Binomial model, the posterior after observing -$y_j$ responders among $n_j$ patients is - -$$\pi_j \mid y_j \;\sim\; \mathrm{Beta}(a_j^*,\, b_j^*),$$ - -where the posterior shape parameters are - -$$a_j^* = a_j + y_j, \qquad b_j^* = b_j + n_j - y_j.$$ - -The posterior mean and variance are - -$$E[\pi_j \mid y_j] = \frac{a_j^*}{a_j^* + b_j^*}, \qquad - \mathrm{Var}(\pi_j \mid y_j) = - \frac{a_j^*\, b_j^*}{(a_j^* + b_j^*)^2\,(a_j^* + b_j^* + 1)}.$$ - -### 1.3 Posterior of the Treatment Effect - -The treatment effect is $\theta = \pi_t - \pi_c$. Since the two -groups are independent, -$\theta \mid y_t, y_c$ follows the distribution of the difference -of two independent Beta random variables: - -$$\pi_t \mid y_t \;\sim\; \mathrm{Beta}(a_t^*,\, b_t^*), \qquad - \pi_c \mid y_c \;\sim\; \mathrm{Beta}(a_c^*,\, b_c^*).$$ - -There is no closed-form CDF for $\theta = \pi_t - \pi_c$, so the -posterior probability - -$$P(\theta > \theta_0 \mid y_t, y_c) = P(\pi_t - \pi_c > \theta_0 - \mid y_t, y_c)$$ - -is evaluated by the convolution integral implemented in `pbetadiff()`: - -$$P(\pi_t - \pi_c > \theta_0) = - \int_0^1 - F_{\mathrm{Beta}(a_c^*, b_c^*)}\!\left(x - \theta_0\right)\, - f_{\mathrm{Beta}(a_t^*, b_t^*)}\!(x)\; dx,$$ - -where $F_{\mathrm{Beta}(\alpha,\beta)}$ is the Beta CDF and -$f_{\mathrm{Beta}(\alpha,\beta)}$ is the Beta PDF. -This one-dimensional integral is evaluated by adaptive Gauss-Kronrod -quadrature via `stats::integrate()`. - ---- - -## 2. Posterior Predictive Probability - -### 2.1 Beta-Binomial Predictive Distribution +This vignette describes the analysis of a proof-of-concept (PoC) study with +one binary endpoint (Kang, Yamaguchi and Han, 2026). `vignette("overview")` +introduces the decision criteria. + +## Model + +In group $k$ ($k = t$ for treatment, $c$ for control), $y_k$ of $n_k$ +subjects respond, $y_k \sim \textrm{Binomial}(n_k, \pi_k)$, and the response +rate has the prior distribution $\pi_k \sim \textrm{Beta}(a_k, b_k)$ +(`prior_beta()`; `prior_beta(0.5, 0.5)` is the Jeffreys prior). The +posterior distribution is +$$\pi_k \mid y_k \sim \textrm{Beta}(a_k + y_k, b_k + n_k - y_k),$$ +and the treatment effect is $\theta = \pi_t - \pi_c$. The posterior +probability $\Pr(\theta > q \mid D)$ is computed by numerical integration +(`pbetadiff()`). + +For the predictive criterion, $m_k$ future subjects of group $k$ have +$\tilde y_k$ responders, whose posterior predictive distribution is +beta-binomial. The future effect is +$\tilde\theta = \tilde y_t / m_t - \tilde y_c / m_c$, and its predictive +probabilities are computed exactly by summation (`pbetabinomdiff()`). + +## Decision for observed data + +A study with 12 subjects in each group, Jeffreys priors and a posterior +criterion with $\theta_{TV} = 0.2$, $\theta_{MAV} = 0.1$, +$\gamma_{go} = 0.5$ and $\gamma_{nogo} = 0.8$: + +```{r design} +jeffreys <- prior_beta(0.5, 0.5) +crit <- criterion_posterior(theta_tv = 0.2, theta_mav = 0.1, + gamma_go = 0.5, gamma_nogo = 0.8) +des <- design_binary(n_t = 12, n_c = 12, prior_t = jeffreys, + prior_c = jeffreys, criterion = crit) +dec <- qdm_decide(des, data_t = data_binary(12, 9), + data_c = data_binary(12, 3)) +dec +``` -Let $\tilde{y}_j \mid \pi_j \sim \mathrm{Binomial}(m_j, \pi_j)$ be -future trial counts with $m_j$ future patients. Integrating out $\pi_j$ -over its Beta posterior gives the Beta-Binomial predictive distribution: +The probabilities of the Go and NoGo regions are the posterior probabilities +$\Pr(\theta > 0.2 \mid D)$ and $\Pr(\theta \le 0.1 \mid D)$, which +`pbetadiff()` gives from the posterior parameters: + +```{r pbetadiff} +post_t <- dec$posterior_t +post_c <- dec$posterior_c +pbetadiff(0.2, a_t = post_t[["a"]], b_t = post_t[["b"]], + a_c = post_c[["a"]], b_c = post_c[["b"]], lower.tail = FALSE) +pbetadiff(0.1, a_t = post_t[["a"]], b_t = post_t[["b"]], + a_c = post_c[["a"]], b_c = post_c[["b"]]) +``` -$$P(\tilde{y}_j = k \mid y_j) = - \binom{m_j}{k} - \frac{B(a_j^* + k,\; b_j^* + m_j - k)}{B(a_j^*,\; b_j^*)}, - \quad k = 0, 1, \ldots, m_j,$$ +With 9 and 3 responders, the decision is `r dec$decision`. -where $B(\cdot, \cdot)$ is the Beta function. +## Forms of the control group -### 2.2 Posterior Predictive Probability of Future Success +### External control data -The posterior predictive probability that the future treatment difference -exceeds $\theta_{\mathrm{NULL}}$ is +External data enter through a power prior: with $n_e$ subjects, +$y_e$ responders and weight $a_0$ (from 0 to 1), the posterior distribution +of the response rate is +$$\textrm{Beta}(a + a_0 y_e + y, \; b + a_0 (n_e - y_e) + n - y).$$ +With $a_0 = 0$ the external data are ignored, and with $a_0 = 1$ they are +pooled with the current data. Borrowing half of 20 external control +subjects with 5 responders: -$$P\!\left(\frac{\tilde{y}_t}{m_t} - \frac{\tilde{y}_c}{m_c} - > \theta_{\mathrm{NULL}} \;\Big|\; y_t, y_c\right) - = \sum_{k_t=0}^{m_t} \sum_{k_c=0}^{m_c} - \mathbf{1}\!\left[\frac{k_t}{m_t} - \frac{k_c}{m_c} > - \theta_{\mathrm{NULL}}\right]\, - P(\tilde{y}_t = k_t \mid y_t)\, - P(\tilde{y}_c = k_c \mid y_c).$$ +```{r external} +des_ext <- design_binary( + n_t = 12, n_c = 12, prior_t = jeffreys, prior_c = jeffreys, + criterion = crit, + external_c = borrow(data_binary(n = 20, y = 5), a0 = 0.5) +) +dec_ext <- qdm_decide(des_ext, data_t = data_binary(12, 9), + data_c = data_binary(12, 3)) +dec_ext$posterior_c +``` -This double sum over all $(m_t + 1)(m_c + 1)$ outcome combinations is -evaluated exactly by `pbetabinomdiff()`. +The external data add +`r dec_ext$posterior_c[["a"]] - dec$posterior_c[["a"]]` responders and +`r dec_ext$posterior_c[["b"]] - dec$posterior_c[["b"]]` non-responders to the +posterior distribution of the control group, and the +probability of the Go region becomes +`r format(dec_ext$prob_go, digits = 3)` (without them, +`r format(dec$prob_go, digits = 3)`). + +Without a concurrent control group (`n_c = 0`), the control group can be +described by the external data alone: + +```{r external-only} +des_ext0 <- design_binary( + n_t = 12, n_c = 0, prior_t = jeffreys, prior_c = jeffreys, + criterion = crit, + external_c = borrow(data_binary(n = 40, y = 10), a0 = 1) +) +qdm_decide(des_ext0, data_t = data_binary(12, 9)) +``` ---- +External treatment data (`external_t`) can be used in the same way with any +form of the control group. -## 3. Study Designs +### Hypothetical control -### 3.1 Controlled Design +For an uncontrolled study, Kang et al. (2026, Section 4.1.4) describe the +control response rate by a hypothetical control, +$\pi_c \sim \textrm{Beta}(a_t + z, b_t + n_t - z)$, where $z$ is the number +of responders expected among $n_t$ control subjects. This is obtained with +`prior_c` equal to `prior_t` and `hypothetical(data_binary(n_t, z))`: -Standard parallel-group RCT with observed data from both groups. The -posterior shape parameters for group $j$ are +```{r hypothetical} +des_hyp <- design_binary( + n_t = 12, n_c = 0, prior_t = jeffreys, prior_c = jeffreys, + criterion = crit, + hypothetical_c = hypothetical(data = data_binary(n = 12, y = 3)) +) +qdm_decide(des_hyp, data_t = data_binary(12, 9)) +``` -$$a_j^* = a_j + y_j, \qquad b_j^* = b_j + n_j - y_j,$$ +### Fixed control + +A single-arm study is often compared with a known benchmark, such as the +response rate of the standard of care reported in the literature. With +`fixed_c`, the control response rate is a known value $\pi_{c0}$, the +treatment effect is $\theta = \pi_t - \pi_{c0}$, and `prior_c` is not used +(it must be `NULL`). The probability of the Go region is then the Beta +probability $\Pr(\pi_t > \pi_{c0} + \theta_{TV} \mid D)$. A study with 20 +subjects compared with a benchmark of 0.2: + +```{r fixed} +crit_fix <- criterion_posterior(theta_tv = 0.2, theta_mav = 0.05, + gamma_go = 0.8, gamma_nogo = 0.8) +des_fix <- design_binary(n_t = 20, n_c = 0, prior_t = prior_beta(1, 1), + criterion = crit_fix, fixed_c = 0.2) +dec_fix <- qdm_decide(des_fix, data_t = data_binary(20, 11)) +dec_fix +pbeta(0.2 + 0.2, 1 + 11, 1 + 20 - 11, lower.tail = FALSE) +``` -and the posterior probability is $P(\pi_t - \pi_c > \theta_0 \mid y_t, y_c)$ -computed via `pbetadiff()`. +With `fixed_c = 0`, the effect is the response rate itself, and the +thresholds are response rates. For the predictive criterion, the future +effect is $\tilde y_t / m_t - \pi_{c0}$, and `m_c` is not used. -Posterior probability at TV and MAV: +## Predictive criterion -```{r ctrl-post} -# P(pi_t - pi_c > TV | data) -p_tv <- pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = 8, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE -) +The predictive criterion asks whether a future study with $m_t$ and $m_c$ +subjects would observe an effect larger than $\theta_{NULL}$. With 40 +subjects per group in the future study and $\theta_{NULL} = 0$: -# P(pi_t - pi_c > MAV | data) -p_mav <- pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.05, - n_t = 12, n_c = 12, y_t = 8, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE +```{r predictive} +des_pred <- design_binary( + n_t = 12, n_c = 12, prior_t = jeffreys, prior_c = jeffreys, + criterion = criterion_predictive(theta_null = 0, m_t = 40, + gamma_go = 0.9, gamma_nogo = 0.7) ) - -cat(sprintf("P(theta > TV | data) = %.4f -> Go criterion (>= %.2f): %s\n", - p_tv, 0.80, ifelse(p_tv >= 0.80, "YES", "NO"))) -cat(sprintf("P(theta <= MAV | data) = %.4f -> NoGo criterion (>= %.2f): %s\n", - 1 - p_mav, 0.20, ifelse((1 - p_mav) >= 0.20, "YES", "NO"))) -cat(sprintf("Decision: %s\n", - ifelse(p_tv >= 0.80 & (1 - p_mav) < 0.20, "Go", - ifelse(p_tv < 0.80 & (1 - p_mav) >= 0.20, "NoGo", - ifelse(p_tv >= 0.80 & (1 - p_mav) >= 0.20, "Miss", "Gray"))))) +dec_pred <- qdm_decide(des_pred, data_t = data_binary(12, 9), + data_c = data_binary(12, 3)) +dec_pred +post_t <- dec_pred$posterior_t +post_c <- dec_pred$posterior_c +pbetabinomdiff(0, m_t = 40, a_t = post_t[["a"]], b_t = post_t[["b"]], + m_c = 40, a_c = post_c[["a"]], b_c = post_c[["b"]], + lower.tail = FALSE) ``` -Posterior predictive probability (future Phase III: $m_t = m_c = 40$): - -```{r ctrl-pred} -p_pred <- pbayespostpred1bin( - prob = 'predictive', design = 'controlled', theta0 = 0.10, - n_t = 12, n_c = 12, y_t = 8, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = 40, m_c = 40, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE -) -cat(sprintf("Predictive probability (m_t = m_c = 40) = %.4f\n", p_pred)) -``` - -Vectorised computation over all possible outcomes: - -The function accepts vectors for `y_t` and `y_c`, enabling efficient -computation of the posterior probability for every possible outcome pair -$(y_t, y_c) \in \{0,\ldots,n_t\} \times \{0,\ldots,n_c\}$. - -```{r ctrl-vector} -grid <- expand.grid(y_t = 0:12, y_c = 0:12) -p_all <- pbayespostpred1bin( - prob = 'posterior', design = 'controlled', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = grid$y_t, y_c = grid$y_c, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE -) -# Show results for a selection of outcome pairs -sel <- data.frame(y_t = grid$y_t, y_c = grid$y_c, P_gt_TV = round(p_all, 4)) -head(sel[order(-sel$P_gt_TV), ], 10) -``` +The Go and NoGo regions of the predictive criterion are complementary, so +their probabilities add up to 1. A Gray decision is then possible only when +$\gamma_{go} + \gamma_{nogo} > 1$. -### 3.2 Uncontrolled Design (Single-Arm) +## Operating characteristics -When no concurrent control group is enrolled, a hypothetical control -responder count $z$ is specified from historical knowledge. The -control posterior is then +`qdm_oc()` computes the probabilities of Go, NoGo, Gray and Miss decisions +under scenarios for the true response rates. All outcomes +$(y_t, y_c)$ of the study are enumerated and weighted by their binomial +probabilities, so the results are exact. -$$\pi_c \mid z \;\sim\; \mathrm{Beta}(a_c + z,\; b_c + n_c - z),$$ +```{r oc} +oc <- qdm_oc(des, data.frame(pi_t = seq(0.2, 0.8, by = 0.05), pi_c = 0.2)) +oc +plot(oc) +``` -where $n_c$ is the hypothetical control sample size and $z$ is the -assumed number of hypothetical responders ($0 \le z \le n_c$). Only the -treatment group data $y_t$ are observed; $y_c$ is set to `NULL`. +The vertical lines mark the effects $\theta_{MAV}$ and $\theta_{TV}$. For +the uncontrolled design, the horizontal axis is the response rate of the +treatment group, and the lines are shifted by the mean of the hypothetical +control distribution: -```{r unctrl-post} -# Hypothetical control: z = 2 responders out of n_c = 12 -p_unctrl <- pbayespostpred1bin( - prob = 'posterior', design = 'uncontrolled', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = 8, y_c = NULL, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = 2L, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE -) -cat(sprintf("P(theta > TV | data, uncontrolled, z=2) = %.4f\n", p_unctrl)) +```{r oc-hyp} +oc_hyp <- qdm_oc(des_hyp, data.frame(pi_t = seq(0.2, 0.8, by = 0.05))) +plot(oc_hyp) ``` -Effect of the hypothetical control count: varying $z$ shows the -sensitivity to the assumed control rate. - -```{r unctrl-z-sens} -z_seq <- 0:12 -p_z <- sapply(z_seq, function(z) { - pbayespostpred1bin( - prob = 'posterior', design = 'uncontrolled', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = 8, y_c = NULL, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = z, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - lower.tail = FALSE - ) -}) -data.frame(z = z_seq, P_gt_TV = round(p_z, 4)) -``` +## Decision boundary -### 3.3 External Design (Power Prior) - -Historical or external data are incorporated via a power prior with -borrowing weight $\alpha_{0ej} \in (0, 1]$. The augmented prior shape -parameters are - -$$a_j^* = a_j + \alpha_{0ej}\, y_{ej}, \qquad - b_j^* = b_j + \alpha_{0ej}\,(n_{ej} - y_{ej}),$$ - -where $n_{ej}$ and $y_{ej}$ are the external sample size and responder -count for group $j$ -(corresponding to `ne_t`/`ne_c`, `ye_t`/`ye_c`, and `alpha0e_t`/`alpha0e_c`). -These serve as the prior for the current PoC data, -yielding a closed-form posterior: - -$$\pi_j \mid y_j \;\sim\; - \mathrm{Beta}\!\left(a_j^* + y_j,\; b_j^* + n_j - y_j\right).$$ - -Setting $\alpha_{0ej} = 1$ corresponds to full borrowing (the external -data are treated as if they came from the current trial); $\alpha_{0ej} \to 0$ -recovers the result from the current data alone with the original prior. - -Here, external data for both groups (external design): -$n_{et} = 15$, $y_{et} = 5$, -$n_{ec} = 15$, $y_{ec} = 4$, borrowing weights $\alpha_{0et} = \alpha_{0ec} = 0.5$: - -```{r ext-post} -p_ext <- pbayespostpred1bin( - prob = 'posterior', design = 'external', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = 8, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = 15L, ne_c = 15L, ye_t = 5L, ye_c = 4L, - alpha0e_t = 0.5, alpha0e_c = 0.5, - lower.tail = FALSE -) -cat(sprintf("P(theta > TV | data, external, alpha0e=0.5) = %.4f\n", p_ext)) -``` +`qdm_boundary()` gives the decision for every possible outcome of the study, +and its plot shows which outcomes lead to Go, NoGo and Gray decisions. +Unlike the operating characteristics, it does not depend on the true +response rates. For the design with a concurrent control group, the axes are +the numbers of responders of the two groups: -Effect of the borrowing weight: varying $\alpha_{0ec}$ (control group -only) with fixed $\alpha_{0et} = 0.5$: - -```{r ext-borrowing} -# alpha0e must be in (0, 1]; avoid alpha0e = 0 -ae_seq <- c(0.01, seq(0.1, 1.0, by = 0.1)) -p_ae <- sapply(ae_seq, function(ae) { - pbayespostpred1bin( - prob = 'posterior', design = 'external', theta0 = 0.20, - n_t = 12, n_c = 12, y_t = 8, y_c = 3, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - m_t = NULL, m_c = NULL, z = NULL, - ne_t = 15L, ne_c = 15L, ye_t = 5L, ye_c = 4L, - alpha0e_t = 0.5, alpha0e_c = ae, - lower.tail = FALSE - ) -}) -data.frame(alpha0e_c = ae_seq, P_gt_TV = round(p_ae, 4)) +```{r boundary} +plot(qdm_boundary(des)) ``` ---- +Without a concurrent control group, the boundary is shown for several sample +sizes of the treatment group, here from 10 to 40 subjects for the design +with a fixed control: -## 4. Operating Characteristics - -### 4.1 Definition - -For given true response rates $(\pi_t, \pi_c)$, the operating -characteristics are computed by exact enumeration over all -$(n_t + 1)(n_c + 1)$ possible outcome pairs -$(y_t, y_c) \in \{0,\ldots,n_t\} \times \{0,\ldots,n_c\}$: - -$$\Pr(\mathrm{Go}) = - \sum_{y_t=0}^{n_t} \sum_{y_c=0}^{n_c} - \mathbf{1}\!\left[g_{\mathrm{Go}}(y_t, y_c) \ge \gamma_{\mathrm{go}} - \;\text{ and }\; g_{\mathrm{NoGo}}(y_t, y_c) < \gamma_{\mathrm{nogo}}\right]\, - \binom{n_t}{y_t} \pi_t^{y_t}(1-\pi_t)^{n_t-y_t}\, - \binom{n_c}{y_c} \pi_c^{y_c}(1-\pi_c)^{n_c-y_c},$$ - -where - -$$g_{\mathrm{Go}}(y_t, y_c) = P(\pi_t - \pi_c > \theta_{\mathrm{TV}} \mid y_t, y_c),$$ -$$g_{\mathrm{NoGo}}(y_t, y_c) = P(\pi_t - \pi_c \le \theta_{\mathrm{MAV}} \mid y_t, y_c),$$ - -and the decision outcomes are classified as: - -- Go: $g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}}$ AND $g_{\mathrm{NoGo}} < \gamma_{\mathrm{nogo}}$ -- NoGo: $g_{\mathrm{Go}} < \gamma_{\mathrm{go}}$ AND $g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}}$ -- Miss: $g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}}$ AND $g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}}$ -- Gray: neither Go nor NoGo criterion met - -### 4.2 Example: Controlled Design, Posterior Probability - -```{r oc-controlled, fig.width = 8, fig.height = 6} -oc_ctrl <- pbayesdecisionprob1bin( - prob = 'posterior', - design = 'controlled', - theta_TV = 0.30, theta_MAV = 0.15, theta_NULL = NULL, - gamma_go = 0.80, gamma_nogo = 0.20, - pi_t = seq(0.10, 0.80, by = 0.05), - pi_c = rep(0.10, length(seq(0.10, 0.80, by = 0.05))), - n_t = 12, n_c = 12, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) -print(oc_ctrl) -plot(oc_ctrl, base_size = 20) +```{r boundary-fixed} +b_fix <- qdm_boundary(des_fix, n_t = 10:40) +plot(b_fix) ``` -The same function supports `design = 'uncontrolled'` (with argument `z`), -`design = 'external'` (with power prior arguments `ne_t`, `ne_c`, `ye_t`, -`ye_c`, `alpha0e_t`, `alpha0e_c`), and `prob = 'predictive'` (with future -sample size arguments `m_t`, `m_c` and `theta_NULL`). The function signature -and output format are identical across all combinations. +With 20 subjects, a Go decision needs at least +`r min(b_fix$y_t[b_fix$n_t == 20 & b_fix$decision == "Go"])` responders, and +the decision is NoGo with at most +`r max(b_fix$y_t[b_fix$n_t == 20 & b_fix$decision == "NoGo"])` responders. + +## Calibration of the thresholds + +`qdm_calibrate()` chooses $\gamma_{go}$ as the smallest value of a grid for +which the probability of meeting the Go criterion under `scenario_go` is at +most `target_go`, and $\gamma_{nogo}$ in the same way for the NoGo criterion +under `scenario_nogo`. Here the Go criterion should be met with probability +at most 0.05 when the treatment has no effect, and the NoGo criterion with +probability at most 0.2 when the effect is 0.3: + +```{r calibrate} +cal <- qdm_calibrate(des, + scenario_go = data.frame(pi_t = 0.2, pi_c = 0.2), + scenario_nogo = data.frame(pi_t = 0.5, pi_c = 0.2), + target_go = 0.05, target_nogo = 0.2) +cal +plot(cal) +``` ---- +The chosen thresholds are $\gamma_{go} =$ `r cal$gamma_go` and +$\gamma_{nogo} =$ `r cal$gamma_nogo`. The design with these thresholds is +`cal$design`: -## 5. Optimal Threshold Search - -### 5.1 Objective and Algorithm - -The `getgamma1bin()` function finds the optimal pair -$(\gamma_{\mathrm{go}}^*, \gamma_{\mathrm{nogo}}^*)$ by grid search over -$\Gamma = \{\gamma^{(1)}, \ldots, \gamma^{(K)}\} \subset (0, 1)$ at a -null scenario $(\pi_t^{\mathrm{null}}, \pi_c^{\mathrm{null}})$. - -A two-stage precompute-then-sweep strategy is used: - -Stage 1 (Precompute): all posterior/predictive probabilities -$g_{\mathrm{Go}}(y_t, y_c)$ and $g_{\mathrm{NoGo}}(y_t, y_c)$ are -computed once over all $(n_t + 1)(n_c + 1)$ outcome pairs — independently -of $\gamma$. - -Stage 2 (Sweep): for each candidate $\gamma \in \Gamma$, -$\Pr(\mathrm{Go} \mid \gamma)$ and $\Pr(\mathrm{NoGo} \mid \gamma)$ -are obtained as weighted sums of indicator functions: - -$$\Pr(\mathrm{Go} \mid \gamma) = \sum_{y_t, y_c} - \mathbf{1}\!\left[g_{\mathrm{Go}}(y_t, y_c) \ge \gamma\right]\, - w(y_t, y_c),$$ - -$$\Pr(\mathrm{NoGo} \mid \gamma) = \sum_{y_t, y_c} - \mathbf{1}\!\left[g_{\mathrm{NoGo}}(y_t, y_c) \ge \gamma\right]\, - w(y_t, y_c),$$ - -where $w(y_t, y_c) = \mathrm{Binom}(y_t; n_t, \pi_t)\,\mathrm{Binom}(y_c; n_c, \pi_c)$ -are the binomial weights under the null scenario. No further calls to -`pbayespostpred1bin()` are required at this stage. - -The sweep is vectorised using `outer()`, making the full grid search -computationally negligible once Stage 1 is complete. - -The optimal $\gamma_{\mathrm{go}}^*$ is the smallest value in $\Gamma$ such that -$\Pr(\mathrm{Go} \mid \gamma_{\mathrm{go}}^*)$ satisfies the criterion against a -target (e.g., $\Pr(\mathrm{Go}) < 0.05$). Analogously for $\gamma_{\mathrm{nogo}}^*$. - -### 5.2 Example: Controlled Design, Posterior Probability - -```{r getgamma-ctrl, fig.width = 8, fig.height = 6} -res_gamma <- getgamma1bin( - prob = 'posterior', - design = 'controlled', - theta_TV = 0.30, theta_MAV = 0.15, theta_NULL = NULL, - pi_t_go = 0.10, pi_c_go = 0.10, - pi_t_nogo = 0.30, pi_c_nogo = 0.10, - target_go = 0.05, target_nogo = 0.20, - n_t = 12L, n_c = 12L, - a_t = 0.5, b_t = 0.5, a_c = 0.5, b_c = 0.5, - z = NULL, m_t = NULL, m_c = NULL, - ne_t = NULL, ne_c = NULL, ye_t = NULL, ye_c = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01) -) -plot(res_gamma, base_size = 20) +```{r calibrated-oc} +qdm_oc(cal$design, data.frame(pi_t = c(0.2, 0.35, 0.5), pi_c = 0.2)) ``` -The same function supports `design = 'uncontrolled'` (with `pi_t_go`, -`pi_t_nogo`, and `z`), `design = 'external'` (with power prior arguments), -and `prob = 'predictive'` (with `theta_NULL`, `m_t`, and `m_c`). The -calibration plot and the returned `gamma_go`/`gamma_nogo` values are -available for all combinations. - ---- +## Reference -## 6. Summary - -This vignette covered single binary endpoint analysis in BayesianQDM: - -1. Bayesian model: Beta-Binomial conjugate posterior with explicit - update formulae for $a_j^* = a_j + y_j$ and $b_j^* = b_j + n_j - y_j$; - Jeffreys prior ($a_j = b_j = 0.5$) as the recommended weakly - informative default. -2. Posterior probability: evaluated via the convolution integral - in `pbetadiff()` — no closed-form CDF exists for the Beta difference. -3. Posterior predictive probability: evaluated by exact enumeration - of the Beta-Binomial double sum in `pbetabinomdiff()`. -4. Three study designs: controlled (both groups observed), uncontrolled - (hypothetical control count $z$ fixed from prior knowledge), external - design (power prior with borrowing weight $\alpha_{0ej}$, augmenting - the prior by $\alpha_{0ej}$ times the external sufficient statistics). -5. Operating characteristics: computed by exact enumeration over all - $(n_t+1)(n_c+1)$ outcome pairs with binomial probability weights — - no simulation required for the binary endpoint. -6. Optimal threshold search: two-stage precompute-then-sweep strategy - in `getgamma1bin()` using `outer()` for a fully vectorised gamma sweep. - -See `vignette("single-continuous")` for the analogous continuous endpoint -analysis. +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. *Journal of Biopharmaceutical Statistics*. + diff --git a/vignettes/single-continuous.Rmd b/vignettes/single-continuous.Rmd index 727632d..09b60df 100644 --- a/vignettes/single-continuous.Rmd +++ b/vignettes/single-continuous.Rmd @@ -1,682 +1,275 @@ --- -title: "Single Continuous Endpoint" +title: "Single continuous endpoint" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Single Continuous Endpoint} + %\VignetteIndexEntry{Single continuous endpoint} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.width = 7, - fig.height = 4.5, - fig.path = "figures/single-cont-" -) +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) library(BayesianQDM) ``` -## Motivating Scenario - -We use a hypothetical Phase IIa proof-of-concept (PoC) trial in -moderate-to-severe rheumatoid arthritis (RA). The investigational drug -is compared with placebo in a 1:1 randomised controlled trial with -$n_t = n_c = 15$ patients per group. - -Endpoint: change from baseline in DAS28 score (a larger decrease -indicates greater improvement). - -Clinically meaningful thresholds (posterior probability): - -- Target Value ($\theta_{\mathrm{TV}}$) = 1.5 (ambitious target) -- Minimum Acceptable Value ($\theta_{\mathrm{MAV}}$) = 0.5 (lower bar) - -Null hypothesis threshold (predictive probability): -$\theta_{\mathrm{NULL}} = 1.0$. - -Decision thresholds: $\gamma_{\mathrm{go}} = 0.80$ (Go), -$\gamma_{\mathrm{nogo}} = 0.20$ (NoGo). - -Observed data (used in Sections 2--4): -$\bar{y}_t = 3.2$, $s_t = 2.0$ (treatment); -$\bar{y}_c = 1.1$, $s_c = 1.8$ (control). - ---- - -## 1. Bayesian Model: Normal-Inverse-Chi-Squared Conjugate - -### 1.1 Prior Distribution - -For group $j$ ($j = t$: treatment, $j = c$: control), patient $i$ -($i = 1, \ldots, n_j$), we model the continuous outcome as - -$$y_{ij} \mid \mu_j, \sigma_j^2 \;\overset{iid}{\sim}\; - \mathcal{N}(\mu_j,\, \sigma_j^2).$$ - -The conjugate prior is the Normal-Inverse-Chi-squared (N-Inv-$\chi^2$) -distribution: - -$$(\mu_j,\, \sigma_j^2) \;\sim\; - \mathrm{N\text{-}Inv\text{-}\chi^2} - \!\left(\mu_{0j},\, \kappa_{0j},\, \nu_{0j},\, \sigma_{0j}^2\right),$$ - -where $\mu_{0j}$ (`mu0_t`, `mu0_c`) is the prior mean, -$\kappa_{0j}$ (`kappa0_t`, `kappa0_c`) $> 0$ the prior precision -(pseudo-sample size), $\nu_{0j}$ (`nu0_t`, `nu0_c`) $> 0$ the prior -degrees of freedom, and $\sigma_{0j}^2$ (`sigma0_t`, `sigma0_c`) $> 0$ -the prior scale. - -The vague (Jeffreys) prior is obtained by letting -$\kappa_{0j} \to 0$ and $\nu_{0j} \to 0$, which places minimal information -on the parameters. - -### 1.2 Posterior Distribution - -Given $n_j$ observations with sample mean $\bar{y}_j$ and sample standard -deviation $s_j$, the posterior parameters are updated as follows: - -$$\kappa_{nj} = \kappa_{0j} + n_j, \qquad - \nu_{nj} = \nu_{0j} + n_j,$$ - -$$\mu_{nj} = \frac{\kappa_{0j}\,\mu_{0j} + n_j\,\bar{y}_j}{\kappa_{nj}},$$ - -$$\sigma_{nj}^2 = \frac{\nu_{0j}\,\sigma_{0j}^2 + (n_j - 1)\,s_j^2 + - \dfrac{n_j\,\kappa_{0j}}{\kappa_{nj}}\,(\mu_{0j} - \bar{y}_j)^2} - {\nu_{nj}}.$$ - -The marginal posterior of the group mean $\mu_j$ is a non-standardised -$t$-distribution: - -$$\mu_j \mid \mathbf{y}_j \;\sim\; - t_{\nu_{nj}}\!\!\left(\mu_{nj},\; - \frac{\sigma_{nj}}{\sqrt{\kappa_{nj}}}\right).$$ - -Under the vague prior ($\kappa_{0j} = \nu_{0j} = 0$), this simplifies to - -$$\mu_j \mid \mathbf{y}_j \;\sim\; - t_{n_j - 1}\!\!\left(\bar{y}_j,\; - \frac{s_j}{\sqrt{n_j}}\right).$$ - -### 1.3 Posterior of the Treatment Effect - -The treatment effect is $\theta = \mu_t - \mu_c$. Since the two groups -are independent, the posterior of $\theta$ is the distribution of the -difference of two independent non-standardised $t$-variables: - -$$T_j \;\sim\; t_{\nu_{nj}}(\mu_{nj},\, \sigma_{nj}^{\dagger}), \qquad - j = t, c,$$ - -where the posterior scale is -$\sigma_{nj}^{\dagger} = \sigma_{nj} / \sqrt{\kappa_{nj}}$. - -The posterior probability that $\theta$ exceeds a threshold $\theta_0$, - -$$P(\theta > \theta_0 \mid \mathbf{y}) = - P(T_t - T_c > \theta_0),$$ - -is computed by one of three methods described in Section 3. - ---- - -## 2. Posterior Predictive Probability - -### 2.1 Predictive Distribution - -Let $\bar{\tilde{y}}_j$ denote the future sample mean based on $m_j$ -future patients. Under the N-Inv-$\chi^2$ posterior, the predictive -distribution of $\bar{\tilde{y}}_j$ is again a non-standardised -$t$-distribution: - -$$\bar{\tilde{y}}_j \mid \mathbf{y}_j \;\sim\; - t_{\nu_{nj}}\!\!\left(\mu_{nj},\; - \sigma_{nj}\sqrt{\frac{1 + \kappa_{nj}}{\kappa_{nj}\, m_j}}\right).$$ - -Under the vague prior ($\kappa_{nj} = n_j$, $\sigma_{nj} = s_j$) this becomes - -$$\bar{\tilde{y}}_j \mid \mathbf{y}_j \;\sim\; - t_{n_j - 1}\!\!\left(\bar{y}_j,\; - s_j\sqrt{\frac{n_j + 1}{n_j\, m_j}}\right).$$ - -### 2.2 Posterior Predictive Probability - -The posterior predictive probability that the future treatment effect -exceeds the null threshold $\theta_{\mathrm{NULL}}$ is - -$$P\!\left(\bar{\tilde{y}}_t - \bar{\tilde{y}}_c > \theta_{\mathrm{NULL}} - \mid \mathbf{y}\right),$$ - -computed by the same three methods as the posterior probability but with -the predictive scale replacing the posterior scale. - ---- - -## 3. Three Computation Methods - -### 3.1 Numerical Integration (NI) - -The exact CDF of $D = T_t - T_c$ is expressed as a one-dimensional integral: - -$$P(D \le \theta_0) = - \int_{-\infty}^{\infty} - F_{t_{\nu_c}(\mu_c, \sigma_c)}\!\left(t - \theta_0\right)\, - f_{t_{\nu_t}(\mu_t, \sigma_t)}(t)\; dt,$$ - -where $F_{t_\nu(\mu,\sigma)}$ and $f_{t_\nu(\mu,\sigma)}$ are the CDF and -PDF of the non-standardised $t$-distribution respectively. This integral is -evaluated by `stats::integrate()` (adaptive Gauss-Kronrod quadrature) in -`ptdiff_NI()`. The method is exact but evaluates the integral once per call -and is therefore slow for large-scale simulation. - -### 3.2 Monte Carlo Simulation (MC) - -$n_{\mathrm{MC}}$ independent samples are drawn from each marginal: - -$$T_t^{(i)} \;\sim\; t_{\nu_t}(\mu_t, \sigma_t), \quad - T_c^{(i)} \;\sim\; t_{\nu_c}(\mu_c, \sigma_c), \quad - i = 1, \ldots, n_{\mathrm{MC}},$$ - -and the probability is estimated as - -$$\widehat{P}(D > \theta_0) = - \frac{1}{n_{\mathrm{MC}}} - \sum_{i=1}^{n_{\mathrm{MC}}} - \mathbf{1}\!\left[T_t^{(i)} - T_c^{(i)} > \theta_0\right].$$ - -When called from `pbayesdecisionprob1cont()` with $n_{\mathrm{sim}}$ -simulation replicates, all draws are generated as a single -$n_{\mathrm{MC}} \times n_{\mathrm{sim}}$ matrix to avoid loop overhead. - -### 3.3 Moment-Matching Approximation (MM) - -The difference $D = T_t - T_c$ is approximated by a single -non-standardised $t$-distribution (Yamaguchi et al., 2025, Theorem 1). -Let - -$$Q^*_u = \left(\sigma_t^2\,\frac{\nu_t}{\nu_t - 2} + - \sigma_c^2\,\frac{\nu_c}{\nu_c - 2}\right)^{\!2},$$ - -$$Q_u = \frac{(\sigma_t^2)^2\,\nu_t^2}{(\nu_t-2)(\nu_t-4)} + - \frac{(\sigma_c^2)^2\,\nu_c^2}{(\nu_c-2)(\nu_c-4)} + - 2\left(\sigma_t^2\,\frac{\nu_t}{\nu_t-2}\right) - \!\left(\sigma_c^2\,\frac{\nu_c}{\nu_c-2}\right) - \qquad (\nu_t > 4,\; \nu_c > 4).$$ - -Then $D \approx Z^* \sim t_{\nu^*}(\mu^*, \sigma^*)$, where - -$$\mu^* = \mu_t - \mu_c,$$ - -$$\nu^* = \frac{2Q^*_u - 4Q_u}{Q^*_u - Q_u},$$ - -$$\sigma^* = \sqrt{\left(\sigma_t^2\,\frac{\nu_t}{\nu_t - 2} + - \sigma_c^2\,\frac{\nu_c}{\nu_c - 2}\right) - \frac{\nu^* - 2}{\nu^*}}.$$ - -The CDF is evaluated via a single call to `stats::pt()`. This method -requires $\nu_j > 4$, is exact in the normal limit -($\nu_j \to \infty$), and is fully vectorised --- making it the -recommended method for large-scale simulation. - -### 3.4 Comparison of the Three Methods - -```{r method-compare} -# Observed data (nMC excluded from base list; passed individually per method) -args_base <- list( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta0 = 1.0, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL -) - -p_ni <- do.call(pbayespostpred1cont, - c(args_base, list(CalcMethod = 'NI', nMC = NULL))) -p_mm <- do.call(pbayespostpred1cont, - c(args_base, list(CalcMethod = 'MM', nMC = NULL))) -set.seed(42) -p_mc <- do.call(pbayespostpred1cont, - c(args_base, list(CalcMethod = 'MC', nMC = 10000L))) - -cat(sprintf("NI : %.6f (exact)\n", p_ni)) -cat(sprintf("MM : %.6f (approx)\n", p_mm)) -cat(sprintf("MC : %.6f (n_MC=10000)\n", p_mc)) +This vignette describes the analysis of a proof-of-concept (PoC) study with +one normally distributed endpoint. `vignette("overview")` introduces the +decision criteria. + +## Model + +In group $k$ ($k = t, c$), the outcomes follow $N(\mu_k, \sigma_k^2)$, and +the data are summarized by the number of subjects $n_k$, the sample mean +$\bar y_k$ and the sample standard deviation $s_k$ (`data_continuous()`). +The treatment effect is $\theta = \mu_t - \mu_c$. + +With the Normal-Inverse-chi-squared prior (`prior_nix()`), +$$\mu_k \mid \sigma_k^2 \sim N(\mu_0, \sigma_k^2 / \kappa_0), \qquad +\sigma_k^2 \sim \textrm{Inv-}\chi^2(\nu_0, \sigma_0^2),$$ +the posterior distribution has the same form with parameters +$\kappa_n = \kappa_0 + n$, $\mu_n = (\kappa_0 \mu_0 + n \bar y) / \kappa_n$, +$\nu_n = \nu_0 + n$ and +$\nu_n \sigma_n^2 = \nu_0 \sigma_0^2 + (n - 1) s^2 + +\kappa_0 n (\bar y - \mu_0)^2 / \kappa_n$, and the posterior distribution of +the mean is the t distribution $t_{\nu_n}(\mu_n, \sigma_n^2 / \kappa_n)$. +With the vague prior $p(\mu, \sigma^2) \propto \sigma^{-2}$ +(`prior_vague()`), it is $t_{n - 1}(\bar y, s^2 / n)$. + +For the predictive criterion, the mean of $m$ future subjects of a group has +the posterior predictive distribution +$$t_{\nu_n}\left(\mu_n, \; \sigma_n^2 \left(\frac{1}{\kappa_n} + +\frac{1}{m}\right)\right).$$ +Version 0.1.0 of the package used the squared scale +$\sigma_n^2 (1 + 1 / \kappa_n) / m$, which treats the $m$ future subjects as +independent draws from the predictive distribution of one subject and +understates the uncertainty. + +The posterior and predictive probabilities of the Go and NoGo regions are +probabilities of the difference of two t variables, computed by `ptdiff()` +with one of three methods (argument `method` of `design_continuous()`): + +- `"NI"` (the default): numerical integration over the whole real line, + exact up to a small numerical error; +- `"MM"`: the moment-matching approximation of the difference by a single t + distribution (Yamaguchi, Homma, Takeda and Maruo, submitted), which + requires more than 4 + degrees of freedom in both groups; +- `"MC"`: Monte Carlo simulation with `nMC` draws. + +## Decision for observed data + +A study with 12 subjects in each group and vague priors, with +$\theta_{TV} = 15$ and $\theta_{MAV} = 5$: + +```{r design} +crit <- criterion_posterior(theta_tv = 15, theta_mav = 5, + gamma_go = 0.6, gamma_nogo = 0.7) +des <- design_continuous(n_t = 12, n_c = 12, prior_t = prior_vague(), + prior_c = prior_vague(), criterion = crit) +dec <- qdm_decide(des, data_t = data_continuous(n = 12, mean = 22, sd = 25), + data_c = data_continuous(n = 12, mean = 2, sd = 25)) +dec ``` ---- - -## 4. Study Designs - -### 4.1 Controlled Design - -Standard parallel-group RCT with observed data from both treatment -($n_t$, $\bar{y}_t$, $s_t$) and control ($n_c$, $\bar{y}_c$, $s_c$) groups. -Both posteriors are updated from the PoC data. - -Vague prior --- posterior probability: - -```{r ctrl-post} -# P(mu_t - mu_c > theta_TV | data) and P(mu_t - mu_c <= theta_MAV | data) -p_tv <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - CalcMethod = 'NI', theta0 = 1.5, nMC = NULL, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - lower.tail = FALSE -) - -p_mav <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - CalcMethod = 'NI', theta0 = 0.5, nMC = NULL, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - lower.tail = FALSE -) - -cat(sprintf("P(theta > theta_TV | data) = %.4f -> Go criterion: >= 0.80? %s\n", - p_tv, ifelse(p_tv >= 0.80, "YES", "NO"))) -cat(sprintf("P(theta <= theta_MAV | data) = %.4f -> NoGo criterion: >= 0.20? %s\n", - 1 - p_mav, ifelse((1 - p_mav) >= 0.20, "YES", "NO"))) -cat(sprintf("Decision: %s\n", - ifelse(p_tv >= 0.80 & (1 - p_mav) < 0.20, "Go", - ifelse(p_tv < 0.80 & (1 - p_mav) >= 0.20, "NoGo", - ifelse(p_tv >= 0.80 & (1 - p_mav) >= 0.20, "Miss", "Gray"))))) +The posterior distribution of each mean is $t_{11}(\bar y, s^2 / 12)$. The +three methods of `ptdiff()` give similar probabilities of the Go region: + +```{r methods} +post_t <- dec$posterior_t +post_c <- dec$posterior_c +scale_t <- post_t[["sigma"]] / sqrt(post_t[["kappa"]]) +scale_c <- post_c[["sigma"]] / sqrt(post_c[["kappa"]]) +set.seed(1) +sapply(c("NI", "MM", "MC"), function(m) { + ptdiff(15, mu_t = post_t[["mu"]], scale_t = scale_t, df_t = post_t[["nu"]], + mu_c = post_c[["mu"]], scale_c = scale_c, df_c = post_c[["nu"]], + method = m, lower.tail = FALSE) +}) ``` -N-Inv-$\chi^2$ informative prior: - -Historical knowledge suggests treatment mean $\sim 3.0$ and control mean -$\sim 1.0$ with prior pseudo-sample size $\kappa_{0t} = \kappa_{0c} = 5$ -(`kappa0_t`, `kappa0_c`) and degrees of freedom -$\nu_{0t} = \nu_{0c} = 5$ (`nu0_t`, `nu0_c`). - -```{r ctrl-post-niChisq} -p_tv_inf <- pbayespostpred1cont( - prob = 'posterior', design = 'controlled', prior = 'N-Inv-Chisq', - CalcMethod = 'NI', theta0 = 1.5, nMC = NULL, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = 5, kappa0_c = 5, - nu0_t = 5, nu0_c = 5, - mu0_t = 3.0, mu0_c = 1.0, - sigma0_t = 2.0, sigma0_c = 1.8, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - lower.tail = FALSE -) -cat(sprintf("P(theta > theta_TV | data, N-Inv-Chisq prior) = %.4f\n", p_tv_inf)) -``` +## Prior distributions and external data -Posterior predictive probability (future Phase III: $m_t = m_c = 60$): - -```{r ctrl-pred} -p_pred <- pbayespostpred1cont( - prob = 'predictive', design = 'controlled', prior = 'vague', - CalcMethod = 'NI', theta0 = 1.0, nMC = NULL, - n_t = 15, n_c = 15, m_t = 60, m_c = 60, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - lower.tail = FALSE +An informative Normal-Inverse-chi-squared prior is given by its parameters; +for example, a control prior centered at 0 with the weight of 2 subjects for +the mean and 4 degrees of freedom for the variance: + +```{r nix} +des_nix <- design_continuous( + n_t = 12, n_c = 12, prior_t = prior_vague(), + prior_c = prior_nix(mu0 = 0, kappa0 = 2, nu0 = 4, sigma0 = 25), + criterion = crit ) -cat(sprintf("Predictive probability (m_t = m_c = 60) = %.4f\n", p_pred)) +qdm_decide(des_nix, data_t = data_continuous(12, 22, 25), + data_c = data_continuous(12, 2, 25))$posterior_c ``` -### 4.2 Uncontrolled Design (Single-Arm) - -When no concurrent control group is enrolled, the control distribution is -specified from external knowledge: - -- Hypothetical control mean: $\mu_{0c}$ (`mu0_c`, fixed scalar) -- Variance scaling: $\sigma_c = \sqrt{r} \cdot \sigma_t$, - so $r = 1$ assumes equal variances - -The posterior of the control mean is not updated from observed data; -only the treatment posterior is updated. - -```{r unctrl-post} -p_unctrl <- pbayespostpred1cont( - prob = 'posterior', design = 'uncontrolled', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.5, nMC = NULL, - n_t = 15, n_c = NULL, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = NULL, s_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = 1.0, # hypothetical control mean - sigma0_t = NULL, sigma0_c = NULL, - r = 1.0, # equal variance assumption - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - lower.tail = FALSE +External data enter through a power prior with weight $a_0$: data with $n_e$ +subjects, mean $\bar y_e$ and standard deviation $s_e$ act as $a_0 n_e$ +subjects with the same mean and the sum of squares +$a_0 (n_e - 1) s_e^2$, which keeps the posterior distribution in closed form +(Huang et al., submitted). With the vague prior, the posterior distribution +of the mean then has $a_0 n_e + n - 1$ degrees of freedom. Borrowing half of +30 external control subjects: + +```{r external} +des_ext <- design_continuous( + n_t = 12, n_c = 12, prior_t = prior_vague(), prior_c = prior_vague(), + criterion = crit, + external_c = borrow(data_continuous(n = 30, mean = 0, sd = 25), a0 = 0.5) ) -cat(sprintf("P(theta > theta_TV | data, uncontrolled) = %.4f\n", p_unctrl)) +dec_ext <- qdm_decide(des_ext, data_t = data_continuous(12, 22, 25), + data_c = data_continuous(12, 2, 25)) +dec_ext$posterior_c ``` -### 4.3 External Design (Power Prior) - -In the external design, historical data from a prior study are -incorporated via a power prior with borrowing weight -$\alpha_{0e} \in (0, 1]$. The two prior specifications yield different -posterior update formulae. - -#### Vague prior (`prior = 'vague'`) - -For group $j$ with $n_{e,j}$ external patients, external mean -$\bar{y}_{e,j}$, and external SD $s_{e,j}$, the posterior parameters -after combining the power prior with the PoC data are given by -Theorem 4 of Huang et al. (2025): - -$$\mu_{nj}^* = \frac{\alpha_{0e,j}\, n_{e,j}\, \bar{y}_{e,j} + n_j\, \bar{y}_j} - {\alpha_{0e,j}\, n_{e,j} + n_j},$$ - -$$\kappa_{nj}^* = \alpha_{0e,j}\, n_{e,j} + n_j,$$ - -$$\nu_{nj}^* = \alpha_{0e,j}\, n_{e,j} + n_j - 1,$$ +The control mean now has `r dec_ext$posterior_c[["nu"]]` degrees of freedom +($0.5 \times 30 + 12 - 1$), and the probability of the Go region is +`r format(dec_ext$prob_go, digits = 3)` (without the external data, +`r format(dec$prob_go, digits = 3)`). -$$(\sigma_{nj}^*)^2 = \frac{\alpha_{0e,j}(n_{e,j}-1)\, s_{e,j}^2 + - (n_j-1)\, s_j^2 + - \dfrac{\alpha_{0e,j}\, n_{e,j}\, n_j\, (\bar{y}_{e,j} - \bar{y}_j)^2} - {\alpha_{0e,j}\, n_{e,j} + n_j}} - {\alpha_{0e,j}\, n_{e,j} + n_j}.$$ +## Hypothetical control -The marginal posterior of $\mu_j$ is then +For an uncontrolled study, Kang, Yamaguchi and Han (2026, Section 4.2.4) +give the control mean the same t distribution as the posterior distribution +of the treatment mean, with location $\mu_{0c}$ and the squared scale +multiplied by $r$: +$$\mu_c \sim t_{\nu_{nt}}(\mu_{0c}, \; r \sigma_{nt}^2 / \kappa_{nt}).$$ +The prior of the control group is then not used and is left `NULL`: -$$\mu_j \mid \mathbf{y}_j \;\sim\; - t_{\nu_{nj}^*}\!\!\left(\mu_{nj}^*,\; - \frac{\sigma_{nj}^*}{\sqrt{\kappa_{nj}^*}}\right).$$ - -Setting $\alpha_{0e,j} = 1$ corresponds to full borrowing; -as $\alpha_{0e,j} \to 0$ the result recovers the vague-prior posterior -from the current data alone. - -#### N-Inv-$\chi^2$ prior (`prior = 'N-Inv-Chisq'`) +```{r hypothetical} +des_hyp <- design_continuous( + n_t = 12, n_c = 0, prior_t = prior_vague(), criterion = crit, + hypothetical_c = hypothetical(mean = 0, r = 1) +) +qdm_decide(des_hyp, data_t = data_continuous(12, 22, 25)) +``` -When an informative N-Inv-$\chi^2(\mu_{0j}, \kappa_{0j}, \nu_{0j}, \sigma_{0j}^2)$ -initial prior is specified, the power prior is first formed by combining -the initial prior with the discounted external data (Theorem 1 of -Huang et al., 2025): +## Fixed control -$$\mu_{e,j} = \frac{\alpha_{0e,j}\, n_{e,j}\, \bar{y}_{e,j} + \kappa_{0j}\, \mu_{0j}} - {\alpha_{0e,j}\, n_{e,j} + \kappa_{0j}},$$ +With `fixed_c`, the control mean is a known value $\mu_{c0}$, for example +the mean of the standard of care reported in the literature. The effect is +$\theta = \mu_t - \mu_{c0}$, its probabilities are those of the t +distribution of the treatment mean, and `prior_c` and `method` are not +used. With the vague prior and a benchmark of $-10$: -$$\kappa_{e,j} = \alpha_{0e,j}\, n_{e,j} + \kappa_{0j},$$ +```{r fixed} +des_fix <- design_continuous(n_t = 12, n_c = 0, prior_t = prior_vague(), + criterion = crit, fixed_c = -10) +dec_fix <- qdm_decide(des_fix, data_t = data_continuous(12, 22, 25)) +dec_fix +pt((22 - (-10 + 15)) / (25 / sqrt(12)), df = 11) +``` -$$\nu_{e,j} = \alpha_{0e,j}\, n_{e,j} + \nu_{0j},$$ +For the predictive criterion, the mean of the $m_t$ future subjects has the +predictive t distribution given above, and the future effect is that mean +minus $\mu_{c0}$. -$$\sigma_{e,j}^2 = \frac{\alpha_{0e,j}(n_{e,j}-1)\, s_{e,j}^2 + - \nu_{0j}\, \sigma_{0j}^2 + - \dfrac{\alpha_{0e,j}\, n_{e,j}\, \kappa_{0j}\, (\bar{y}_{e,j} - \mu_{0j})^2} - {\alpha_{0e,j}\, n_{e,j} + \kappa_{0j}}} - {\nu_{e,j}}.$$ +## Predictive criterion -This intermediate result is then updated with the PoC data by standard -conjugate updating (Theorem 2 of Huang et al., 2025): +With 50 subjects per group in a future study and $\theta_{NULL} = 0$: -$$\mu_{nj}^* = \frac{\kappa_{e,j}\, \mu_{e,j} + n_j\, \bar{y}_j} - {\kappa_{e,j} + n_j},$$ +```{r predictive} +des_pred <- design_continuous( + n_t = 12, n_c = 12, prior_t = prior_vague(), prior_c = prior_vague(), + criterion = criterion_predictive(theta_null = 0, m_t = 50, + gamma_go = 0.9, gamma_nogo = 0.7) +) +qdm_decide(des_pred, data_t = data_continuous(12, 22, 25), + data_c = data_continuous(12, 2, 25)) +``` -$$\kappa_{nj}^* = \kappa_{e,j} + n_j,$$ +## Operating characteristics + +`qdm_oc()` simulates `nsim` studies under each scenario. Only the sufficient +statistics are simulated, $\bar y = \mu + \sigma Z / \sqrt{n}$ and +$s = \sigma \sqrt{X / (n - 1)}$ with $Z \sim N(0, 1)$ and +$X \sim \chi^2_{n - 1}$, and the same random numbers are used for all +scenarios. The moment-matching approximation is much faster than numerical +integration and is convenient for exploring designs: + +```{r oc} +des_mm <- design_continuous(n_t = 12, n_c = 12, prior_t = prior_vague(), + prior_c = prior_vague(), criterion = crit, + method = "MM") +scen <- data.frame(mu_t = seq(0, 40, by = 5), sd_t = 25, mu_c = 0, sd_c = 25) +oc <- qdm_oc(des_mm, scen, seed = 1) +oc +plot(oc) +``` -$$\nu_{nj}^* = \nu_{e,j} + n_j,$$ +The chosen design can be checked with numerical integration. To keep this +vignette quick, only three scenarios and 1000 simulated studies are used +here; with the same seed, both methods are applied to the same simulated +studies: + +```{r oc-ni} +scen3 <- scen[c(1, 3, 5), ] +oc_ni <- qdm_oc(des, scen3, nsim = 1000, seed = 1) +oc_mm <- qdm_oc(des_mm, scen3, nsim = 1000, seed = 1) +data.frame(mu_t = scen3$mu_t, Go_NI = oc_ni$Go, Go_MM = oc_mm$Go, + NoGo_NI = oc_ni$NoGo, NoGo_MM = oc_mm$NoGo) +``` -$$(\sigma_{nj}^*)^2 = \frac{\nu_{e,j}\, \sigma_{e,j}^2 + (n_j-1)\, s_j^2 + - \dfrac{n_j\, \kappa_{e,j}\, (\mu_{e,j} - \bar{y}_j)^2} - {\kappa_{e,j} + n_j}} - {\nu_{nj}^*}.$$ +The simulation standard error of the probabilities is at most +$0.5 / \sqrt{nsim}$, `r format(0.5 / sqrt(10000), digits = 2)` for the +default `nsim = 10000`. -The marginal posterior of $\mu_j$ is then +## Decision boundary -$$\mu_j \mid \mathbf{y}_j \;\sim\; - t_{\nu_{nj}^*}\!\!\left(\mu_{nj}^*,\; - \frac{\sigma_{nj}^*}{\sqrt{\kappa_{nj}^*}}\right).$$ +`qdm_boundary()` gives the decision on a grid of observed treatment means +and standard deviations (or sample sizes), and its plot shows which data +lead to Go, NoGo and Gray decisions. With a concurrent control group, the +observed control data are given by `data_c`, and the vertical axis is the +observed difference in means: -#### Example: external control design, vague prior +```{r boundary} +b <- qdm_boundary(des_mm, mean_t = seq(-10, 50, by = 1), + sd_t = seq(10, 40, by = 1), + data_c = data_continuous(12, 2, 25)) +plot(b) +``` -Here, $n_{e,c} = 20$ (`ne_c`), $\bar{y}_{e,c} = 0.9$ (`bar_ye_c`), -$s_{e,c} = 1.8$ (`se_c`), $\alpha_{0e,c} = 0.5$ (`alpha0e_c`) -(50% borrowing from external control): +A larger standard deviation needs a larger observed difference for a Go +decision. For the design with a fixed control, the boundary can be drawn +against the sample size instead: -```{r ext-post} -p_ext <- pbayespostpred1cont( - prob = 'posterior', design = 'external', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.5, nMC = NULL, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = 0.9, se_c = 1.8, - lower.tail = FALSE -) -cat(sprintf("P(theta > theta_TV | data, external control design, alpha=0.5) = %.4f\n", - p_ext)) +```{r boundary-fixed} +plot(qdm_boundary(des_fix, n_t = 6:40, mean_t = seq(-10, 40, by = 0.5), + sd_t = 25)) ``` -Effect of the borrowing weight: varying $\alpha_{0e,c}$ from 0 to 1 -shows how external data influence the posterior. - -```{r ext-borrowing} -# alpha0e_c must be in (0, 1]; start from 0.01 to avoid validation error -alpha_seq <- c(0.01, seq(0.1, 1.0, by = 0.1)) -p_alpha <- sapply(alpha_seq, function(a) { - pbayespostpred1cont( - prob = 'posterior', design = 'external', prior = 'vague', - CalcMethod = 'MM', theta0 = 1.5, nMC = NULL, - n_t = 15, n_c = 15, - bar_y_t = 3.2, s_t = 2.0, - bar_y_c = 1.1, s_c = 1.8, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = 20L, alpha0e_t = NULL, alpha0e_c = a, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = 0.9, se_c = 1.8, - lower.tail = FALSE - ) -}) -data.frame(alpha_ec = alpha_seq, P_gt_TV = round(p_alpha, 4)) -``` +## Calibration of the thresholds ---- +The thresholds are calibrated so that the Go criterion is met with +probability at most 0.05 when the treatment has no effect, and the NoGo +criterion with probability at most 0.2 when the effect is 20: -## 5. Operating Characteristics - -### 5.1 Definition - -For given true parameters $(\mu_t, \mu_c, \sigma_t, \sigma_c)$, the -operating characteristics are the probabilities of each decision outcome -under the Go/NoGo/Gray/Miss rule with thresholds -$(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})$. -These are estimated by Monte Carlo simulation over $n_{\mathrm{sim}}$ -replicates: - -$$\widehat{\Pr}(\mathrm{Go}) = - \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} - \mathbf{1}\!\left[g_{\mathrm{Go}}^{(i)} \ge \gamma_{\mathrm{go}} - \;\text{ and }\; g_{\mathrm{NoGo}}^{(i)} < \gamma_{\mathrm{nogo}}\right],$$ - -$$\widehat{\Pr}(\mathrm{NoGo}) = - \frac{1}{n_{\mathrm{sim}}} \sum_{i=1}^{n_{\mathrm{sim}}} - \mathbf{1}\!\left[g_{\mathrm{Go}}^{(i)} < \gamma_{\mathrm{go}} - \;\text{ and }\; g_{\mathrm{NoGo}}^{(i)} \ge \gamma_{\mathrm{nogo}}\right],$$ - -$$\widehat{\Pr}(\mathrm{Gray}) = 1 - - \widehat{\Pr}(\mathrm{Go}) - \widehat{\Pr}(\mathrm{NoGo}) - - \widehat{\Pr}(\mathrm{Miss}),$$ - -where - -$$g_{\mathrm{Go}}^{(i)} = P(\theta > \theta_{\mathrm{TV}} \mid \mathbf{y}^{(i)}), -\qquad -g_{\mathrm{NoGo}}^{(i)} = P(\theta \le \theta_{\mathrm{MAV}} \mid \mathbf{y}^{(i)})$$ - -are evaluated for the $i$-th simulated dataset $\mathbf{y}^{(i)}$. -A Miss ($g_{\mathrm{Go}} \ge \gamma_{\mathrm{go}}$ AND -$g_{\mathrm{NoGo}} \ge \gamma_{\mathrm{nogo}}$) -indicates an inconsistent threshold configuration and triggers an error by -default (`error_if_Miss = TRUE`). - -### 5.2 Example: Controlled Design, Posterior Probability - -```{r oc-controlled, fig.width = 8, fig.height = 6} -oc_ctrl <- pbayesdecisionprob1cont( - nsim = 500L, - prob = 'posterior', - design = 'controlled', - prior = 'vague', - CalcMethod = 'MM', - theta_TV = 1.5, theta_MAV = 0.5, theta_NULL = NULL, - nMC = NULL, - gamma_go = 0.80, gamma_nogo = 0.20, - n_t = 15, n_c = 15, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - mu_t = seq(1.0, 4.0, by = 0.5), - mu_c = 1.0, - sigma_t = 2.0, - sigma_c = 2.0, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, se_t = NULL, bar_ye_c = NULL, se_c = NULL, - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, - seed = 42L +```{r calibrate} +cal <- qdm_calibrate( + des_mm, + scenario_go = data.frame(mu_t = 0, sd_t = 25, mu_c = 0, sd_c = 25), + scenario_nogo = data.frame(mu_t = 20, sd_t = 25, mu_c = 0, sd_c = 25), + target_go = 0.05, target_nogo = 0.2, seed = 1 ) -print(oc_ctrl) -plot(oc_ctrl, base_size = 20) +cal +plot(cal) ``` -The same function supports `design = 'uncontrolled'` (with arguments -`mu0_c` and `r`), `design = 'external'` (with power prior arguments -`ne_c`, `alpha0e_c`, `bar_ye_c`, `se_c`), and `prob = 'predictive'` -(with future sample size arguments `m_t`, `m_c` and `theta_NULL`). -The function signature and output format are identical across all -combinations. - ---- +The chosen thresholds are $\gamma_{go} =$ `r cal$gamma_go` and +$\gamma_{nogo} =$ `r cal$gamma_nogo`. -## 6. Optimal Threshold Search - -### 6.1 Objective - -The `getgamma1cont()` function finds the optimal pair -$(\gamma_{\mathrm{go}}^*, \gamma_{\mathrm{nogo}}^*)$ by grid search over -$\Gamma = \{\gamma^{(1)}, \ldots, \gamma^{(K)}\} \subset (0, 1)$. -The two thresholds are calibrated independently under separate scenarios: - -- $\gamma_{\mathrm{go}}^*$: selected so that - $\Pr(\mathrm{Go} \mid \gamma_{\mathrm{go}}^*)$ satisfies - a criterion against a target value (e.g., $\Pr(\mathrm{Go}) < 0.05$) - under the Go-calibration scenario (`mu_t_go`, `mu_c_go`, - `sigma_t_go`, `sigma_c_go`; typically the null scenario - $\mu_t = \mu_c$). -- $\gamma_{\mathrm{nogo}}^*$: selected so that - $\Pr(\mathrm{NoGo} \mid \gamma_{\mathrm{nogo}}^*)$ - satisfies a criterion (e.g., $\Pr(\mathrm{NoGo}) < 0.20$) under the - NoGo-calibration scenario (`mu_t_nogo`, `mu_c_nogo`, - `sigma_t_nogo`, `sigma_c_nogo`; typically the alternative scenario). - -The search uses a two-stage strategy: - -Stage 1 (Simulate once): $n_{\mathrm{sim}}$ datasets are generated -from the true parameter distribution and the probabilities -$g_{\mathrm{Go}}^{(i)}$ and $g_{\mathrm{NoGo}}^{(i)}$ are computed for -each replicate --- independently of $\gamma$. - -Stage 2 (Sweep over $\Gamma$): for each candidate $\gamma \in \Gamma$, -$\Pr(\mathrm{Go} \mid \gamma)$ and $\Pr(\mathrm{NoGo} \mid \gamma)$ are -computed as empirical proportions over the precomputed indicator values -without further probability evaluations. - -### 6.2 Example: Controlled Design, Posterior Probability - -```{r getgamma-ctrl, fig.width = 8, fig.height = 6} -res_gamma <- getgamma1cont( - nsim = 1000L, - prob = 'posterior', - design = 'controlled', - prior = 'vague', - CalcMethod = 'MM', - theta_TV = 1.5, theta_MAV = 0.5, theta_NULL = NULL, - nMC = NULL, - mu_t_go = 1.0, mu_c_go = 1.0, # null scenario: no treatment effect - sigma_t_go = 2.0, sigma_c_go = 2.0, - mu_t_nogo = 2.5, mu_c_nogo = 1.0, - sigma_t_nogo = 2.0, sigma_c_nogo = 2.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 15L, n_c = 15L, m_t = NULL, m_c = NULL, - kappa0_t = NULL, kappa0_c = NULL, nu0_t = NULL, nu0_c = NULL, - mu0_t = NULL, mu0_c = NULL, sigma0_t = NULL, sigma0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - gamma_grid = seq(0.01, 0.99, by = 0.01), - seed = 42L -) -plot(res_gamma, base_size = 20) -``` +## References -The same function supports `design = 'uncontrolled'` (with `mu_t_go`, -`mu_t_nogo`, `mu0_c`, and `r`; set `mu_c_go` and `mu_c_nogo` to -`NULL`), `design = 'external'` (with power prior arguments), and -`prob = 'predictive'` (with `theta_NULL`, `m_t`, and `m_c`). The -calibration plot and the returned `gamma_go`/`gamma_nogo` values are -available for all combinations. +Huang, Y., Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Conjugate representation of power priors for efficient Bayesian analysis of +normal data. ---- +Kang, R., Yamaguchi, Y. and Han, C. (2026). Bayesian quantitative +decision-making framework in cell and gene therapy development for rare +diseases. *Journal of Biopharmaceutical Statistics*. + -## 7. Summary - -This vignette covered single continuous endpoint analysis in BayesianQDM: - -1. Bayesian model: N-Inv-$\chi^2$ conjugate posterior (vague and - informative priors) with explicit update formulae for $\kappa_{nj}$, - $\nu_{nj}$, $\mu_{nj}$, and $\sigma_{nj}^2$. -2. Posterior and predictive distributions: marginal $t$-distributions - for $\mu_j$ and $\bar{\tilde{y}}_j$, with explicit scale expressions. -3. Three computation methods: NI (exact), MC (simulation), MM - (moment-matching approximation; Yamaguchi et al., 2025, Theorem 1); - MM requires $\nu_j > 4$ and is recommended for large-scale simulation. -4. Three study designs: controlled (both groups observed), uncontrolled - ($\mu_{0c}$ and $r$ fixed from prior knowledge), external design - (power prior with borrowing weight $\alpha_{0e,j}$; vague prior follows - Theorem 4 of Huang et al. (2025), N-Inv-$\chi^2$ prior follows - Theorems 1--2 of Huang et al. (2025)). -5. Operating characteristics: Monte Carlo estimation of - $\Pr(\mathrm{Go})$, $\Pr(\mathrm{NoGo})$, $\Pr(\mathrm{Gray})$ - across true parameter scenarios. -6. Optimal threshold search: two-stage precompute-then-sweep strategy - in `getgamma1cont()` with user-specified criteria and selection rules. - -See `vignette("single-binary")` for the analogous binary endpoint analysis. +Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Moment-matching approximation for t-differences in clinical trials with +continuous endpoints. diff --git a/vignettes/time-to-event.Rmd b/vignettes/time-to-event.Rmd new file mode 100644 index 0000000..1b82444 --- /dev/null +++ b/vignettes/time-to-event.Rmd @@ -0,0 +1,208 @@ +--- +title: "Time-to-event endpoint" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Time-to-event endpoint} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include = FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) +library(BayesianQDM) +``` + +This vignette describes the analysis of a proof-of-concept (PoC) study with +one time-to-event endpoint, such as progression-free survival, evaluated by +the survival probability at a milestone time. `vignette("overview")` +introduces the decision criteria. + +## Model + +In group $k$ ($k = t, c$), the event times are exponential with hazard +$\lambda_k$, and the data are summarized by the number of events $d_k$ and +the total observed time $E_k$, the sum of the follow-up times of all +subjects until their event or censoring (`data_tte()`). With the Gamma prior +$\lambda_k \sim \textrm{Gamma}(a_k, b_k)$ (shape $a_k$ and rate $b_k$; +`prior_gamma()`), the posterior distribution is +$$\lambda_k \mid D \sim \textrm{Gamma}(a_k + d_k, \; b_k + E_k).$$ +The prior acts as $a_k$ events in a total observed time of $b_k$, so a prior +with a small shape and rate, such as `prior_gamma(0.1, 1)` with time in +months, has little influence. + +The effect is the difference of the survival probabilities at the milestone +time $t_0$, +$$\theta = S_t(t_0) - S_c(t_0), \qquad S_k(t_0) = \exp(-\lambda_k t_0).$$ +The posterior probability $\Pr(\theta > q \mid D)$ is computed by numerical +integration over the control hazard (`psurvdiff()`). + +External data with $d_e$ events and total observed time $E_e$ enter through +a power prior with weight $a_0$, which adds $a_0 d_e$ to the shape and +$a_0 E_e$ to the rate. A hypothetical control adds its events and total +observed time to the prior of the control group. + +## Decision for observed data + +A single-arm study is often compared with a known benchmark. With +`fixed_c`, the control survival probability at the milestone is a known +value $S_{c0}$, and the probabilities of the Go and NoGo regions are Gamma +probabilities of the treatment hazard. Consider 30 subjects, a milestone of +3 months, a benchmark of 0.72, $\theta_{TV} = 0.15$ and +$\theta_{MAV} = 0$: + +```{r design} +crit <- criterion_posterior(theta_tv = 0.15, theta_mav = 0, + gamma_go = 0.6, gamma_nogo = 0.8) +des <- design_tte(n_t = 30, n_c = 0, prior_t = prior_gamma(0.1, 1), + criterion = crit, milestone = 3, fixed_c = 0.72) +dec <- qdm_decide(des, data_t = data_tte(events = 6, exposure = 150)) +dec +``` + +The Go region is $S_t(3) > 0.72 + 0.15$, that is +$\lambda_t < -\log(0.87) / 3$, whose posterior probability is + +```{r fixed-check} +pgamma(-log(0.87) / 3, shape = 0.1 + 6, rate = 1 + 150) +``` + +With `fixed_c = 0`, the effect is the milestone survival probability +itself, and the thresholds are survival probabilities. + +With a concurrent control group of 30 subjects: + +```{r concurrent} +des_c <- design_tte(n_t = 30, n_c = 30, prior_t = prior_gamma(0.1, 1), + prior_c = prior_gamma(0.1, 1), criterion = crit, + milestone = 3) +dec_c <- qdm_decide(des_c, data_t = data_tte(6, 150), + data_c = data_tte(12, 140)) +dec_c +post_t <- dec_c$posterior_t +post_c <- dec_c$posterior_c +psurvdiff(0.15, milestone = 3, shape_t = post_t[["shape"]], + rate_t = post_t[["rate"]], shape_c = post_c[["shape"]], + rate_c = post_c[["rate"]], lower.tail = FALSE) +``` + +External control data and hypothetical controls are given as in the other +vignettes, with `borrow(data_tte(...), a0)` and +`hypothetical(data_tte(...))`. + +## Conduct of the study + +The operating characteristics and the predictive criterion need the timing +of the study, which `conduct_tte()` specifies: the enrollment +(piecewise uniform over the intervals of `accrual_time` with relative rates +`accrual_rate`), the dropout (piecewise exponential hazards) and the time of +the analysis, either at a calendar time (`cut_time`) or at the time of a +given number of events among all subjects of the study (`cut_events`). For +example, enrollment over 15 months with increasing rates, a small dropout +hazard and an analysis 15.44 months after the start of enrollment: + +```{r conduct} +cond <- conduct_tte(accrual_time = c(0, 5, 10, 15), + accrual_rate = c(0.4, 2, 4.5), + dropout_hazard = 0.00226, cut_time = 15.44) +cond +des <- design_tte(n_t = 30, n_c = 0, prior_t = prior_gamma(0.1, 1), + criterion = crit, milestone = 3, conduct = cond, + fixed_c = 0.72) +``` + +## Predictive criterion + +For the predictive criterion, a future study with $m_t$ and $m_c$ subjects +is conducted as specified by `conduct_future` (by default `conduct`). The +survival probability of each group in the future study is estimated by +$\exp\{-t_0 (a + \tilde d) / (b + \tilde E)\}$, from its number of events +$\tilde d$ and total observed time $\tilde E$, and the future effect is the +difference of the two estimates (or the treatment estimate minus the fixed +value). The predictive probabilities are estimated by simulating `nMC` +future studies, each with hazards drawn from the posterior distributions, +so they are Monte Carlo estimates and depend on the seed: + +```{r predictive} +des_pred <- design_tte( + n_t = 30, n_c = 0, prior_t = prior_gamma(0.1, 1), + criterion = criterion_predictive(theta_null = 0.05, m_t = 60, + gamma_go = 0.8, gamma_nogo = 0.3), + milestone = 3, conduct = cond, fixed_c = 0.72, nMC = 5000 +) +qdm_decide(des_pred, data_t = data_tte(6, 150), seed = 1) +``` + +## Operating characteristics + +A scenario gives the median survival time of each group (`median_t` and, +with a concurrent control group, `median_c`), and the hazard is +$\log 2$ divided by the median. `qdm_oc()` simulates `nsim` studies +conducted as specified by `conduct`, with the same random numbers for all +scenarios. The median for which the milestone survival equals the benchmark +is `med0` below, and the median for which it equals the benchmark plus +$\theta_{TV}$ is `med1`: + +```{r oc} +med0 <- 3 * log(2) / -log(0.72) +med1 <- 3 * log(2) / -log(0.72 + 0.15) +c(med0, med1) +scen <- data.frame(median_t = c(6, 8, 10, 12, 15, 20)) +oc <- qdm_oc(des, scen, seed = 1) +oc +plot(oc) +``` + +The horizontal axis is the survival probability of the treatment group at +the milestone, and the vertical lines are shifted by the fixed control +value. For a design with a concurrent control group, the probabilities of +each simulated study are computed by numerical integration, which takes +longer; here 1000 studies are simulated per scenario: + +```{r oc-concurrent} +des_c <- design_tte(n_t = 30, n_c = 30, prior_t = prior_gamma(0.1, 1), + prior_c = prior_gamma(0.1, 1), criterion = crit, + milestone = 3, conduct = cond) +oc_c <- qdm_oc(des_c, data.frame(median_t = c(med0, 10, 15, 20), + median_c = med0), nsim = 1000, seed = 1) +oc_c +``` + +With a predictive criterion, every simulated study requires `nMC` simulated +future studies, so small values of `nsim` and `nMC` are advisable for +exploration. + +## Calibration of the thresholds + +The thresholds of the single-arm design are calibrated so that the Go +criterion is met with probability at most 0.05 when the milestone survival +equals the benchmark (median `med0`), and the NoGo criterion with +probability at most 0.1 when it equals the benchmark plus 0.15 (median +`med1`): + +```{r calibrate} +cal <- qdm_calibrate(des, scenario_go = data.frame(median_t = med0), + scenario_nogo = data.frame(median_t = med1), + target_go = 0.05, target_nogo = 0.1, seed = 1) +cal +plot(cal) +``` + +The chosen thresholds are $\gamma_{go} =$ `r cal$gamma_go` and +$\gamma_{nogo} =$ `r cal$gamma_nogo`. + +## Decision boundary + +`qdm_boundary()` gives the decision for each combination of the number of +events and the total observed time of the treatment group. With a posterior +criterion, it does not depend on the conduct of the study: + +```{r boundary} +b <- qdm_boundary(des, exposure_t = seq(20, 400, by = 5)) +plot(b) +``` + +With a total observed time of 150 months, a Go decision needs at most +`r max(b$events_t[b$exposure_t == 150 & b$decision == "Go"])` events. For a +design with a concurrent control group, the observed control data are given +by `data_c`. diff --git a/vignettes/two-binary.Rmd b/vignettes/two-binary.Rmd index 1d0d7bb..98af667 100644 --- a/vignettes/two-binary.Rmd +++ b/vignettes/two-binary.Rmd @@ -1,669 +1,233 @@ --- -title: "Two Binary Endpoints" +title: "Two binary endpoints" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Two Binary Endpoints} + %\VignetteIndexEntry{Two binary endpoints} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.width = 7, - fig.height = 5.5, - fig.path = "figures/2bin-" -) +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) library(BayesianQDM) ``` -## Motivating Scenario - -We extend the single-endpoint RA trial to a bivariate binary design -with two co-primary binary endpoints: - -- Endpoint 1: ACR20 response (1 = responder, 0 = non-responder) -- Endpoint 2: DAS28 remission (1 = achieved, 0 = not achieved) - -The trial enrolls $n_t = n_c = 7$ patients per group in a 1:1 randomised -controlled design. - -Clinically meaningful thresholds (posterior probability): - -| | Endpoint 1 | Endpoint 2 | -|--------------------------|-----------|-----------| -| $\theta_{\mathrm{TV}1}$ | 0.20 | 0.20 | -| $\theta_{\mathrm{MAV}1}$ | 0.10 | 0.10 | - -Null hypothesis thresholds (predictive probability): -$\theta_{\mathrm{NULL}1} = 0.15$, $\theta_{\mathrm{NULL}2} = 0.15$. - -Decision thresholds: $\gamma_{\mathrm{go}} = 0.80$ (Go), $\gamma_{\mathrm{nogo}} = 0.80$ (NoGo). - -Observed data (used in Sections 2--4): treatment group counts for the -four response patterns $(Y_{i,1}, Y_{i,2}) \in \{(0,0),(0,1),(1,0),(1,1)\}$: - -| Pattern | Treatment ($x_{t,lm}$) | Control ($x_{c,lm}$) | -|---------|:---:|:---:| -| (0, 0) | 1 | 2 | -| (0, 1) | 1 | 1 | -| (1, 0) | 2 | 2 | -| (1, 1) | 3 | 2 | - -Marginal responder counts: treatment $y_{t,1} = 5$, $y_{t,2} = 4$; -control $y_{c,1} = 4$, $y_{c,2} = 3$. - ---- - -## 1. Bayesian Model: Dirichlet-Multinomial Conjugate - -### 1.1 Response Pattern Parameterisation - -Because the two endpoints within each patient $i$ ($i = 1, \ldots, n_j$) are -correlated, the bivariate binary outcome $(Y_{i,1}, Y_{i,2})$ is modelled -jointly through its four-cell probability vector - -$$\mathbf{p}_j = (p_{j,00},\, p_{j,01},\, p_{j,10},\, p_{j,11})^\top, -\qquad \mathbf{p}_j \in \Delta^3,$$ - -where $j \in \{t, c\}$ denotes the treatment or control group, -$\Delta^3$ denotes the 3-simplex (all entries non-negative and summing to 1), -and the subscripts refer to the values of $(Y_{i,1}, Y_{i,2})$. - -The observed count vector $\mathbf{x}_j = (x_{j,00}, x_{j,01}, x_{j,10}, -x_{j,11})^\top$ with $\sum_{lm} x_{j,lm} = n_j$ follows - -$$\mathbf{x}_j \mid \mathbf{p}_j \;\sim\; - \mathrm{Multinomial}(n_j,\, \mathbf{p}_j).$$ - -The marginal response rates and treatment effects are obtained by summing: - -$$\pi_{j1} = p_{j,10} + p_{j,11}, \qquad - \pi_{j2} = p_{j,01} + p_{j,11},$$ - -$$\theta_1 = \pi_{t1} - \pi_{c1}, \qquad - \theta_2 = \pi_{t2} - \pi_{c2}.$$ - -### 1.2 Prior: Dirichlet Distribution - -The conjugate prior for $\mathbf{p}_j$ is the Dirichlet distribution: - -$$\mathbf{p}_j \;\sim\; \mathrm{Dir}(\alpha_{j,00},\, \alpha_{j,01},\, - \alpha_{j,10},\, \alpha_{j,11}),$$ - -where all hyperparameters $\alpha_{j,lm} > 0$ (corresponding to -`a_t_00`, `a_t_01`, `a_t_10`, `a_t_11` for $j = t$ and -`a_c_00`, `a_c_01`, `a_c_10`, `a_c_11` for $j = c$). -The symmetric choice $\alpha_{j,lm} = 0.25$ for all $lm$ is the natural -extension of the Jeffreys prior to the four-cell multinomial and is used -throughout this vignette. - -### 1.3 Posterior Distribution +This vignette describes the analysis of a proof-of-concept (PoC) study with +two binary endpoints (Yamaguchi et al., submitted). +`vignette("overview")` introduces the decision criteria for one endpoint. -By conjugacy of the Dirichlet-Multinomial model, the posterior is: +## Model -$$\mathbf{p}_j \mid \mathbf{x}_j \;\sim\; - \mathrm{Dir}(\alpha_{j,00}^*,\, \alpha_{j,01}^*,\, - \alpha_{j,10}^*,\, \alpha_{j,11}^*),$$ +The responses of a subject on the two endpoints fall into one of four cells, +`"00"`, `"01"`, `"10"` and `"11"`, where the first digit is the response on +endpoint 1 and the second the response on endpoint 2. In group $k$, the +counts $x_k$ of the four cells follow a multinomial distribution with cell +probabilities $p_k = (p_{k,00}, p_{k,01}, p_{k,10}, p_{k,11})$, which have a +Dirichlet prior distribution $\textrm{Dir}(\alpha_k)$ (`prior_dirichlet()`). +The posterior distribution is $\textrm{Dir}(\alpha_k + x_k)$, and with +external data $x_{e}$ borrowed with weight $a_0$ it is +$\textrm{Dir}(\alpha_k + a_0 x_{e} + x_k)$. -where the posterior parameters are +The response rates of the two endpoints are the margins +$\pi_{k1} = p_{k,10} + p_{k,11}$ and $\pi_{k2} = p_{k,01} + p_{k,11}$, and +the treatment effects are $\theta_j = \pi_{tj} - \pi_{cj}$ ($j = 1, 2$). -$$\alpha_{j,lm}^* = \alpha_{j,lm} + x_{j,lm}, \qquad - lm \in \{00, 01, 10, 11\}.$$ +## Regions and criteria -The posterior mean for each cell is -$E[p_{j,lm} \mid \mathbf{x}_j] = \alpha_{j,lm}^* / A_j^*$, -where $A_j^* = \sum_{lm} \alpha_{j,lm}^*$. +The target values and minimum acceptable values divide the plane of +$(\theta_1, \theta_2)$ into nine regions: -### 1.4 Within-Group Correlation - -The within-group Pearson correlation between Endpoint 1 and Endpoint 2 is - -$$\rho_j = \frac{p_{j,11} - \pi_{j1}\,\pi_{j2}} - {\sqrt{\pi_{j1}(1-\pi_{j1})\,\pi_{j2}(1-\pi_{j2})}}.$$ - -When specifying operating characteristic scenarios, the true parameter -vector $\mathbf{p}_j$ is specified via the reparameterisation -$(\pi_{j1}, \pi_{j2}, \rho_j)$, with the feasibility constraint: +```{r regions} +qdm_regions("posterior") +``` -$$\rho_{\min} = \frac{\max(0,\pi_{j1}+\pi_{j2}-1) - \pi_{j1}\pi_{j2}} - {\sqrt{\pi_{j1}(1-\pi_{j1})\pi_{j2}(1-\pi_{j2})}} -\;\le\; \rho_j \;\le\; -\frac{\min(\pi_{j1},\pi_{j2}) - \pi_{j1}\pi_{j2}} - {\sqrt{\pi_{j1}(1-\pi_{j1})\pi_{j2}(1-\pi_{j2})}} -= \rho_{\max}.$$ +With `rule = "joint"` (the default), the Go criterion is that the posterior +probability of the union of `go_regions` is at least $\gamma_{go}$, and the +NoGo criterion that the probability of the union of `nogo_regions` is at +least $\gamma_{nogo}$. The defaults, region 1 for Go and region 9 for NoGo, +require both effects to exceed their target values and both to be at most +their minimum acceptable values. With `rule = "and"` or `rule = "or"`, the +criteria are applied to each endpoint separately and combined with AND or +OR. -The helper function `getjointbin()` converts $(\pi_{j1}, \pi_{j2}, \rho_j)$ -to $(p_{j,00}, p_{j,01}, p_{j,10}, p_{j,11})$: +For the predictive criterion, the null values divide the plane of the +future effects into four regions: -```{r getjointbin} -# Convert marginal rates + correlation to cell probabilities -getjointbin(pi1 = 0.30, pi2 = 0.35, rho = 0.20) -getjointbin(pi1 = 0.20, pi2 = 0.20, rho = 0.00) # independence +```{r regions-pred} +qdm_regions("predictive") ``` -### 1.5 Nine-Region Grid (Posterior Probability) - -The bivariate threshold grid for $(\theta_1, \theta_2)$ creates a -$3 \times 3$ partition: - -```{r nine-region-bin, echo = FALSE, results = 'asis'} -cat(' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Nine-region grid for two-endpoint posterior probability
- Endpoint 1
θ1 > θTV1θTV1 ≥ θ1 > θMAV1θMAV1 ≥ θ1
Endpoint 2 - θ2 > θTV2R1R4R7
- θTV2 ≥ θ2 > θMAV2R2R5R8
- θMAV2 ≥ θ2R3R6R9
-') +The posterior probabilities of the regions are estimated with `nMC` draws +from the Dirichlet posterior distributions. The predictive probabilities are +computed exactly from the joint distribution of the numbers of future +responders on the two endpoints. + +## Decision for observed data + +The first case study of Yamaguchi et al. (submitted) has 10 subjects per +group, $\textrm{Dir}(0.25, 0.25, 0.25, 0.25)$ priors, +$\theta_{TV} = (0.15, 0.15)$ and $\theta_{MAV} = (0.10, 0.10)$. Here the +thresholds are $\gamma_{go} = \gamma_{nogo} = 0.6$ (the article calibrates +its own thresholds), and `nMC = 2000` keeps the computations quick: + +```{r design} +prior <- prior_dirichlet(rep(0.25, 4)) +des <- design_binary2( + n_t = 10, n_c = 10, prior_t = prior, prior_c = prior, + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.6, gamma_nogo = 0.6), + nMC = 2000 +) +dec <- qdm_decide(des, data_t = data_binary2(c(3, 2, 2, 3)), + data_c = data_binary2(c(6, 2, 1, 1)), seed = 1) +dec ``` -Typical choices: Go if $P(R_1) \ge \gamma_{\mathrm{go}}$, -NoGo if $P(R_9) \ge \gamma_{\mathrm{nogo}}$. - -### 1.6 Four-Region Grid (Predictive Probability) - -For the predictive probability, a $2 \times 2$ partition is used: - -```{r four-region-bin, echo = FALSE, results = 'asis'} -cat(' - - - - - - - - - - - - - - - - - - - - - - - - - -
Four-region grid for two-endpoint predictive probability
- Endpoint 1
θ1 > θNULL1θ1 ≤ θNULL1
Endpoint 2 - θ2 > θNULL2R1R3
- θ2 ≤ θNULL2R2R4
-') +The posterior probability of region 1 is +`r format(dec$prob_go, digits = 3)`, and the decision is `r dec$decision`. +With `rule = "and"`, the Go criterion requires each endpoint to meet its +threshold separately: + +```{r and} +des_and <- design_binary2( + n_t = 10, n_c = 10, prior_t = prior, prior_c = prior, + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.6, gamma_nogo = 0.6, + rule = "and"), + nMC = 2000 +) +qdm_decide(des_and, data_t = data_binary2(c(3, 2, 2, 3)), + data_c = data_binary2(c(6, 2, 1, 1)), seed = 1) ``` ---- - -## 2. Posterior Predictive Distribution - -### 2.1 Dirichlet-Multinomial Predictive Distribution - -Let $\tilde{\mathbf{x}}_j \sim \mathrm{Multinomial}(m_j, \mathbf{p}_j)$ -be the future count vector with $m_j$ future patients -(corresponding to `m_t` and `m_c`). -Integrating out $\mathbf{p}_j$ over its Dirichlet posterior gives the -Dirichlet-Multinomial predictive distribution: - -$$P(\tilde{\mathbf{x}}_j = \mathbf{c} \mid \mathbf{x}_j) = - \binom{m_j}{\mathbf{c}} - \frac{B(\boldsymbol{\alpha}_j^* + \mathbf{c})}{B(\boldsymbol{\alpha}_j^*)}, - \quad \sum_{lm} c_{lm} = m_j,$$ - -where $B(\cdot)$ is the multivariate Beta function and -$\binom{m_j}{\mathbf{c}} = m_j! / \prod_{lm} c_{lm}!$ is the multinomial -coefficient. - -### 2.2 Monte Carlo Evaluation - -Because the Dirichlet-Multinomial does not yield a tractable closed form -for the joint probability that $(\tilde\theta_1, \tilde\theta_2)$ falls -in a given region, all region probabilities are estimated by Monte Carlo: +For the predictive criterion with 30 future subjects per group: -$$\widehat{P}(R_r) = \frac{1}{n_\mathrm{MC}} \sum_{s=1}^{n_\mathrm{MC}} - \mathbf{1}\!\left[(\pi_{t1}^{(s)} - \pi_{c1}^{(s)},\; - \pi_{t2}^{(s)} - \pi_{c2}^{(s)}) \in R_r\right],$$ +```{r predictive} +des_pred <- design_binary2( + n_t = 10, n_c = 10, prior_t = prior, prior_c = prior, + criterion = criterion_predictive(theta_null = c(0, 0), m_t = 30, + gamma_go = 0.6, gamma_nogo = 0.6) +) +qdm_decide(des_pred, data_t = data_binary2(c(3, 2, 2, 3)), + data_c = data_binary2(c(6, 2, 1, 1))) +``` -where $\mathbf{p}_j^{(s)} \sim \mathrm{Dir}(\boldsymbol{\alpha}_j^*)$ are -draws from the Dirichlet posterior and $\pi_{j1}^{(s)} = p_{j,10}^{(s)} + p_{j,11}^{(s)}$, -$\pi_{j2}^{(s)} = p_{j,01}^{(s)} + p_{j,11}^{(s)}$. -For the predictive probability, future proportion differences -$\tilde\theta_k^{(s)} = \tilde{\pi}_{t,k}^{(s)} - \tilde{\pi}_{c,k}^{(s)}$ -are computed from corresponding Multinomial draws conditioned on the -Dirichlet samples. +## External data and hypothetical controls ---- +External data of either group are given as cell counts and borrowed with a +power prior weight: -## 3. Study Designs - -### 3.1 Controlled Design - -Both groups are observed in the PoC trial. The posterior parameters are -updated as $\alpha_{j,lm}^* = \alpha_{j,lm} + x_{j,lm}$, where -$(x_{t,00}, x_{t,01}, x_{t,10}, x_{t,11})$ and -$(x_{c,00}, x_{c,01}, x_{c,10}, x_{c,11})$ -are supplied as `x_t_00`, ..., `x_t_11` and `x_c_00`, ..., `x_c_11`. - -```{r ctrl-post} -set.seed(42) -p_post_ctrl <- pbayespostpred2bin( - prob = 'posterior', design = 'controlled', - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 1L, x_t_01 = 1L, x_t_10 = 2L, x_t_11 = 3L, - x_c_00 = 2L, x_c_01 = 1L, x_c_10 = 2L, x_c_11 = 2L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 1000L +```{r external} +des_ext <- design_binary2( + n_t = 10, n_c = 10, prior_t = prior, prior_c = prior, + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.6, gamma_nogo = 0.6), + external_c = borrow(data_binary2(c(12, 3, 3, 2)), a0 = 0.5), + nMC = 2000 ) -print(round(p_post_ctrl, 4)) -cat(sprintf( - "\nGo region (R1): P = %.4f >= gamma_go (0.80)? %s\n", - p_post_ctrl["R1"], ifelse(p_post_ctrl["R1"] >= 0.80, "YES -> Go", "NO") -)) -cat(sprintf( - "NoGo region (R9): P = %.4f >= gamma_nogo (0.80)? %s\n", - p_post_ctrl["R9"], ifelse(p_post_ctrl["R9"] >= 0.80, "YES -> NoGo", "NO") -)) +qdm_decide(des_ext, data_t = data_binary2(c(3, 2, 2, 3)), + data_c = data_binary2(c(6, 2, 1, 1)), seed = 1)$posterior_c ``` -Posterior predictive probability (future Phase III: $m_t = m_c = 15$): - -```{r ctrl-pred} -set.seed(42) -p_pred_ctrl <- pbayespostpred2bin( - prob = 'predictive', design = 'controlled', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.15, theta_NULL2 = 0.15, - x_t_00 = 1L, x_t_01 = 1L, x_t_10 = 2L, x_t_11 = 3L, - x_c_00 = 2L, x_c_01 = 1L, x_c_10 = 2L, x_c_11 = 2L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = 15L, m_c = 15L, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 1000L +For a study without a concurrent control group, `hypothetical()` with cell +counts adds the hypothetical control data to the prior of the control group: + +```{r hypothetical} +des_hyp <- design_binary2( + n_t = 10, n_c = 0, prior_t = prior, prior_c = prior, + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.6, gamma_nogo = 0.6), + hypothetical_c = hypothetical(data = data_binary2(c(6, 2, 1, 1))), + nMC = 2000 ) -print(round(p_pred_ctrl, 4)) -cat(sprintf( - "\nGo region (R1): P = %.4f >= gamma_go (0.80)? %s\n", - p_pred_ctrl["R1"], ifelse(p_pred_ctrl["R1"] >= 0.80, "YES -> Go", "NO") -)) +qdm_decide(des_hyp, data_t = data_binary2(c(3, 2, 2, 3)), seed = 1) ``` -### 3.2 Uncontrolled Design - -When no concurrent control group is enrolled, the control distribution is -specified via a hypothetical count vector -$\mathbf{z} = (z_{00}, z_{01}, z_{10}, z_{11})$ combined with the -Dirichlet prior: - -$$\mathbf{p}_c \;\sim\; - \mathrm{Dir}(\alpha_{c,00} + z_{00},\; \alpha_{c,01} + z_{01},\; - \alpha_{c,10} + z_{10},\; \alpha_{c,11} + z_{11}).$$ - -This specification encodes prior belief about the bivariate control -response rates --- including any assumed within-group correlation --- -without requiring observed control data. -The hypothetical counts are supplied as `z00`, `z01`, `z10`, `z11`. - -```{r unctrl-post} -set.seed(1) -p_unctrl <- pbayespostpred2bin( - prob = 'posterior', design = 'uncontrolled', - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 1L, x_t_01 = 1L, x_t_10 = 2L, x_t_11 = 3L, - x_c_00 = NULL, x_c_01 = NULL, x_c_10 = NULL, x_c_11 = NULL, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = 2L, z01 = 1L, z10 = 2L, z11 = 1L, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 1000L +With `fixed_c`, the control response rates of the two endpoints are known +values $(\pi_{c1,0}, \pi_{c2,0})$, for example those of the standard of care +reported in the literature. The effects are then +$\theta_j = \pi_{tj} - \pi_{cj,0}$, and `prior_c` must be `NULL`: + +```{r fixed} +des_fix <- design_binary2( + n_t = 10, n_c = 0, prior_t = prior, + criterion = criterion_posterior(theta_tv = c(0.15, 0.15), + theta_mav = c(0.10, 0.10), + gamma_go = 0.6, gamma_nogo = 0.6), + fixed_c = c(0.2, 0.2), nMC = 2000 ) -print(round(p_unctrl, 4)) +qdm_decide(des_fix, data_t = data_binary2(c(3, 2, 2, 3)), seed = 1) ``` -### 3.3 External Control Design (Power Prior) - -External data for group $j$ (count vector $\mathbf{x}_{ej}$, -supplied as `xe_t_00`, ..., `xe_t_11` for $j = t$ and -`xe_c_00`, ..., `xe_c_11` for $j = c$) -are incorporated via a Dirichlet power prior with weight -$\alpha_{0e,j} \in (0, 1]$ (`alpha0e_t`, `alpha0e_c`). -The augmented prior parameters are: - -$$\alpha_{j,lm}^{*} = \alpha_{j,lm} + \alpha_{0e,j} \cdot x_{ej,lm}.$$ - -Setting $\alpha_{0e,j} = 1$ treats the external data as equivalent to current -trial data; $\alpha_{0e,j} \to 0$ recovers the original prior. -The current PoC data then update these augmented parameters: - -$$\alpha_{j,lm}^{**} = \alpha_{j,lm}^{*} + x_{j,lm} - = \alpha_{j,lm} + \alpha_{0e,j}\, x_{ej,lm} + x_{j,lm}.$$ - -When only the control group uses external data (external control design), -`xe_t_00` through `xe_t_11` and `alpha0e_t` are set to `NULL`. - -```{r ext-post} -set.seed(2) -p_ext <- pbayespostpred2bin( - prob = 'posterior', design = 'external', - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 1L, x_t_01 = 1L, x_t_10 = 2L, x_t_11 = 3L, - x_c_00 = 2L, x_c_01 = 1L, x_c_10 = 2L, x_c_11 = 2L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = 3L, xe_c_01 = 1L, xe_c_10 = 2L, xe_c_11 = 1L, - alpha0e_t = NULL, alpha0e_c = 0.5, - nMC = 1000L -) -print(round(p_ext, 4)) -``` +## Operating characteristics -Sensitivity to borrowing weight $\alpha_{0e,c}$: - -```{r ext-borrowing} -ae_seq <- c(0.01, seq(0.1, 1.0, by = 0.1)) -p_ae <- sapply(ae_seq, function(ae) { - set.seed(99) - res <- pbayespostpred2bin( - prob = 'posterior', design = 'external', - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - x_t_00 = 1L, x_t_01 = 1L, x_t_10 = 2L, x_t_11 = 3L, - x_c_00 = 2L, x_c_01 = 1L, x_c_10 = 2L, x_c_11 = 2L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = 3L, xe_c_01 = 1L, xe_c_10 = 2L, xe_c_11 = 1L, - alpha0e_t = NULL, alpha0e_c = ae, nMC = 500L - ) - res["R1"] -}) -data.frame(alpha0e_c = ae_seq, P_R1 = round(p_ae, 4)) -``` +A scenario gives the response rates of the two endpoints and their +correlation in each group. `cellprob_binary2()` converts them into the cell +probabilities; a correlation is feasible only if all four probabilities are +non-negative. ---- +```{r cellprob} +cellprob_binary2(pi1 = 0.35, pi2 = 0.35, rho = 0.3) +``` -## 4. Operating Characteristics - -### 4.1 Definition - -For given true parameters $(\mathbf{p}_t, \mathbf{p}_c)$, the operating -characteristics are computed by exact enumeration over all possible -multinomial count combinations via a two-stage strategy. - -Stage 1 (precomputation): all count combinations -$\mathbf{x}_{t,i}$ ($K_t$ combinations) and $\mathbf{x}_{c,j}$ ($K_c$ -combinations) are enumerated by `allmultinom()`. For each pair $(i, j)$, -`pbayespostpred2bin()` computes the region probability vector once, -yielding $\hat{g}_{\mathrm{go},ij}$ and $\hat{g}_{\mathrm{nogo},ij}$ -independent of any decision threshold. - -Stage 2 (weighting): for given thresholds $(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})$: - -$$\Pr(\mathrm{Go}) = \sum_{i=1}^{K_t} \sum_{j=1}^{K_c} - w_{ij}\, \mathbf{1}\!\left[\hat{g}_{\mathrm{go},ij} \ge \gamma_{\mathrm{go}} - \text{ and } \hat{g}_{\mathrm{nogo},ij} < \gamma_{\mathrm{nogo}}\right],$$ - -$$\Pr(\mathrm{NoGo}) = \sum_{i=1}^{K_t} \sum_{j=1}^{K_c} - w_{ij}\, \mathbf{1}\!\left[\hat{g}_{\mathrm{nogo},ij} \ge \gamma_{\mathrm{nogo}} - \text{ and } \hat{g}_{\mathrm{go},ij} < \gamma_{\mathrm{go}}\right],$$ - -where $w_{ij} = P_\mathrm{Mult}(\mathbf{x}_{t,i};\, n_t, \mathbf{p}_t) -\times P_\mathrm{Mult}(\mathbf{x}_{c,j};\, n_c, \mathbf{p}_c)$, -and - -$$\hat{g}_{\mathrm{go},ij} = \sum_{r \in \text{GoRegions}} \hat{P}(R_r \mid \mathbf{x}_{t,i}, \mathbf{x}_{c,j}),$$ -$$\hat{g}_{\mathrm{nogo},ij} = \sum_{r \in \text{NoGoRegions}} \hat{P}(R_r \mid \mathbf{x}_{t,i}, \mathbf{x}_{c,j}).$$ - -A Miss ($\hat{g}_{\mathrm{go},ij} \ge \gamma_{\mathrm{go}}$ AND -$\hat{g}_{\mathrm{nogo},ij} \ge \gamma_{\mathrm{nogo}}$) indicates an -inconsistent threshold configuration and triggers an error by default -(`error_if_Miss = TRUE`). Gray comprises all remaining outcomes. - -For large $n_t$ or $n_c$, the `CalcMethod = 'MC'` option replaces full -enumeration with $n_\mathrm{sim}$ multinomial draws, deduplicates them -into $K \ll n_\mathrm{sim}$ unique pairs, and evaluates -`pbayespostpred2bin()` only for those unique pairs. - -> **Note on computation time.** The number of multinomial count -> combinations grows rapidly with $n$: for $n_j$ patients and 4 response -> categories the number of combinations is $\binom{n_j + 3}{3}$, which -> equals 286 for $n_j = 10$ and 1771 for $n_j = 20$. For the Exact method -> with two groups this means up to $286^2 \approx 82{,}000$ unique pairs -> each requiring `nMC` Dirichlet draws. When predictive probability is used -> ($m_j > 0$), an additional layer of Multinomial sampling is added inside -> each Dirichlet draw, further multiplying computation time. Use small -> `nMC` (100--500) and `n_t = n_c = 10` for demonstration; switch to -> `CalcMethod = 'MC'` with moderate `nsim` for larger sample sizes. - -### 4.2 Example: Controlled Design, Posterior Probability - -```{r oc-controlled, fig.width = 8, fig.height = 6} -pi_t_seq <- seq(0.20, 0.90, by = 0.10) -n_scen <- length(pi_t_seq) - -oc_ctrl <- pbayesdecisionprob2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.80, gamma_nogo = 0.80, - pi_t1 = rep(pi_t_seq, each = n_scen), - pi_t2 = rep(pi_t_seq, times = n_scen), - rho_t = rep(0.0, n_scen * n_scen), - pi_c1 = rep(0.20, n_scen * n_scen), - pi_c2 = rep(0.20, n_scen * n_scen), - rho_c = rep(0.0, n_scen * n_scen), - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - m_t = NULL, m_c = NULL, - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 200L, CalcMethod = 'Exact', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE -) -print(oc_ctrl) -plot(oc_ctrl, base_size = 20) +By default (`enumerate = TRUE`), `qdm_oc()` enumerates all outcomes of the +study, `choose(n + 3, 3)` per group (`r choose(13, 3)` for 10 subjects), and +computes the region probabilities once for every pair of treatment and +control outcomes, with the same Monte Carlo draws for all pairs. The +computing time is proportional to the number of pairs times `nMC`; for large +sample sizes, `enumerate = FALSE` simulates `nsim` studies instead. + +```{r oc} +effects <- expand.grid(theta1 = c(0, 0.15, 0.3), theta2 = c(0, 0.15, 0.3)) +scen <- data.frame(pi_t1 = 0.2 + effects$theta1, + pi_t2 = 0.2 + effects$theta2, rho_t = 0.3, + pi_c1 = 0.2, pi_c2 = 0.2, rho_c = 0.3) +oc <- qdm_oc(des, scen, seed = 1) +oc +plot(oc) ``` -The same function supports `design = 'uncontrolled'` (with hypothetical -count vector arguments `z00`, `z01`, `z10`, `z11`), -`design = 'external'` (with power prior arguments `xe_c_00`, ..., -`xe_c_11` and `alpha0e_c`), and `prob = 'predictive'` (with future -sample size arguments `m_t`, `m_c` and `theta_NULL1`, `theta_NULL2`). -The within-group correlation `rho_t` can also be varied to study its -effect on the operating characteristics. The function signature and -output format are identical across all combinations. +A scenario whose correlation is outside the feasible range is not evaluable: +its probabilities are `NA`, with a warning, and it is marked "NE" in the +plot. ---- +The decision boundaries of `qdm_boundary()` (see `vignette("single-binary")`) +are not available for two binary endpoints, because the decision depends on +the four cell counts of the treatment group and cannot be shown on two axes. -## 5. Optimal Threshold Search - -### 5.1 Objective and Algorithm - -`getgamma2bin()` finds the optimal pair $(\gamma_{\mathrm{go}}^*, \gamma_{\mathrm{nogo}}^*)$ -by the same two-stage precompute-then-sweep strategy as -`pbayesdecisionprob2bin()`, but sweeps over the two-dimensional grid -$\Gamma_{\mathrm{go}} \times \Gamma_{\mathrm{nogo}}$ -(`gamma_go_grid` $\times$ `gamma_nogo_grid`). -The two thresholds are calibrated independently under separate scenarios: - -- $\gamma_{\mathrm{go}}^*$: calibrated under the Go-calibration scenario - (`pi_t1_go`, `pi_t2_go`, `rho_t_go`, `pi_c1_go`, `pi_c2_go`, - `rho_c_go`; typically the null scenario $\pi_t = \pi_c$), so that - $\Pr(\mathrm{Go}) < \texttt{target_go}$. -- $\gamma_{\mathrm{nogo}}^*$: calibrated under the NoGo-calibration scenario - (`pi_t1_nogo`, `pi_t2_nogo`, `rho_t_nogo`, `pi_c1_nogo`, - `pi_c2_nogo`, `rho_c_nogo`; typically the alternative scenario), so - that $\Pr(\mathrm{NoGo}) < \texttt{target_nogo}$. - -Stage 1 (precomputation): `pbayespostpred2bin()` is called for every -unique multinomial outcome combination $(\mathbf{x}_{t,i}, \mathbf{x}_{c,j})$ -enumerated by `allmultinom()`. The region probability vector is summed over -`GoRegions` and `NoGoRegions` to obtain $\hat{g}_{\mathrm{go},ij}$ and -$\hat{g}_{\mathrm{nogo},ij}$, independent of $(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}})$. - -Stage 2 (gamma sweep): for every pair -$(\gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}}) \in \Gamma_{\mathrm{go}} \times \Gamma_{\mathrm{nogo}}$: - -$$\Pr(\mathrm{Go} \mid \gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}}) = - \sum_{i,j} w_{ij}\, - \mathbf{1}\!\left[\hat{g}_{\mathrm{go},ij} \ge \gamma_{\mathrm{go}} \text{ and } - \hat{g}_{\mathrm{nogo},ij} < \gamma_{\mathrm{nogo}}\right],$$ - -$$\Pr(\mathrm{NoGo} \mid \gamma_{\mathrm{go}}, \gamma_{\mathrm{nogo}}) = - \sum_{i,j} w_{ij}\, - \mathbf{1}\!\left[\hat{g}_{\mathrm{nogo},ij} \ge \gamma_{\mathrm{nogo}} \text{ and } - \hat{g}_{\mathrm{go},ij} < \gamma_{\mathrm{go}}\right].$$ - -Results are stored in $|\Gamma_{\mathrm{go}}| \times |\Gamma_{\mathrm{nogo}}|$ matrices -`PrGo_grid` and `PrNoGo_grid`. - -Stage 3 (optimal selection): for each candidate $\gamma_{\mathrm{go}}$, -the worst-case $\Pr(\mathrm{Go})$ over all $\gamma_{\mathrm{nogo}}$ is compared -against `target_go`; analogously for $\gamma_{\mathrm{nogo}}$. - -### 5.2 Example: Controlled Design, Posterior Probability - -Null scenario: $\pi_{t1} = \pi_{c1} = 0.20$, $\pi_{t2} = \pi_{c2} = 0.20$, -$\rho_t = \rho_c = 0$ (no treatment effect, independence). - -```{r getgamma-ctrl, fig.width = 8, fig.height = 6} -res_gamma <- getgamma2bin( - prob = 'posterior', design = 'controlled', - GoRegions = 1L, NoGoRegions = 9L, - pi_t1_go = 0.20, pi_t2_go = 0.20, rho_t_go = 0.0, - pi_c1_go = 0.20, pi_c2_go = 0.20, rho_c_go = 0.0, - pi_t1_nogo = 0.40, pi_t2_nogo = 0.40, rho_t_nogo = 0.0, - pi_c1_nogo = 0.20, pi_c2_nogo = 0.20, rho_c_nogo = 0.0, - target_go = 0.05, target_nogo = 0.20, - n_t = 7L, n_c = 7L, - a_t_00 = 0.25, a_t_01 = 0.25, a_t_10 = 0.25, a_t_11 = 0.25, - a_c_00 = 0.25, a_c_01 = 0.25, a_c_10 = 0.25, a_c_11 = 0.25, - theta_TV1 = 0.20, theta_MAV1 = 0.10, - theta_TV2 = 0.20, theta_MAV2 = 0.10, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - z00 = NULL, z01 = NULL, z10 = NULL, z11 = NULL, - xe_t_00 = NULL, xe_t_01 = NULL, xe_t_10 = NULL, xe_t_11 = NULL, - xe_c_00 = NULL, xe_c_01 = NULL, xe_c_10 = NULL, xe_c_11 = NULL, - alpha0e_t = NULL, alpha0e_c = NULL, - nMC = 200L, - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05) -) -plot(res_gamma, base_size = 20) -``` +## Calibration of the thresholds -The same function supports `design = 'uncontrolled'` (with `pi_t1_go`, -`pi_t2_go`, `rho_t_go`, `pi_t1_nogo`, `pi_t2_nogo`, `rho_t_nogo`; set -`pi_c*_go` and `pi_c*_nogo` to `NULL`), `design = 'external'` (with power -prior arguments), and `prob = 'predictive'` (with `theta_NULL1`, -`theta_NULL2`, `m_t`, and `m_c`). The calibration plot and the returned -`gamma_go`/`gamma_nogo` values are available for all combinations. +With `rule = "joint"`, `qdm_calibrate()` chooses one threshold for the Go +criterion and one for the NoGo criterion. Here the Go criterion should be +met with probability at most 0.1 when neither endpoint is improved, and the +NoGo criterion with probability at most 0.2 when both effects are 0.3: ---- +```{r calibrate} +cal <- qdm_calibrate(des, scenario_go = scen[1, ], scenario_nogo = scen[9, ], + target_go = 0.1, target_nogo = 0.2, seed = 1) +cal +plot(cal) +``` -## 6. Summary - -This vignette covered two binary endpoint analysis in BayesianQDM: - -1. Bayesian model: Dirichlet-Multinomial conjugate, modelling the - bivariate binary outcome through the four-cell probability vector - $\mathbf{p}_j$ ($j \in \{t, c\}$). Posterior update: - $\alpha_{j,lm}^* = \alpha_{j,lm} + x_{j,lm}$. The symmetric - Jeffreys-type prior $\alpha_{j,lm} = 0.25$ is recommended. -2. Within-group correlation: parameterised via $\rho_j$ using the - moment-matching identity; feasible range enforced by `getjointbin()`. -3. Nine-region grid for posterior probability and four-region grid - for predictive probability, identical in structure to the two continuous - endpoint case. -4. Monte Carlo evaluation of region probabilities via Dirichlet draws; - no closed-form expression for the joint probability exists in the - bivariate binary case. -5. Three study designs: controlled design (standard posterior update), - uncontrolled design (hypothetical count vector $\mathbf{z}$ fixes the - control Dirichlet distribution), external control design (Dirichlet - power prior with $\alpha_{j,lm}^* = \alpha_{j,lm} + \alpha_{0e,j}\, x_{ej,lm}$). -6. Exact operating characteristics: two-stage precomputation over all - multinomial count combinations via `allmultinom()`, with multinomial - probability weighting (no outer Monte Carlo needed for small $n$). -7. Optimal threshold search: three-stage precompute-then-sweep in - `getgamma2bin()`, producing $|\Gamma_{\mathrm{go}}| \times |\Gamma_{\mathrm{nogo}}|$ - matrices `PrGo_grid` and `PrNoGo_grid`, visualised as contour plots. - -See `vignette("overview")` for a comparison across all four endpoint types. +The calibrated thresholds add up to `r cal$gamma_go + cal$gamma_nogo`. When +the sum is 1 or less, a Go and a NoGo criterion can be met together (a Miss +decision); here Miss decisions have probability up to +`r format(max(cal$oc$Miss), digits = 2)` under the two scenarios, which the +warning reports. `qdm_calibrate()` chooses the smallest thresholds that meet +the targets, and larger thresholds also meet them, with more Gray decisions. +For example, the design with $\gamma_{go} = \gamma_{nogo} = 0.6$ used above +meets the Go criterion with probability `r format(oc$Go[1], digits = 2)` +when neither endpoint is improved and the NoGo criterion with probability +`r format(oc$NoGo[9], digits = 2)` when both effects are 0.3, and Miss +decisions are impossible because the thresholds add up to more than 1. + +## Reference + +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development. diff --git a/vignettes/two-continuous.Rmd b/vignettes/two-continuous.Rmd index cd37b17..4db5010 100644 --- a/vignettes/two-continuous.Rmd +++ b/vignettes/two-continuous.Rmd @@ -1,810 +1,214 @@ --- -title: "Two Continuous Endpoints" +title: "Two continuous endpoints" output: rmarkdown::html_vignette vignette: > - %\VignetteIndexEntry{Two Continuous Endpoints} + %\VignetteIndexEntry{Two continuous endpoints} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} -knitr::opts_chunk$set( - collapse = TRUE, - comment = "#>", - fig.width = 7, - fig.height = 5.5, - fig.path = "figures/2cont-" -) +knitr::opts_chunk$set(collapse = TRUE, comment = "#>", fig.width = 7, + fig.height = 4.5) library(BayesianQDM) ``` -## Motivating Scenario - -We extend the single-endpoint RA trial to a bivariate design with two -co-primary continuous endpoints: - -- Endpoint 1: change from baseline in DAS28 score -- Endpoint 2: change from baseline in HAQ-DI (Health Assessment - Questionnaire -- Disability Index) - -The trial enrolls $n_t = n_c = 20$ patients per group (treatment vs. placebo) -in a 1:1 randomised controlled design. - -Clinically meaningful thresholds (posterior probability): - -| | Endpoint 1 | Endpoint 2 | -|---------------------------------------|:----------:|:----------:| -| $\theta_{\mathrm{TV},1}$ | 1.5 | 1.0 | -| $\theta_{\mathrm{MAV},1}$ | 0.5 | 0.3 | - -Null hypothesis thresholds (predictive probability): -$\theta_{\mathrm{NULL},1} = 0.5$, $\theta_{\mathrm{NULL},2} = 0.3$. - -Decision thresholds: $\gamma_1 = 0.80$ (Go), $\gamma_2 = 0.20$ (NoGo). - -Observed data (used in Sections 2--4): - -- Treatment: $\bar{\mathbf{y}}_t = (3.5, 2.1)^\top$, - $S_t = \begin{pmatrix}18.0 & 3.6\\3.6 & 9.0\end{pmatrix}$ -- Control: $\bar{\mathbf{y}}_c = (1.8, 1.0)^\top$, - $S_c = \begin{pmatrix}16.0 & 2.8\\2.8 & 8.5\end{pmatrix}$ - -where $S_j = \sum_{i=1}^{n_j}(\mathbf{y}_{ij} - \bar{\mathbf{y}}_j) -(\mathbf{y}_{ij} - \bar{\mathbf{y}}_j)^\top$ ($j = t, c$) is the sum-of-squares matrix. - ---- - -## 1. Bayesian Model: Normal-Inverse-Wishart Conjugate - -### 1.1 Prior Distribution - -For group $j$ ($j = t$: treatment, $j = c$: control), we model the -bivariate outcomes for patient $i$ ($i = 1, \ldots, n_j$) as - -$$\mathbf{y}_{ij} \mid \boldsymbol{\mu}_j, \Sigma_j \;\overset{iid}{\sim}\; - \mathcal{N}_2(\boldsymbol{\mu}_j,\, \Sigma_j).$$ - -The conjugate prior is the Normal-Inverse-Wishart (NIW) distribution: - -$$(\boldsymbol{\mu}_j, \Sigma_j) \;\sim\; - \mathrm{NIW}(\boldsymbol{\mu}_{0j},\, \kappa_{0j},\, \nu_{0j},\, - \Lambda_{0j}),$$ - -where $\boldsymbol{\mu}_{0j} \in \mathbb{R}^2$ is the prior mean -(argument `mu0_t` or `mu0_c`), -$\kappa_{0j} > 0$ is the prior concentration -(`kappa0_t` or `kappa0_c`), -$\nu_{0j} > 3$ is the prior degrees of freedom -(`nu0_t` or `nu0_c`), and -$\Lambda_{0j}$ is a $2 \times 2$ positive-definite prior scale matrix -(`Lambda0_t` or `Lambda0_c`). - -The vague (Jeffreys) prior is obtained by letting -$\kappa_{0j} \to 0$ and $\nu_{0j} \to 0$ (`prior = 'vague'`). - -### 1.2 Posterior Distribution - -Given $n_j$ observations with sample mean $\bar{\mathbf{y}}_j$ -(`ybar_t` or `ybar_c`) and -sum-of-squares matrix $S_j$ (`S_t` or `S_c`), -the NIW posterior has updated parameters: - -$$\kappa_{nj} = \kappa_{0j} + n_j, \qquad - \nu_{nj} = \nu_{0j} + n_j,$$ - -$$\boldsymbol{\mu}_{nj} = - \frac{\kappa_{0j}\,\boldsymbol{\mu}_{0j} + n_j\,\bar{\mathbf{y}}_j} - {\kappa_{nj}},$$ - -$$\Lambda_{nj} = \Lambda_{0j} + S_j + - \frac{\kappa_{0j}\,n_j}{\kappa_{nj}} - (\bar{\mathbf{y}}_j - \boldsymbol{\mu}_{0j}) - (\bar{\mathbf{y}}_j - \boldsymbol{\mu}_{0j})^\top.$$ - -The marginal posterior of the group mean $\boldsymbol{\mu}_j$ is a -bivariate non-standardised $t$-distribution: - -$$\boldsymbol{\mu}_j \mid \mathbf{Y}_j \;\sim\; - t_{\nu_{nj} - 1}\!\!\left(\boldsymbol{\mu}_{nj},\; - \frac{\Lambda_{nj}}{\kappa_{nj}(\nu_{nj} - 1)}\right).$$ - -Under the vague prior, this simplifies to - -$$\boldsymbol{\mu}_j \mid \mathbf{Y}_j \;\sim\; - t_{n_j - 2}\!\!\left(\bar{\mathbf{y}}_j,\; - \frac{S_j}{n_j(n_j - 2)}\right).$$ - -### 1.3 Posterior of the Bivariate Treatment Effect - -The bivariate treatment effect is $\boldsymbol{\theta} = -\boldsymbol{\mu}_t - \boldsymbol{\mu}_c$. Since the two groups are -independent, the posterior of $\boldsymbol{\theta}$ is the distribution -of the difference of two independent bivariate $t$-vectors: - -$$T_j \;\sim\; t_{\nu_{nj}-1}(\boldsymbol{\mu}_{nj},\, V_j),$$ - -where the posterior scale matrix is -$V_j = \Lambda_{nj} / [\kappa_{nj}(\nu_{nj}-1)]$. - -The posterior probability that $\boldsymbol{\theta}$ falls in a -rectangular region $R$ defined by thresholds on each component is - -$$P(\boldsymbol{\theta} \in R \mid \mathbf{Y}) = - P(T_t - T_c \in R),$$ - -computed by one of two methods (MC or MM) described in Section 3. - -### 1.4 Nine-Region Grid (Posterior Probability) - -The bivariate threshold grid for $(\theta_1, \theta_2)$ creates a -$3 \times 3$ partition using `theta_TV1`, `theta_MAV1`, `theta_TV2`, -`theta_MAV2`: - -```{r nine-region-cont, echo = FALSE, results = 'asis'} -cat(' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Nine-region grid for two-endpoint posterior probability
- Endpoint 1
θ1 > θTV1θTV1 ≥ θ1 > θMAV1θMAV1 ≥ θ1
Endpoint 2 - θ2 > θTV2R1R4R7
- θTV2 ≥ θ2 > θMAV2R2R5R8
- θMAV2 ≥ θ2R3R6R9
-') -``` - -Region $R_1$ (both endpoints exceed $\theta_{\mathrm{TV}}$) is typically -designated as Go and $R_9$ (both endpoints below $\theta_{\mathrm{MAV}}$) -as NoGo. - -### 1.5 Four-Region Grid (Predictive Probability) - -For the predictive probability, a $2 \times 2$ partition is used, -defined by `theta_NULL1` and `theta_NULL2`: - -```{r four-region-cont, echo = FALSE, results = 'asis'} -cat(' - - - - - - - - - - - - - - - - - - - - - - - - - -
Four-region grid for two-endpoint predictive probability
- Endpoint 1
θ1 > θNULL1θ1 ≤ θNULL1
Endpoint 2 - θ2 > θNULL2R1R3
- θ2 ≤ θNULL2R2R4
-') +This vignette describes the analysis of a proof-of-concept (PoC) study with +two continuous endpoints (Yamaguchi et al., submitted). +`vignette("two-binary")` describes the regions and the criteria for two +endpoints, which are the same here. + +## Model + +In group $k$ ($k = t, c$), the responses of a subject on the two endpoints +have a bivariate normal distribution $N_2(\mu_k, \Sigma_k)$, and the data +are summarized by the number of subjects, the vector of sample means and +the sample covariance matrix (`data_continuous2()`). With the +Normal-Inverse-Wishart prior (`prior_niw()`), +$$\mu_k \mid \Sigma_k \sim N_2(\mu_0, \Sigma_k / \kappa_0), \qquad +\Sigma_k \sim \textrm{Inv-Wishart}(\nu_0, \Lambda_0),$$ +the posterior distribution has the same form with parameters +$(\mu_n, \kappa_n, \nu_n, \Lambda_n)$, and the mean has the bivariate t +distribution with $\nu_n - 1$ degrees of freedom, location $\mu_n$ and scale +matrix $\Lambda_n / \{\kappa_n (\nu_n - 1)\}$. With the vague prior +$p(\mu, \Sigma) \propto |\Sigma|^{-3/2}$ (`prior_vague()`), the posterior +distribution of the mean is $t_{n - 2}(\bar y, S / \{n (n - 2)\})$, where +$S$ is $n - 1$ times the sample covariance matrix. + +For the predictive criterion, the mean of $m$ future subjects has the same +distribution with the scale matrix +$(1 / \kappa_n + 1 / m) \Lambda_n / (\nu_n - 1)$. Version 0.1.0 of the +package and Yamaguchi et al. (submitted) used +$(1 + \kappa_n) \Lambda_n / \{\kappa_n (\nu_n - 1) m\}$, which treats the +future subjects as independent draws from the predictive distribution of one +subject. + +The treatment effects are $\theta_j = \mu_{tj} - \mu_{cj}$ ($j = 1, 2$), and +the probabilities of the regions are computed by one of two methods +(argument `method` of `design_continuous2()`): + +- `"MM"` (the default): the difference of the two bivariate t + distributions is approximated by a bivariate t distribution with matched + moments (Yamaguchi, Homma, Takeda and Maruo, submitted, Theorem 3), whose + rectangle probabilities are computed by numerical integration for real + degrees of freedom; it requires more than 4 degrees of freedom in both + groups; +- `"MC"`: Monte Carlo simulation with `nMC` draws from each distribution. + +## Decision for observed data + +The second case study of Yamaguchi et al. (submitted) has 30 subjects per +group, Normal-Inverse-Wishart priors, $\theta_{TV} = (10, 2)$ and +$\theta_{MAV} = (5, 1)$. Here the thresholds are +$\gamma_{go} = \gamma_{nogo} = 0.6$ (the article calibrates its own +thresholds): + +```{r design} +L0 <- matrix(c(80^2, 15, 15, 6^2), 2, 2) +crit <- criterion_posterior(theta_tv = c(10, 2), theta_mav = c(5, 1), + gamma_go = 0.6, gamma_nogo = 0.6) +des <- design_continuous2( + n_t = 30, n_c = 30, + prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), + prior_c = prior_niw(mu0 = c(-10, -1), kappa0 = 0.1, nu0 = 4, + Lambda0 = L0), + criterion = crit +) +data_t <- data_continuous2(30, mean = c(12, 3), + cov = matrix(c(6400, 190, 190, 36), 2, 2)) +data_c <- data_continuous2(30, mean = c(-10, -1), + cov = matrix(c(5600, 150, 150, 42), 2, 2)) +dec <- qdm_decide(des, data_t = data_t, data_c = data_c) +dec ``` -Region $R_1$ (both endpoints exceed $\theta_{\mathrm{NULL}}$) is typically -designated as Go and $R_4$ (both endpoints at or below $\theta_{\mathrm{NULL}}$) -as NoGo. - ---- - -## 2. Posterior Predictive Distribution - -The predictive distribution of the future sample mean -$\bar{\tilde{\mathbf{y}}}_j$ based on $m_j$ future patients -(`m_t` or `m_c`) is again a bivariate $t$-distribution: - -$$\bar{\tilde{\mathbf{y}}}_j \mid \mathbf{Y}_j \;\sim\; - t_{\nu_{nj}-1}\!\!\left(\boldsymbol{\mu}_{nj},\; - \frac{\Lambda_{nj}}{\kappa_{nj}(\nu_{nj}-1)} - \cdot \frac{\kappa_{nj} + 1}{\kappa_{nj}} \cdot \frac{1}{m_j} - \right)$$ - -under the NIW prior. Under the vague prior the scale inflates to -$S_j(n_j + 1) / [n_j^2(n_j - 2) m_j]$. - ---- - -## 3. Two Computation Methods - -The computation method is specified via the `CalcMethod` argument. - -### 3.1 Monte Carlo Simulation (`CalcMethod = 'MC'`) - -For each of $n_\mathrm{MC}$ draws (`nMC`), independent samples are generated: +The decision is `r dec$decision`. Monte Carlo simulation gives similar +probabilities of the regions: -$$T_t^{(i)} \;\sim\; t_{\nu_{nt}-1}(\boldsymbol{\mu}_{nt}, V_t), \qquad - T_c^{(i)} \;\sim\; t_{\nu_{nc}-1}(\boldsymbol{\mu}_{nc}, V_c),$$ - -and the probability of region $R_\ell$ is estimated as the empirical -proportion: - -$$\widehat{P}(R_\ell) = - \frac{1}{n_\mathrm{MC}} \sum_{i=1}^{n_\mathrm{MC}} - \mathbf{1}\!\left[T_t^{(i)} - T_c^{(i)} \in R_\ell\right].$$ - -When `pbayespostpred2cont()` is called in vectorised mode over -$n_\mathrm{sim}$ replicates, all $n_\mathrm{MC}$ standard normal and -chi-squared draws are pre-generated once and reused; only the -Cholesky factor of the replicate-specific scale matrix is recomputed -per observation. - -### 3.2 Moment-Matching Approximation (`CalcMethod = 'MM'`) - -The difference $\boldsymbol{D} = T_t - T_c$ is approximated by a -bivariate non-standardised $t$-distribution -(Yamaguchi et al., 2025, Theorem 3). -Let $V_j$ be the scale matrix of $T_j$ ($j = t, c$), and define - -$$A = \left(\frac{\nu_t}{\nu_t - 2} V_t + - \frac{\nu_c}{\nu_c - 2} V_c\right)^{\!-1},$$ - -$$Q_m = \frac{1}{p(p+2)}\Biggl[ - \frac{\nu_t^2}{(\nu_t-2)(\nu_t-4)} - \left\{(\mathrm{tr}(AV_t))^2 + 2\,\mathrm{tr}(AV_t AV_t)\right\}$$ - -$$\quad - + \frac{\nu_c^2}{(\nu_c-2)(\nu_c-4)} - \left\{(\mathrm{tr}(AV_c))^2 + 2\,\mathrm{tr}(AV_c AV_c)\right\}$$ - -$$\quad - + \frac{2\nu_t\nu_c}{(\nu_t-2)(\nu_c-2)} - \left\{\mathrm{tr}(AV_t)\,\mathrm{tr}(AV_c) + - 2\,\mathrm{tr}(AV_t AV_c)\right\} -\Biggr]$$ - -with $p = 2$. Then $\boldsymbol{D} \approx Z^* \sim -t_{\nu^*}(\boldsymbol{\mu}^*, \Sigma^*)$, where - -$$\boldsymbol{\mu}^* = \boldsymbol{\mu}_t - \boldsymbol{\mu}_c,$$ - -$$\nu^* = \frac{2 - 4Q_m}{1 - Q_m},$$ - -$$\Sigma^* = \left(\frac{\nu_t}{\nu_t - 2} V_t + - \frac{\nu_c}{\nu_c - 2} V_c\right) \frac{\nu^* - 2}{\nu^*}.$$ - -The joint probability over each rectangular region is evaluated by a -single call to `mvtnorm::pmvt()`, which avoids simulation entirely and -is exact in the normal limit ($\nu_{nj} \to \infty$). - -The MM method requires $\nu_{nj} - 1 > 4$ for both groups ($\nu_j > 4$ -in the notation above); if this condition is not met, the function falls -back to MC automatically. - ---- - -## 4. Study Designs - -### 4.1 Controlled Design - -Both groups are observed in the PoC trial. All NIW posterior parameters -are updated from the current data. - -Posterior probability -- vague prior: - -```{r ctrl-post-vague} -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) - -set.seed(42) -p_post_vague <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 5000L +```{r mc} +des_mc <- design_continuous2( + n_t = 30, n_c = 30, + prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), + prior_c = prior_niw(mu0 = c(-10, -1), kappa0 = 0.1, nu0 = 4, + Lambda0 = L0), + criterion = crit, method = "MC", nMC = 10000 ) -print(round(p_post_vague, 4)) -cat(sprintf( - "g_Go = P(R1 | data) = %.4f\n", p_post_vague["R1"] -)) -cat(sprintf( - "g_NoGo = P(R9 | data) = %.4f\n\n", p_post_vague["R9"] -)) -cat(sprintf( - "Go criterion: g_Go >= gamma1 (0.80)? %s\n", - ifelse(p_post_vague["R1"] >= 0.80, "YES", "NO") -)) -cat(sprintf( - "NoGo criterion: g_NoGo >= gamma2 (0.20)? %s\n", - ifelse(p_post_vague["R9"] >= 0.20, "YES", "NO") -)) -cat(sprintf("Decision: %s\n", - ifelse(p_post_vague["R1"] >= 0.80 & p_post_vague["R9"] < 0.20, "Go", - ifelse(p_post_vague["R1"] < 0.80 & p_post_vague["R9"] >= 0.20, "NoGo", - ifelse(p_post_vague["R1"] >= 0.80 & p_post_vague["R9"] >= 0.20, "Miss", - "Gray"))) -)) +dec_mc <- qdm_decide(des_mc, data_t = data_t, data_c = data_c, seed = 1) +rbind(MM = dec$prob_regions, MC = dec_mc$prob_regions) ``` -Posterior probability -- NIW informative prior: - -```{r ctrl-post-niw} -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) - -set.seed(42) -p_post_niw <- pbayespostpred2cont( - prob = 'posterior', design = 'controlled', prior = 'N-Inv-Wishart', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 5000L -) -print(round(p_post_niw, 4)) -``` +## Hypothetical control -Posterior predictive probability (future Phase III: $m_t = m_c = 60$): - -```{r ctrl-pred} -set.seed(42) -p_pred <- pbayespostpred2cont( - prob = 'predictive', design = 'controlled', prior = 'vague', - theta_TV1 = NULL, theta_MAV1 = NULL, - theta_TV2 = NULL, theta_MAV2 = NULL, - theta_NULL1 = 0.5, theta_NULL2 = 0.3, - n_t = 20L, n_c = 20L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = 60L, m_c = 60L, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 5000L -) -print(round(p_pred, 4)) -cat(sprintf( - "\nGo region (R1): P = %.4f >= gamma1 (0.80)? %s\n", - p_pred["R1"], ifelse(p_pred["R1"] >= 0.80, "YES", "NO") -)) -cat(sprintf( - "NoGo region (R4): P = %.4f >= gamma2 (0.20)? %s\n", - p_pred["R4"], ifelse(p_pred["R4"] >= 0.20, "YES", "NO") -)) -cat(sprintf("Decision: %s\n", - ifelse(p_pred["R1"] >= 0.80 & p_pred["R4"] < 0.20, "Go", - ifelse(p_pred["R1"] < 0.80 & p_pred["R4"] >= 0.20, "NoGo", - ifelse(p_pred["R1"] >= 0.80 & p_pred["R4"] >= 0.20, "Miss", - "Gray"))) -)) -``` +For a study without a concurrent control group, `hypothetical(mean, r)` +gives the control mean the distribution of the treatment mean with location +`mean` and the scale matrix multiplied by `r`. The prior of the control +group is then not used and is left `NULL`: -### 4.2 Uncontrolled Design - -No concurrent control group is enrolled. Under the NIW prior, the -hypothetical control distribution is - -$$\boldsymbol{\mu}_c \;\sim\; - t_{\nu_{nt}-1}\!\!\left(\boldsymbol{\mu}_{0c},\; - r \cdot \frac{\Lambda_{nt}}{\kappa_{nt}(\nu_{nt}-1)}\right),$$ - -where $\boldsymbol{\mu}_{0c}$ (`mu0_c`) is the assumed control mean, -$r > 0$ (`r`) scales -the covariance relative to the treatment group, and $\Lambda_{nt}$ is the -posterior scale matrix of the treatment group. - -```{r unctrl-post} -set.seed(1) -p_unctrl <- pbayespostpred2cont( - prob = 'posterior', design = 'uncontrolled', prior = 'N-Inv-Wishart', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = NULL, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = NULL, S_c = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = NULL, nu0_c = NULL, mu0_c = c(0.0, 0.0), Lambda0_c = NULL, - r = 1.0, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 5000L +```{r hypothetical} +des_hyp <- design_continuous2( + n_t = 30, n_c = 0, + prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), + criterion = crit, + hypothetical_c = hypothetical(mean = c(-10, -1), r = 1) ) -print(round(p_unctrl, 4)) +dec_hyp <- qdm_decide(des_hyp, data_t = data_t) +dec_hyp ``` -### 4.3 External Design (Power Prior) - -External data for group $j$ (sample size $n_{e,j}$, sample mean -$\bar{\mathbf{y}}_{e,j}$, sum-of-squares matrix $S_{e,j}$) are incorporated via -a power prior with weight $\alpha_{0e,j} \in (0,1]$. -Both `prior = 'vague'` and `prior = 'N-Inv-Wishart'` are supported. - -#### Vague prior (`prior = 'vague'`) - -The posterior parameters after combining the vague power prior with the -PoC data are given by Corollary 2 of Huang et al. (2025): - -$$\boldsymbol{\mu}_{nj}^* = - \frac{\alpha_{0e,j}\,n_{e,j}\,\bar{\mathbf{y}}_{e,j} + n_j\,\bar{\mathbf{y}}_j} - {\kappa_{nj}^*},$$ - -$$\kappa_{nj}^* = \alpha_{0e,j}\,n_{e,j} + n_j, \qquad - \nu_{nj}^* = \alpha_{0e,j}\,n_{e,j} + n_j - 1,$$ - -$$\Lambda_{nj}^* = \alpha_{0e,j}\,S_{e,j} + S_j + - \frac{\alpha_{0e,j}\,n_{e,j}\,n_j}{\kappa_{nj}^*} - (\bar{\mathbf{y}}_j - \bar{\mathbf{y}}_{e,j}) - (\bar{\mathbf{y}}_j - \bar{\mathbf{y}}_{e,j})^\top.$$ - -The marginal posterior of $\boldsymbol{\mu}_j$ is then - -$$\boldsymbol{\mu}_j \mid \mathbf{Y}_j \;\sim\; - t_{\nu_{nj}^* - 1}\!\!\left(\boldsymbol{\mu}_{nj}^*,\; - \frac{\Lambda_{nj}^*}{\kappa_{nj}^*(\nu_{nj}^* - 1)}\right).$$ - -```{r ext-post-vague} -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -Se2_ext <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) - -set.seed(2) -p_ext_vague <- pbayespostpred2cont( - prob = 'posterior', design = 'external', prior = 'vague', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = Se2_ext, - nMC = 5000L -) -print(round(p_ext_vague, 4)) -``` +## Fixed control + +With `fixed_c`, the control means are known values, for example the means of +the standard of care reported in the literature. The probabilities of the +regions are then those of the bivariate t distribution of the treatment +mean, which are computed by numerical integration for any degrees of +freedom, so `method` is not used: -#### N-Inv-Wishart prior (`prior = 'N-Inv-Wishart'`) - -The power prior first combines the initial NIW prior with the discounted -external data (Theorem 5 of Huang et al., 2025): - -$$\boldsymbol{\mu}_{e,j} = - \frac{\alpha_{0e,j}\,n_{e,j}\,\bar{\mathbf{y}}_{e,j} + - \kappa_{0j}\,\boldsymbol{\mu}_{0j}} - {\kappa_{e,j}},$$ - -$$\kappa_{e,j} = \alpha_{0e,j}\,n_{e,j} + \kappa_{0j}, \qquad - \nu_{e,j} = \alpha_{0e,j}\,n_{e,j} + \nu_{0j},$$ - -$$\Lambda_{e,j} = \alpha_{0e,j}\,S_{e,j} + \Lambda_{0j} + - \frac{\kappa_{0j}\,\alpha_{0e,j}\,n_{e,j}}{\kappa_{e,j}} - (\boldsymbol{\mu}_{0j} - \bar{\mathbf{y}}_{e,j}) - (\boldsymbol{\mu}_{0j} - \bar{\mathbf{y}}_{e,j})^\top.$$ - -This intermediate NIW result is then updated with the current PoC data -by standard conjugate updating (Theorem 6 of Huang et al., 2025): - -$$\boldsymbol{\mu}_{nj}^* = - \frac{\kappa_{e,j}\,\boldsymbol{\mu}_{e,j} + n_j\,\bar{\mathbf{y}}_j} - {\kappa_{nj}^*},$$ - -$$\kappa_{nj}^* = \kappa_{e,j} + n_j, \qquad - \nu_{nj}^* = \nu_{e,j} + n_j,$$ - -$$\Lambda_{nj}^* = \Lambda_{e,j} + S_j + - \frac{\kappa_{e,j}\,n_j}{\kappa_{nj}^*} - (\bar{\mathbf{y}}_j - \boldsymbol{\mu}_{e,j}) - (\bar{\mathbf{y}}_j - \boldsymbol{\mu}_{e,j})^\top.$$ - -The marginal posterior of $\boldsymbol{\mu}_j$ is then - -$$\boldsymbol{\mu}_j \mid \mathbf{Y}_j \;\sim\; - t_{\nu_{nj}^* - 1}\!\!\left(\boldsymbol{\mu}_{nj}^*,\; - \frac{\Lambda_{nj}^*}{\kappa_{nj}^*(\nu_{nj}^* - 1)}\right).$$ - -```{r ext-post} -S_t <- matrix(c(18.0, 3.6, 3.6, 9.0), 2, 2) -S_c <- matrix(c(16.0, 2.8, 2.8, 8.5), 2, 2) -L0 <- matrix(c(8.0, 0.0, 0.0, 2.0), 2, 2) -Se2_ext <- matrix(c(15.0, 2.5, 2.5, 7.5), 2, 2) - -set.seed(3) -p_ext <- pbayespostpred2cont( - prob = 'posterior', design = 'external', prior = 'N-Inv-Wishart', - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, - ybar_t = c(3.5, 2.1), S_t = S_t, - ybar_c = c(1.8, 1.0), S_c = S_c, - m_t = NULL, m_c = NULL, - kappa0_t = 2.0, nu0_t = 5.0, mu0_t = c(2.0, 1.0), Lambda0_t = L0, - kappa0_c = 2.0, nu0_c = 5.0, mu0_c = c(0.0, 0.0), Lambda0_c = L0, - r = NULL, - ne_t = NULL, ne_c = 10L, alpha0e_t = NULL, alpha0e_c = 0.5, - bar_ye_t = NULL, bar_ye_c = c(1.5, 0.8), se_t = NULL, se_c = Se2_ext, - nMC = 5000L +```{r fixed} +des_fix <- design_continuous2( + n_t = 30, n_c = 0, + prior_t = prior_niw(mu0 = c(0, 1), kappa0 = 0.1, nu0 = 4, Lambda0 = L0), + criterion = crit, fixed_c = c(-10, -1) ) -print(round(p_ext, 4)) +dec_fix <- qdm_decide(des_fix, data_t = data_t) +dec_fix ``` ---- +The control means are not uncertain, so the probability of the Go region is +`r format(dec_fix$prob_go, digits = 3)`, compared with +`r format(dec_hyp$prob_go, digits = 3)` for the hypothetical control with +the same location. + +## Operating characteristics + +`qdm_oc()` simulates the sample means and the matrix of sums of squares and +cross-products of `nsim` studies under each scenario, with the same random +numbers for all scenarios. A scenario gives the means, standard deviations +and correlation of the two endpoints in each group. To keep this vignette +quick, 1000 studies are simulated per scenario (the default is 10000): + +```{r oc} +effects <- expand.grid(theta1 = c(0, 10, 20), theta2 = c(0, 2, 4)) +scen <- data.frame(mu_t1 = -10 + effects$theta1, + mu_t2 = -1 + effects$theta2, sd_t1 = 80, sd_t2 = 6, + rho_t = 0.3, mu_c1 = -10, mu_c2 = -1, sd_c1 = 80, + sd_c2 = 6, rho_c = 0.3) +oc <- qdm_oc(des, scen, nsim = 1000, seed = 1) +oc +plot(oc) +``` -## 5. Operating Characteristics - -### 5.1 Definition - -For given true parameters $(\boldsymbol{\mu}_t, \Sigma_t, -\boldsymbol{\mu}_c, \Sigma_c)$ (`mu_t`, `Sigma_t`, `mu_c`, `Sigma_c`), -the operating characteristics are -estimated by Monte Carlo over $n_\mathrm{sim}$ replicates (`nsim`). Let -$\hat{g}_{\mathrm{Go},i} = P(\text{GoRegions} \mid \mathbf{Y}^{(i)})$ -and $\hat{g}_{\mathrm{NoGo},i} = P(\text{NoGoRegions} \mid \mathbf{Y}^{(i)})$ -for the $i$-th simulated dataset. Then: - -$$\widehat{\Pr}(\mathrm{Go}) = - \frac{1}{n_\mathrm{sim}} \sum_{i=1}^{n_\mathrm{sim}} - \mathbf{1}\!\left[\hat{g}_{\mathrm{Go},i} \ge \gamma_1 \;\text{and}\; - \hat{g}_{\mathrm{NoGo},i} < \gamma_2\right],$$ - -$$\widehat{\Pr}(\mathrm{NoGo}) = - \frac{1}{n_\mathrm{sim}} \sum_{i=1}^{n_\mathrm{sim}} - \mathbf{1}\!\left[\hat{g}_{\mathrm{NoGo},i} \ge \gamma_2 \;\text{and}\; - \hat{g}_{\mathrm{Go},i} < \gamma_1\right],$$ - -$$\widehat{\Pr}(\mathrm{Miss}) = - \frac{1}{n_\mathrm{sim}} \sum_{i=1}^{n_\mathrm{sim}} - \mathbf{1}\!\left[\hat{g}_{\mathrm{Go},i} \ge \gamma_1 \;\text{and}\; - \hat{g}_{\mathrm{NoGo},i} \ge \gamma_2\right],$$ - -$$\widehat{\Pr}(\mathrm{Gray}) = 1 - - \widehat{\Pr}(\mathrm{Go}) - \widehat{\Pr}(\mathrm{NoGo}) - - \widehat{\Pr}(\mathrm{Miss}).$$ - -Here $\gamma_1$ and $\gamma_2$ correspond to arguments `gamma_go` and -`gamma_nogo`, respectively. -A Miss ($\hat{g}_{\mathrm{Go}} \ge \gamma_1$ and -$\hat{g}_{\mathrm{NoGo}} \ge \gamma_2$ simultaneously) indicates an -inconsistent threshold configuration and triggers an error by default -(`error_if_Miss = TRUE`). - -### 5.2 Example: Controlled Design, Posterior Probability - -Treatment effect scenarios are defined over a two-dimensional grid of -$(\mu_{t1}, \mu_{t2})$ while fixing -$\boldsymbol{\mu}_c = (0, 0)^\top$. -The full factorial combination of unique $\mu_{t1}$ and $\mu_{t2}$ values -triggers the tile plot in `plot()`, with colour intensity encoding -$\Pr(\mathrm{Go})$: - -```{r oc-controlled, fig.width = 8, fig.height = 6} -Sigma <- matrix(c(4.0, 0.8, 0.8, 1.0), 2, 2) - -mu_t1_seq <- seq(0.0, 3.5, by = 0.5) -mu_t2_seq <- seq(0.0, 2.1, by = 0.3) -n_scen <- length(mu_t1_seq) * length(mu_t2_seq) - -oc_ctrl <- pbayesdecisionprob2cont( - nsim = 100L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - gamma_go = 0.80, gamma_nogo = 0.20, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - n_t = 20L, n_c = 20L, m_t = NULL, m_c = NULL, - mu_t = cbind(rep(mu_t1_seq, times = length(mu_t2_seq)), - rep(mu_t2_seq, each = length(mu_t1_seq))), - Sigma_t = Sigma, - mu_c = matrix(0, nrow = n_scen, ncol = 2), - Sigma_c = Sigma, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - error_if_Miss = TRUE, Gray_inc_Miss = FALSE, seed = 42L -) -print(oc_ctrl) -plot(oc_ctrl, base_size = 20) +The simulation standard error of the probabilities is at most +$0.5 / \sqrt{nsim}$, `r format(0.5 / sqrt(1000), digits = 2)` for 1000 +studies. The moment-matching approximation is much faster than Monte Carlo +estimation of the region probabilities, whose computing time is +proportional to `nMC` for every simulated study. + +## Decision boundary + +`qdm_boundary()` gives the decision on a grid of observed treatment means of +the two endpoints, for a given sample covariance matrix, and its plot shows +which means lead to Go, NoGo and Gray decisions. With a concurrent control +group, the observed control data are given by `data_c`, and the axes are the +observed differences in means: + +```{r boundary} +b <- qdm_boundary(des, mean_t = list(seq(-30, 50, by = 2), + seq(-3, 7, by = 0.25)), + cov_t = data_t$cov, data_c = data_c) +plot(b) ``` -The same function supports `design = 'uncontrolled'` (with hypothetical -control mean `mu0_c` and scale factor `r`) and `design = 'external'` -(with power prior arguments `ne_c`, `bar_ye_c`, `se_c`, `alpha0e_c`). -The argument `prob = 'predictive'` switches to predictive probability -(with future sample sizes `m_t`, `m_c` and null thresholds -`theta_NULL1`, `theta_NULL2`). The function signature and output format -are identical across all combinations. +## Calibration of the thresholds ---- +The thresholds are calibrated so that the Go criterion is met with +probability at most 0.1 when neither endpoint is improved, and the NoGo +criterion with probability at most 0.2 when the effects are 20 and 4: -## 6. Optimal Threshold Search - -### 6.1 Objective and Algorithm - -Because there are two decision thresholds $(\gamma_1, \gamma_2)$, the -optimal search is performed over a two-dimensional grid -$\Gamma_1 \times \Gamma_2$ (arguments `gamma_go_grid` and `gamma_nogo_grid`). -The two thresholds are calibrated independently under separate scenarios: - -- $\gamma_1^*$: calibrated under the Go-calibration scenario - (`mu_t_go`, `Sigma_t_go`, `mu_c_go`, `Sigma_c_go`; typically the - null scenario $\boldsymbol{\mu}_t = \boldsymbol{\mu}_c$), so that - $\Pr(\mathrm{Go}) < \texttt{target\_go}$. -- $\gamma_2^*$: calibrated under the NoGo-calibration scenario - (`mu_t_nogo`, `Sigma_t_nogo`, `mu_c_nogo`, `Sigma_c_nogo`; typically - the alternative scenario), so that - $\Pr(\mathrm{NoGo}) < \texttt{target\_nogo}$. - -`getgamma2cont()` uses a three-stage strategy: - -Stage 1 (Simulate and precompute): $n_\mathrm{sim}$ bivariate datasets -are generated separately from each calibration scenario. For each -replicate $i$, `pbayespostpred2cont()` is called once in vectorised -mode to return the full region probability vector. The marginal Go and -NoGo probabilities per replicate are: - -$$\hat{g}_{\mathrm{Go},i} = \sum_{\ell \in \text{GoRegions}} \hat{p}_{i\ell}, \qquad - \hat{g}_{\mathrm{NoGo},i} = \sum_{\ell \in \text{NoGoRegions}} \hat{p}_{i\ell}.$$ - -Stage 2 (Gamma sweep): For each candidate $\gamma_1 \in \Gamma_1$ -(under the Go-calibration scenario) and each $\gamma_2 \in \Gamma_2$ -(under the NoGo-calibration scenario): - -$$\Pr(\mathrm{Go} \mid \gamma_1) = - \frac{1}{n_\mathrm{sim}} \sum_{i=1}^{n_\mathrm{sim}} - \mathbf{1}\!\left[\hat{g}_{\mathrm{Go},i} \ge \gamma_1\right],$$ - -$$\Pr(\mathrm{NoGo} \mid \gamma_2) = - \frac{1}{n_\mathrm{sim}} \sum_{i=1}^{n_\mathrm{sim}} - \mathbf{1}\!\left[\hat{g}_{\mathrm{NoGo},i} \ge \gamma_2\right].$$ - -The results are stored as vectors `PrGo_grid` and `PrNoGo_grid` indexed -by `gamma_go_grid` and `gamma_nogo_grid`, respectively. - -Stage 3 (Optimal selection): $\gamma_1^*$ is the smallest grid value -satisfying $\Pr(\mathrm{Go} \mid \gamma_1) < \texttt{target\_go}$; -$\gamma_2^*$ is the smallest grid value satisfying -$\Pr(\mathrm{NoGo} \mid \gamma_2) < \texttt{target\_nogo}$. - -### 6.2 Example: Controlled Design, Posterior Probability - -Go-calibration scenario: $\boldsymbol{\mu}_t = (0.5, 0.3)^\top$, -$\boldsymbol{\mu}_c = (0, 0)^\top$ (effect at MAV boundary -- above which -Go is not yet warranted, so $\Pr(\mathrm{Go}) < \texttt{target\_go}$ is -required). NoGo-calibration scenario: $\boldsymbol{\mu}_t = (1.0, 0.6)^\top$, -$\boldsymbol{\mu}_c = (0, 0)^\top$ (effect between MAV and TV -- above -which NoGo should be unlikely). - -```{r getgamma-ctrl, fig.width = 8, fig.height = 6} -res_gamma <- getgamma2cont( - nsim = 500L, prob = 'posterior', design = 'controlled', - prior = 'vague', - GoRegions = 1L, NoGoRegions = 9L, - mu_t_go = c(0.5, 0.3), Sigma_t_go = Sigma, - mu_c_go = c(0.0, 0.0), Sigma_c_go = Sigma, - mu_t_nogo = c(1.0, 0.6), Sigma_t_nogo = Sigma, - mu_c_nogo = c(0.0, 0.0), Sigma_c_nogo = Sigma, - target_go = 0.05, target_nogo = 0.20, - n_t = 20L, n_c = 20L, - theta_TV1 = 1.5, theta_MAV1 = 0.5, - theta_TV2 = 1.0, theta_MAV2 = 0.3, - theta_NULL1 = NULL, theta_NULL2 = NULL, - m_t = NULL, m_c = NULL, - kappa0_t = NULL, nu0_t = NULL, mu0_t = NULL, Lambda0_t = NULL, - kappa0_c = NULL, nu0_c = NULL, mu0_c = NULL, Lambda0_c = NULL, - r = NULL, - ne_t = NULL, ne_c = NULL, alpha0e_t = NULL, alpha0e_c = NULL, - bar_ye_t = NULL, bar_ye_c = NULL, se_t = NULL, se_c = NULL, - nMC = 500L, CalcMethod = 'MC', - gamma_go_grid = seq(0.05, 0.95, by = 0.05), - gamma_nogo_grid = seq(0.05, 0.95, by = 0.05), - seed = 42L -) -plot(res_gamma, base_size = 20) +```{r calibrate} +cal <- qdm_calibrate(des, scenario_go = scen[1, ], scenario_nogo = scen[9, ], + target_go = 0.1, target_nogo = 0.2, nsim = 1000, + seed = 1) +cal +plot(cal) ``` -The same function supports `design = 'uncontrolled'` (with `mu0_c` and -`r`) and `design = 'external'` (with power prior arguments `ne_c`, -`bar_ye_c`, `se_c`, `alpha0e_c`). Setting `prob = 'predictive'` -switches to predictive probability calibration (with `theta_NULL1`, -`theta_NULL2`, `m_t`, `m_c`). The function signature is identical -across all combinations. - ---- - -## 7. Summary - -This vignette covered two continuous endpoint analysis in BayesianQDM: - -1. Bayesian model: NIW conjugate posterior with explicit update - formulae for $\kappa_{nj}$, $\nu_{nj}$, $\boldsymbol{\mu}_{nj}$, - and $\Lambda_{nj}$; bivariate non-standardised $t$ marginal posterior. -2. Nine-region grid for posterior probability and four-region grid - for predictive probability; typical choice Go = R1, NoGo = R9 (posterior) - or R4 (predictive). -3. Two computation methods: MC (vectorised pre-generated draws with - Cholesky reuse) and MM (Mahalanobis-distance fourth-moment matching - via Yamaguchi et al. (2025), Theorem 3, + `mvtnorm::pmvt` for joint - probability; requires $\nu_j > 4$). -4. Three study designs: controlled, uncontrolled ($\boldsymbol{\mu}_{0c}$ - and $r$ fixed), external design (vague power prior follows Corollary 2 - of Huang et al. (2025); NIW power prior follows Theorems 5--6). -5. Operating characteristics: Monte Carlo estimation with vectorised - region probability computation. -6. Optimal threshold search: three-stage strategy in `getgamma2cont()` - calibrating $\gamma_1^*$ and $\gamma_2^*$ independently under separate - Go- and NoGo-calibration scenarios, with calibration curves visualised - via `plot()` and optimal thresholds marked at the target probability levels - ($\Pr(\mathrm{Go}) < 0.05$ under null, $\Pr(\mathrm{NoGo}) < 0.20$ - under alternative). - -See `vignette("two-binary")` for the analogous two binary endpoint analysis. +The calibrated thresholds add up to `r cal$gamma_go + cal$gamma_nogo`. When +the sum is 1 or less, a Go and a NoGo criterion can be met together (a Miss +decision); here Miss decisions have probability up to +`r format(max(cal$oc$Miss), digits = 2)` under the two scenarios, which the +warning reports. Larger thresholds also meet the targets, with more Gray +decisions: the design with $\gamma_{go} = \gamma_{nogo} = 0.6$ used above +meets the Go criterion with probability `r format(oc$Go[1], digits = 2)` +when neither endpoint is improved and the NoGo criterion with probability +`r format(oc$NoGo[9], digits = 2)` when the effects are 20 and 4, and Miss +decisions are impossible because the thresholds add up to more than 1. + +## References + +Yamaguchi, Y., Homma, G., Takeda, K. and Maruo, K. (submitted). +Moment-matching approximation for t-differences in clinical trials with +continuous endpoints. + +Yamaguchi, Y., Hu, H., Huang, Y., Han, C., Homma, G. and Wang, A. +(submitted). Bivariate Bayesian quantitative decision-making for two +endpoints in rare disease drug development.