├── .Rbuildignore ├── .gitattributes ├── .github ├── .gitignore └── workflows │ ├── R-CMD-check.yaml │ ├── pkgdown.yaml │ └── test-coverage.yaml ├── .gitignore ├── DESCRIPTION ├── NAMESPACE ├── NEWS.md ├── R ├── ci2num.R ├── disbayes-package.R ├── disbayes.R ├── disbayes_hier.R ├── eb.R ├── fit.R ├── inits.R ├── loo.R ├── stanmodels.R ├── state_probs.R └── tidy.R ├── README.md ├── _pkgdown.yml ├── configure ├── configure.win ├── data-raw ├── gbd_process.Rmd ├── ihdengland.R └── trends.r ├── data ├── ihdengland.rda └── ihdtrends.rda ├── disbayes.Rproj ├── inst ├── include │ └── stan_meta_header.hpp └── stan │ ├── disbayes.stan │ ├── disbayes_hier.stan │ └── include │ ├── license.stan │ └── trans_probs.stan ├── man ├── ci2num.Rd ├── conflict_disbayes.Rd ├── disbayes-package.Rd ├── disbayes.Rd ├── disbayes_hier.Rd ├── ihdengland.Rd ├── ihdtrends.Rd ├── loo.disbayes.Rd ├── loo_indiv.Rd ├── plot.disbayes.Rd ├── plot.disbayes_hier.Rd ├── plotfit_data_disbayes.Rd ├── plotfit_disbayes.Rd ├── reexports.Rd ├── tidy.disbayes.Rd └── tidy_obsdat.Rd ├── metahit ├── .gitignore ├── README.md ├── gbd_process_2019.Rmd ├── ihdtrends2019.rda ├── ihdtrends2019.rds ├── metahit.Rproj ├── paper_analyses.Rmd ├── paper_analyses_gender.r ├── paper_analyses_header.r ├── paper_analyses_hier.r ├── paper_analyses_national.r ├── paper_analyses_nonhier.r ├── paper_analyses_pointests.r ├── read_model_results.r ├── resall.rds ├── resall_selected.rds ├── slurm_bsu.sh └── trends2019.R ├── src ├── Makevars ├── Makevars.win ├── RcppExports.cpp ├── stanExports_disbayes.cc ├── stanExports_disbayes.h ├── stanExports_disbayes_hier.cc └── stanExports_disbayes_hier.h ├── tests ├── extra │ └── test_vb.R ├── slow │ ├── test.R │ ├── test_hier.R │ ├── test_loo.R │ └── test_opt.R ├── test_base.R └── testthat │ ├── data.r │ ├── test.R │ ├── test_ci2num.R │ ├── test_eb.R │ ├── test_fit.R │ ├── test_hier.R │ ├── test_hier_gender.R │ ├── test_loo.R │ └── test_opt.R └── vignettes ├── disbayes.Rmd ├── disbayes.bib ├── disbayes_cache └── html │ ├── __packages │ ├── unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.RData │ ├── unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdb │ ├── unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdx │ ├── unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.RData │ ├── unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdb │ └── unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdx └── disbayes_files └── figure-html ├── unnamed-chunk-10-1.png ├── unnamed-chunk-11-1.png └── unnamed-chunk-9-1.png /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^doc$ 2 | ^Meta$ 3 | data-raw 4 | ^.*\.Rprofile$ 5 | ^.*\.Rproj$ 6 | ^\.Rproj\.user$ 7 | ^metahit$ 8 | vignettes/render.r 9 | dbh.rds 10 | vignettes/dbh.rds 11 | ^_pkgdown\.yml$ 12 | ^docs$ 13 | ^pkgdown$ 14 | ^.+\.dll$ 15 | ^.+\.o$ 16 | ^.+\.so$ 17 | ^\.github$ 18 | vignettes/disbayes_cache 19 | vignettes/disbayes_files 20 | vignettes/disbayes.html 21 | data/ihdtrends2019.rda 22 | R/cfnaive.R 23 | man/cfnaive.Rd 24 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | Makevars text eol=lf 2 | *.cpp text eol=lf 3 | *.cc text eol=lf 4 | *.h text eol=lf 5 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | workflow_dispatch: 9 | 10 | name: R-CMD-check 11 | 12 | jobs: 13 | R-CMD-check: 14 | runs-on: ubuntu-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | R_KEEP_PKG_SOURCE: yes 18 | steps: 19 | - uses: actions/checkout@v2 20 | 21 | - uses: r-lib/actions/setup-r@v2 22 | with: 23 | use-public-rspm: true 24 | 25 | - uses: r-lib/actions/setup-r-dependencies@v2 26 | with: 27 | extra-packages: any::rcmdcheck 28 | needs: check 29 | 30 | - uses: r-lib/actions/check-r-package@v2 31 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | steps: 23 | - uses: actions/checkout@v2 24 | 25 | - uses: r-lib/actions/setup-pandoc@v2 26 | 27 | - uses: r-lib/actions/setup-r@v2 28 | with: 29 | use-public-rspm: true 30 | 31 | - uses: r-lib/actions/setup-r-dependencies@v2 32 | with: 33 | extra-packages: any::pkgdown, local::. 34 | needs: website 35 | 36 | - name: Build site 37 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = TRUE) 38 | shell: Rscript {0} 39 | 40 | - name: Deploy to GitHub pages 🚀 41 | if: github.event_name != 'pull_request' 42 | uses: JamesIves/github-pages-deploy-action@4.1.4 43 | with: 44 | clean: false 45 | branch: gh-pages 46 | folder: docs 47 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | workflow_dispatch: 9 | 10 | name: test-coverage 11 | 12 | jobs: 13 | test-coverage: 14 | runs-on: ubuntu-latest 15 | env: 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | 18 | steps: 19 | - uses: actions/checkout@v2 20 | 21 | - uses: r-lib/actions/setup-r@v2 22 | with: 23 | use-public-rspm: true 24 | 25 | - uses: r-lib/actions/setup-r-dependencies@v2 26 | with: 27 | extra-packages: any::covr 28 | needs: coverage 29 | 30 | - name: Test coverage 31 | run: covr::codecov(quiet = FALSE) 32 | shell: Rscript {0} 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History files 2 | .Rhistory 3 | .Rapp.history 4 | 5 | # Session Data files 6 | .RData 7 | # Example code in package build process 8 | *-Ex.R 9 | # Output files from R CMD build 10 | /*.tar.gz 11 | # Output files from R CMD check 12 | /*.Rcheck/ 13 | # RStudio files 14 | .Rproj.user/ 15 | # produced vignettes 16 | vignettes/*.html 17 | vignettes/*.pdf 18 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 19 | .httr-oauth 20 | # knitr and R markdown default cache directories 21 | /*_cache/ 22 | /cache/ 23 | # Temporary files created by R markdown 24 | *.utf8.md 25 | *.knit.md 26 | # Shiny token, see https://shiny.rstudio.com/articles/shinyapps.html 27 | rsconnect/ 28 | .Rproj.user 29 | Meta 30 | vignettes/metahit_results_* 31 | *~ 32 | inst/stan/*.rds 33 | .o 34 | src/*.o 35 | src/*.so 36 | src/*.dll 37 | metahit/TODO.md 38 | dbh.rds 39 | vignettes/dbh.rds 40 | /Meta/ 41 | metahit/slurm*out 42 | /doc/ 43 | metahit/results_nonhier 44 | docs 45 | configure 46 | *\#* 47 | vignettes/disbayes_cache 48 | .Rprofile 49 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: disbayes 2 | Title: Bayesian Multi-State Modelling of Chronic Disease Burden Data 3 | Date: 2023-09-09 4 | Version: 1.1.0 5 | Authors@R: 6 | person("Christopher", "Jackson", , "chris.jackson@mrc-bsu.cam.ac.uk", role = c("aut", "cre", "cph"), 7 | comment = c(ORCID = "0000-0002-6656-8913")) 8 | Description: Estimation of incidence and case fatality for a chronic disease, given partial information, using a multi-state model. Given data on age-specific mortality and either incidence or prevalence, Bayesian inference is used to estimate the posterior distributions of incidence, case fatality, and functions of these such as prevalence. The methods are described in Jackson et al. (2023) . 9 | License: GPL-3 10 | Encoding: UTF-8 11 | LazyData: true 12 | Biarch: true 13 | Depends: 14 | R (>= 3.5.0) 15 | Imports: 16 | dplyr, 17 | tidyr, 18 | magrittr, 19 | tibble, 20 | generics, 21 | methods, 22 | Rcpp (>= 0.12.0), 23 | rstan (>= 2.26.0), 24 | mgcv, 25 | SHELF, 26 | ggplot2, 27 | loo, 28 | matrixStats 29 | LinkingTo: 30 | BH (>= 1.66.0), 31 | Rcpp (>= 0.12.0), 32 | RcppParallel, 33 | RcppEigen (>= 0.3.3.3.0), 34 | rstan (>= 2.26.0), 35 | StanHeaders (>= 2.26.0) 36 | Suggests: knitr, 37 | rmarkdown, 38 | rstantools (>= 2.0.0.9000), 39 | tempdisagg, 40 | testthat, 41 | codetools 42 | VignetteBuilder: knitr 43 | SystemRequirements: GNU make 44 | URL: https://chjackson.github.io/disbayes/ 45 | BugReports: https://github.com/chjackson/disbayes/issues 46 | RoxygenNote: 7.2.3 47 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(loo,disbayes) 4 | S3method(plot,disbayes) 5 | S3method(plot,disbayes_hier) 6 | S3method(print,disbayes) 7 | S3method(summary,disbayes) 8 | S3method(tidy,disbayes) 9 | S3method(tidy,disbayes_hier) 10 | export(ci2num) 11 | export(conflict_disbayes) 12 | export(disbayes) 13 | export(disbayes_hier) 14 | export(loo) 15 | export(loo_indiv) 16 | export(looi_disbayes) 17 | export(plotfit_data_disbayes) 18 | export(plotfit_disbayes) 19 | export(tidy) 20 | export(tidy_obsdat) 21 | import(Rcpp) 22 | import(dplyr) 23 | import(methods) 24 | import(tibble) 25 | importFrom(generics,tidy) 26 | importFrom(loo,loo) 27 | importFrom(magrittr,"%>%") 28 | importFrom(matrixStats,colQuantiles) 29 | importFrom(mgcv,jagam) 30 | importFrom(mgcv,s) 31 | importFrom(mgcv,smoothCon) 32 | importFrom(rstan,sampling) 33 | importFrom(stats,coef) 34 | importFrom(stats,dbinom) 35 | importFrom(stats,lm) 36 | importFrom(stats,na.omit) 37 | importFrom(stats,pgamma) 38 | importFrom(stats,qbeta) 39 | importFrom(stats,qexp) 40 | importFrom(stats,qnorm) 41 | importFrom(stats,quantile) 42 | importFrom(stats,rbeta) 43 | importFrom(stats,rlnorm) 44 | importFrom(stats,rnorm) 45 | importFrom(stats,setNames) 46 | importFrom(stats,uniroot) 47 | importFrom(tidyr,extract) 48 | importFrom(tidyr,pivot_longer) 49 | importFrom(tidyr,pivot_wider) 50 | useDynLib(disbayes, .registration = TRUE) 51 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | -*- text -*- 2 | 3 | Version 1.1.0 (2023-09-09) 4 | ------------------------- 5 | 6 | * Updated Stan code to new array syntax. As a result, disbayes now requires rstan 2.26. 7 | 8 | 9 | Version 1.0.0 (2022-08-05) 10 | ------------------------- 11 | 12 | * First CRAN release. 13 | -------------------------------------------------------------------------------- /R/ci2num.R: -------------------------------------------------------------------------------- 1 | ##' Convert a proportion and credible interval to a numerator and denominator 2 | ##' 3 | ##' Estimate the number of events and denominator that contain roughly equivalent information to an estimate and uncertainty interval for a proportion, by interpreting the estimate and interval as a Beta posterior arising from a vague Beta(0.5,0.5) prior updated with the data consisting of that number and denominator. 4 | ##' 5 | ##' Based on fitting a Beta distribution by least squares, using the method provided by the \pkg{SHELF} package. 6 | ##' 7 | ##' Requires that the estimate and upper and lower limits are all distinct (except that \code{est=0} is allowed and handled specially for convenience, see \code{denom0}). Vectors of estimates and limits may be supplied. 8 | ##' 9 | ##' @param est Point estimate 10 | ##' 11 | ##' @param lower Lower 95\% credible limit 12 | ##' 13 | ##' @param upper Upper 95\% credible limit 14 | ##' 15 | ##' @param epsilon If any of \code{lower} are zero, then they are replaced by the minimum of \code{epsilon} and \code{est/2}. Similarly values of 1 for \code{upper} are replaced by the maximum of \code{1-epsilon} and \code{(1+est)/2}. 16 | ##' 17 | ##' @param denom0 Denominator to use as a default when the point estimate is exactly 0 or 1 (which is not compatible with the beta distribution). Should correspond to a guess of the population size used to produce the estimate, 18 | ##' which should be no greater than the actual population of the area, and usually less. Should be either a scalar, or a vector of the same length as \code{est} (though note if it is a vector, then only the elements where \code{est} is 1 or 0 get used). 19 | ##' 20 | ##' 21 | ##' @return A data frame with elements \code{num} and \code{denom} corresponding to the supplied estimate and limits. 22 | ##' 23 | ##' @examples 24 | ##' est <- 3.00 / 100 25 | ##' upper <- 3.52 / 100 26 | ##' lower <- 2.60 / 100 27 | ##' ci2num(est, lower, upper) 28 | ##' 29 | ##' @references Oakley (2020). SHELF: Tools to Support the Sheffield Elicitation Framework. R package version 1.7.0. \url{https://CRAN.R-project.org/package=SHELF} 30 | ##' 31 | ##' @export 32 | ci2num <- function(est, lower, upper, epsilon=0.5, denom0=1000){ 33 | check_proportion_ci2num(est, "est") 34 | check_proportion_ci2num(lower, "lower") 35 | check_proportion_ci2num(upper, "upper") 36 | check_interval_ci2num(est, lower, upper) 37 | r <- n <- numeric(length(est)) 38 | zeroinds = which(est==0) 39 | r[zeroinds] <- 0 40 | n[zeroinds] <- rep(denom0, length.out=length(est))[zeroinds] 41 | 42 | inds <- which(est > 0) 43 | if (length(inds) > 0) { 44 | est <- est[inds] 45 | lower <- lower[inds] 46 | upper <- upper[inds] 47 | lower[lower==0] <- pmin(epsilon[lower==0], est[lower==0]/2) 48 | upper[upper==1] <- pmax(1-epsilon[upper==1], (1+est[upper==1])/2) 49 | vals <- rbind(lower, est, upper) 50 | probs <- c(0.025, 0.5, 0.975) 51 | bet <- SHELF::fitdist(vals=vals, probs=probs, lower=0, upper=1)$Beta 52 | apost <- bet$shape1 53 | bpost <- bet$shape2 54 | aprior <- bprior <- 0.5 55 | r[inds] <- round(apost - aprior) 56 | n[inds] <- round(bpost - bprior + r[inds]) 57 | } 58 | data.frame(num=r, denom=n) 59 | } 60 | 61 | check_proportion_ci2num <- function(x, prefix){ 62 | badprop <- which(x < 0 | x > 1) 63 | if (length(badprop) > 0) { 64 | stop(sprintf("%s[%s]=%s should be in [0,1]", 65 | prefix, badprop[1], x[badprop[1]])) 66 | } 67 | } 68 | 69 | check_interval_ci2num <- function(x, lower, upper){ 70 | badint <- which(lower > upper) 71 | if (length(badint) > 0) { 72 | stop(sprintf("lower[%s]=%s, should be < upper[%s]=%s", 73 | badint[1], lower[badint[1]], badint[1], upper[badint[1]])) 74 | } 75 | badint <- which((x!=0) & (x <= lower | x >= upper)) 76 | if (length(badint) > 0) { 77 | stop(sprintf("est[%s]=%s should be inside the credible interval of (lower[%s]=%s, upper[%s]=%s)", 78 | badint[1], x[badint[1]], 79 | badint[1], lower[badint[1]], 80 | badint[1], upper[badint[1]])) 81 | } 82 | } 83 | -------------------------------------------------------------------------------- /R/disbayes-package.R: -------------------------------------------------------------------------------- 1 | #' The 'disbayes' package. 2 | #' 3 | #' @description Bayesian evidence synthesis for chronic disease epidemiology 4 | #' 5 | #' @docType package 6 | #' @name disbayes-package 7 | #' @useDynLib disbayes, .registration = TRUE 8 | #' @import methods 9 | #' @import Rcpp 10 | #' @importFrom stats coef lm qbeta qexp qnorm quantile rlnorm rnorm rbeta dbinom na.omit 11 | #' @importFrom rstan sampling 12 | #' @importFrom mgcv smoothCon jagam s 13 | #' @importFrom matrixStats colQuantiles 14 | #' @import dplyr 15 | #' @importFrom tidyr extract pivot_wider pivot_longer 16 | #' @importFrom magrittr "%>%" 17 | #' @import tibble 18 | #' 19 | #' @references 20 | #' Stan Development Team (2019). RStan: the R interface to Stan. R package version 2.19.2. https://mc-stan.org 21 | #' 22 | NULL 23 | 24 | #' @importFrom generics tidy 25 | #' @export 26 | generics::tidy 27 | 28 | #' @importFrom loo loo 29 | #' @export 30 | loo::loo 31 | 32 | ##' Ischemic heart disease in England 33 | ##' 34 | ##' @format A data frame with columns: 35 | ##' 36 | ##' \code{sex}: \code{"male"} or \code{"female"}. 37 | ##' 38 | ##' \code{ageyr}. Year of age. 39 | ##' 40 | ##' \code{location}. Name of the location, which is either a city region or region in England. 41 | ##' 42 | ##' \code{num_mort}. Numerator behind the estimate of mortality 43 | ##' 44 | ##' \code{num_inc}. Numerator behind the estimate of incidence 45 | ##' 46 | ##' \code{num_prev}. Numerator behind the estimate of prevalence 47 | ##' 48 | ##' \code{denom_mort}. Denominator behind the estimate of mortality 49 | ##' 50 | ##' \code{denom_inc}. Denominator behind the estimate of incidence 51 | ##' 52 | ##' \code{denom_prev}. Denominator behind the estimate of prevalence 53 | ##' 54 | ##' @source Global Burden of Disease, 2017 55 | ##' 56 | ##' @details The data were processed to 57 | ##' 58 | ##' * change the geography to refer to England city regions and the remaining English regions, 59 | ##' 60 | ##' * change counts by 5-year age groups to estimated 1-year counts, 61 | ##' 62 | ##' * obtain estimated numerators and denominators from the published point estimates and uncertainty intervals. 63 | ##' A point estimate of the risk is equivalent to the numerator divided by the denominator. The denominator is 64 | ##' related to the extent of uncertainty around this estimate, and obtained using the Bayesian method 65 | ##' implemented in \code{\link{ci2num}}. 66 | ##' 67 | ##' The script given in \url{https://github.com/chjackson/disbayes/blob/master/data-raw/gbd_process.Rmd} shows 68 | ##' these steps. 69 | ##' 70 | ##' @references Jackson C, Zapata-Diomedi B, Woodcock J. "Bayesian multistate modelling of incomplete chronic disease burden data" \url{https://arxiv.org/abs/2111.14100}. 71 | ##' 72 | ##' @keywords datasets 73 | "ihdengland" 74 | 75 | 76 | 77 | ##' Trends in ischemic heart disease in England 78 | ##' 79 | ##' @format A data frame with columns: 80 | ##' 81 | ##' \code{gender}: \code{"male"} or \code{"female"}. 82 | ##' 83 | ##' \code{age}: Year of age. 84 | ##' 85 | ##' \code{year}: Calendar year. 86 | ##' 87 | ##' \code{p2017}: Estimated ratio between the outcome in the calendar 88 | ##' year and the outcome in 2017. 89 | ##' 90 | ##' \code{outcome}: Outcome referred to (incidence or case fatality). 91 | ##' 92 | ##' @source Scarborough, P., Wickramasinghe, K., Bhatnagar, P. and Rayner, M. (2011) Trends in coronary heart disease, 1961-2001. British Heart Foundation. 93 | ##' 94 | ##' Smolina, K., Wright, F. L., Rayner, M. and Goldacre, M. J. (2012) Determinants of the decline in mortality from acute myocardial infarction in England between 2002 and 2010: linked national database study. BMJ, 344. 95 | ##' 96 | ##' British Heart Foundation (2020) Heart and Circulatory Disease Statistics 2020. British Heart Foundation. 97 | ##' 98 | ##' @details The data were interpolated and smoothed to produce a matrix by year of age and 99 | ##' calendar year, using the script at \url{https://github.com/chjackson/disbayes/blob/master/data-raw/trends.r}. 100 | ##' 101 | ##' @keywords datasets 102 | "ihdtrends" 103 | -------------------------------------------------------------------------------- /R/eb.R: -------------------------------------------------------------------------------- 1 | ## Empirical Bayes method 2 | ## Call disbayes to estimate posterior modes of hyperparameters 3 | ## Return the modes so that they can subsequently be fixed to fit the desired model 4 | 5 | eb_find_modes <- function(dbcall, dbfn=disbayes, hp_fixed_arg){ 6 | dbcall$method <- "opt" 7 | dbcall$hessian <- FALSE 8 | dbcall$draws <- 0 9 | dbcall$hp_fixed <- hp_fixed_arg 10 | dbcall[[1]] <- NULL 11 | ## Don't allow extra args to be passed through (e.g. to customise the sampler) 12 | fargs <- names(dbcall)[names(dbcall) %in% names(formals(dbfn))] 13 | dbcall <- dbcall[fargs] 14 | ebres <- do.call(dbfn, dbcall) 15 | ebres$fit$par 16 | } 17 | 18 | expand_hpfixed <- function(hp, hp_fixed){ 19 | hpfnew <- vector(nrow(hp), mode="list") 20 | names(hpfnew) <- hp$pars 21 | for (i in seq_along(hp$pars)) { 22 | hpfnew[[i]] <- if (is.null(hp_fixed[[hp$pars[i]]])) FALSE else hp_fixed[[hp$pars[i]]] 23 | } 24 | hpfnew 25 | } 26 | 27 | .disbayes_hier_hp <- data.frame( 28 | pars = c("scf","sinc","srem","scfmale","sd_int","sd_slope"), 29 | row.names = c("scf","sinc","srem","scfmale","sd_int","sd_slope"), 30 | stannames = c("lambda_cf[1]", "lambda_inc[1]", "lambda_rem[1]", 31 | "lambda_cf_male[1]", "sd_inter[1]", "sd_slope[1]"), 32 | stringsAsFactors=FALSE 33 | ) 34 | 35 | .disbayes_hp <- data.frame( 36 | pars = c("scf","sinc","srem"), 37 | row.names = c("scf","sinc","srem"), 38 | stannames = c("lambda_cf[1]","lambda_inc[1]","lambda_rem[1]"), 39 | stringsAsFactors=FALSE 40 | ) 41 | 42 | eb_disbayes <- function(hplist, hp_fixed, dbcall, dbfn, method, dotargs){ 43 | hp <- hplist 44 | hp$include <- TRUE 45 | hp_fixed <- expand_hpfixed(hp, hp_fixed) 46 | hp$vals <- 1 47 | for (i in seq_along(hp_fixed)) if (is.numeric(hp_fixed[[i]])) hp$vals[i] <- hp_fixed[[i]] 48 | normalapprox_wanted <- ((method=="opt") && isTRUE(dotargs$hessian) && 49 | !is.null(dotargs$draws) && dotargs$draws> 1) 50 | unc_wanted <- (method %in% c("mcmc","vb") || normalapprox_wanted) 51 | hp$eb <- sapply(hp_fixed, isTRUE) # parameters to do empirical Bayes on 52 | if (unc_wanted && any(hp$eb)) { 53 | hp_fixed_arg <- hp_fixed 54 | hp_fixed_arg[hp$eb] <- FALSE 55 | modes <- eb_find_modes(as.list(dbcall), dbfn=dbfn, hp_fixed_arg) 56 | hp$vals[hp$eb] <- modes[hp$stannames[hp$eb]] 57 | } else modes <- NULL 58 | tmp <- sapply(hp_fixed, function(x){is.numeric(x) || isTRUE(x)}) 59 | hp$isfixed <- tmp 60 | hp 61 | } 62 | 63 | -------------------------------------------------------------------------------- /R/fit.R: -------------------------------------------------------------------------------- 1 | ##' Extract observed data from a disbayes model fit 2 | ##' 3 | ##' @param x Fitted \code{\link{disbayes}} model 4 | ##' 5 | ##' @return A data frame with columns \code{num} and \code{denom} giving the incidence, prevalence and mortality (and remission if used) numerators and denominators used in the model fit. The column \code{var} indicates which of incidence, prevalence etc. the numbers refer to. The column \code{prob} is derived as \code{num} divided by \code{denom}. Columns \code{lower} and \code{upper} define credible intervals for the "data-based" point estimate \code{prob}, obtained from the Beta posterior assuming a Beta(0.5, 0.5) prior. 6 | ##' 7 | ##' This "data-based" point estimate can be compared with estimates from the model using the functions \code{\link{plotfit_data_disbayes}} and \code{\link{plotfit_disbayes}}. 8 | ##' 9 | ##' @export 10 | tidy_obsdat <- function(x){ 11 | if (inherits(x, "disbayes_hier")) return(tidy_obsdat_hier(x)) 12 | dat <- x$dat 13 | inc <- data.frame(var="inc", num = dat$inc_num, denom = dat$inc_denom) 14 | prev <- data.frame(var="prev", num = dat$prev_num, denom = dat$prev_denom) 15 | mort <- data.frame(var="mort", num = dat$mort_num, denom = dat$mort_denom) 16 | tdat <- rbind(inc, prev, mort) 17 | if (dat$remission) { 18 | rem <- data.frame(var="rem", num = dat$rem_num, denom = dat$rem_denom) 19 | tdat <- rbind(tdat, rem) 20 | } 21 | tdat$age <- rep(1:dat$nage, length.out = nrow(tdat)) - 1 22 | tdat$prob <- tdat$num/tdat$denom 23 | tdat$lower <- qbeta(0.025, tdat$num+0.5, tdat$denom-tdat$num+0.5) 24 | tdat$upper <- qbeta(0.975, tdat$num+0.5, tdat$denom-tdat$num+0.5) 25 | tdat 26 | } 27 | 28 | tidy_obsdat_hier <- function(x){ 29 | dat <- x$stan_data 30 | dims <- dim(dat$mort_num) 31 | vars <- c("inc","prev","mort") 32 | if (dat$remission) vars <- c(vars, "rem") 33 | res <- vector(length(vars), mode="list") 34 | for (i in seq_along(vars)){ 35 | tdat <- array_indvecs(dims) 36 | names(tdat) <- c("age", "area", "gender") 37 | tdat$age <- tdat$age - 1 38 | tdat$num <- as.vector(dat[[sprintf("%s_num",vars[i])]]) 39 | tdat$denom <- as.vector(dat[[sprintf("%s_denom",vars[i])]]) 40 | tdat$var <- vars[i] 41 | tdat$prob <- tdat$num/tdat$denom 42 | tdat$lower <- qbeta(0.025, tdat$num+0.5, tdat$denom-tdat$num+0.5) 43 | tdat$upper <- qbeta(0.975, tdat$num+0.5, tdat$denom-tdat$num+0.5) 44 | res[[i]] <- tdat 45 | } 46 | do.call("rbind", res) 47 | } 48 | 49 | ##' Create tidy data for a check of observed against fitted outcome probability estimates 50 | ##' from disbayes 51 | ##' 52 | ##' @param x Fitted model from \code{\link{disbayes}} 53 | ##' 54 | ##' @return A data frame containing observed data in the form of outcome probabilities, as extracted by \code{\link{tidy_obsdat}}, and estimates of the corresponding probability parameters from the fitted model. 55 | ##' 56 | ##' @export 57 | plotfit_data_disbayes <- function(x){ 58 | var <- age <- prob <- lower <- upper <- source <- mode <- `50%` <- `2.5%` <- `97.5%` <- NULL 59 | datobs <- tidy_obsdat(x) %>% 60 | dplyr::select(var, age, prob, lower, upper) %>% 61 | dplyr::mutate(source="Observed") 62 | vars <- c("inc_prob","prev_prob","mort_prob") 63 | if (x$dat$remission) vars <- c(vars, "rem_prob") 64 | res <- tidy(x) 65 | res$prob <- if(is.null(res$mode)) res$`50%` else res$mode 66 | res <- res %>% 67 | dplyr::filter(var %in% vars) %>% 68 | dplyr::rename(lower=`2.5%`, upper=`97.5%`) %>% 69 | dplyr::select(var, age, prob, lower, upper) %>% 70 | dplyr::mutate(source="Fitted", 71 | var = gsub("_prob","",var)) %>% 72 | dplyr::full_join(datobs, by = c("var", "age", "prob", "lower", "upper", "source")) 73 | res$var[res$var=="inc"] <- "Incidence" 74 | res$var[res$var=="prev"] <- "Prevalence" 75 | res$var[res$var=="mort"] <- "Mortality" 76 | if (any(res$var=="rem")) res$var[res$var=="rem"] <- "Remission" 77 | res 78 | } 79 | 80 | ##' Graphical check of observed against fitted outcome probabilities from disbayes 81 | ##' 82 | ##' The data behind the plot can be produced using \code{\link{plotfit_data_disbayes}}, 83 | ##' to enable customised plots to be produced by hand with \code{ggplot2}. 84 | ##' 85 | ##' @inheritParams plotfit_data_disbayes 86 | ##' 87 | ##' @param agemin Minimum age to show on the horizontal axis. 88 | ##' 89 | ##' @return A \code{ggplot2} object containing the plot. 90 | ##' 91 | ##' @export 92 | plotfit_disbayes <- function(x, agemin=50){ 93 | age <- prob <- lower <- upper <- source <- NULL 94 | res <- plotfit_data_disbayes(x) %>% 95 | dplyr::filter(age>agemin) 96 | ggplot2::ggplot(res, ggplot2::aes(x=age, y=prob, col=source)) + 97 | ggplot2::geom_ribbon(ggplot2::aes(ymin=lower, ymax=upper, fill=source), 98 | alpha=0.1) + 99 | ggplot2::geom_line() + 100 | ggplot2::facet_wrap(~var, nrow=1, scales="free_y") + 101 | ggplot2::ylab("") 102 | } 103 | 104 | ## Extract samples from optimisation output 105 | ## Only implemented currently for parameters with three indices 106 | 107 | opt_extract_nonhier <- function(xfit, par){ 108 | varorig <- NULL 109 | sam <- xfit$theta_tilde 110 | parnames <- colnames(sam) 111 | sam <- sam[,grep(sprintf("^%s\\[.+", par), parnames)] 112 | parnames <- colnames(sam) 113 | indvars <- if (par=="mort_prob") "age" else c("age","bias") 114 | ninds <- length(indvars) 115 | pattern <- paste0(par, "\\[", paste(rep("([[:digit:]]+)",ninds), collapse=","), "\\]") 116 | dat <- data.frame(varorig = parnames) 117 | dat <- dat %>% 118 | tidyr::extract(varorig, indvars, pattern, convert=TRUE) 119 | dat$age <- dat$age - 1 120 | nsam <- nrow(sam) 121 | long_inds <- rep(1:nrow(dat), each=nsam) 122 | dat_long <- dat[long_inds,,drop=FALSE] 123 | dat_long$var <- as.vector(sam) 124 | dat_long$sam <- 1:nsam 125 | rownames(dat_long) <- NULL 126 | dat_long 127 | } 128 | 129 | ## Not used currently 130 | 131 | opt_extract_hier <- function(xfit, par){ 132 | varorig <- NULL 133 | sam <- xfit$theta_tilde 134 | parnames <- colnames(sam) 135 | sam <- sam[,grep(sprintf("^%s\\[.+", par), parnames)] 136 | parnames <- colnames(sam) 137 | ninds <- 3 138 | pattern <- paste0(par, "\\[", paste(rep("([[:digit:]]+)",ninds), collapse=","), "\\]") 139 | dat <- data.frame(varorig = parnames) 140 | dat <- dat %>% 141 | tidyr::extract(varorig, c("age","area","gender"), pattern, convert=TRUE) 142 | dat$age <- dat$age - 1 143 | nsam <- nrow(sam) 144 | long_inds <- rep(1:nrow(dat), each=nsam) 145 | dat_long <- dat[long_inds,,drop=FALSE] 146 | dat_long$var <- as.vector(sam) 147 | rownames(dat_long) <- NULL 148 | dat_long 149 | } 150 | 151 | ##' Conflict p-values 152 | ##' 153 | ##' A test of the hypothesis that the direct data on a disease outcome give the same 154 | ##' information about that outcome as an indirect evidence synthesis obtained from a fitted \code{\link{disbayes}} 155 | ##' model. The outcome may be annual incidence, mortality, remission probabilities, 156 | ##' or prevalence. 157 | ##' 158 | ##' Hierarchical models are not currently supported in this function. 159 | ##' 160 | ##' @param x A fitted \code{\link{disbayes}} model. 161 | ##' 162 | ##' @param varname Either \code{inc}, \code{prev}, \code{mort} or \code{rem}. 163 | ##' 164 | ##' @return A data frame with columns indicating age, gender and area. 165 | ##' 166 | ##' \code{p1} is a "one-sided" p-value for the null hypothesis that \eqn{r_{obs}=r_{fit}} against 167 | ##' the alternative that \eqn{r_{obs} > r_{fit}}, 168 | ##' 169 | ##' \code{p2} is the two-sided p-value for the null hypothesis that \eqn{r_{obs}=r_{fit}} against 170 | ##' the alternative that \eqn{r_{obs}} is not equal to \eqn{r_{fit}}, 171 | ##' 172 | ##' where \eqn{r_{obs}} is the rate informed only by direct data, and \eqn{r_{fit}} is the rate 173 | ##' informed by evidence synthesis. Therefore if the evidence synthesis excludes the 174 | ##' direct data, then these are interpreted as "conflict" p-values (see Presanis et al. 2013). 175 | ##' 176 | ##' In each case, a small p-value favours the alternative hypothesis. 177 | ##' 178 | ##' @references Presanis, A. M., Ohlssen, D., Spiegelhalter, D. J. and De Angelis, D. (2013) 179 | ##' Conflict diagnostics in directed acyclic graphs, with applications in Bayesian evidence 180 | ##' synthesis. Statistical Science, 28, 376-397. 181 | ##' 182 | ##' @export 183 | conflict_disbayes <- function(x, varname){ 184 | ## Extract observed and fitted value of "varname_prob" by sample, age [ area and gender ] 185 | ## as tidy data frame 186 | datobs <- tidy_obsdat(x) 187 | datobs <- datobs[datobs$var==varname,] 188 | if (inherits(x$fit, "stanfit")){ 189 | fitted <- rstan::extract(x$fit, pars=paste(varname, "prob", sep="_"))[[1]] 190 | nsam <- dim(fitted)[1] 191 | nage <- dim(fitted)[2] 192 | if (inherits(x, "disbayes_hier")){ 193 | narea <- dim(fitted)[3] 194 | ngender <- dim(fitted)[4] 195 | } else { 196 | narea <- ngender <- 1 197 | datobs$area <- datobs$gender <- 1 198 | fitted <- array(as.vector(fitted), dim=c(dim(fitted), 1, 1)) 199 | } 200 | res <- datobs[,c("age","area","gender")] 201 | fitted_long <- res[rep(1:nrow(res), each=nsam),] 202 | fitted_long$sam <- 1:nsam # auto replicated 203 | fitted_long$var <- as.vector(fitted) 204 | } else { 205 | fitted_long <- opt_extract_nonhier(x$fit, paste0(varname,"_prob")) 206 | if (is.null(fitted_long$area)) fitted_long$area <- 1 207 | if (is.null(fitted_long$gender)) fitted_long$gender <- 1 208 | nsam <- length(unique(fitted_long$sam)) 209 | nage <- length(unique(fitted_long$age)) 210 | narea <- length(unique(fitted_long$area)) 211 | ngender <- length(unique(fitted_long$gender)) 212 | res <- fitted_long[fitted_long$sam==1,c("age","area","gender")] 213 | } 214 | res$p1 <- res$p2 <- NA 215 | 216 | ages <- 0:(nage-1) 217 | for (a in 1:nage){ 218 | for (j in 1:narea){ 219 | for (g in 1:ngender){ 220 | ind <- (res$age==ages[a]) & (res$area==j) & (res$gender==g) 221 | num <- datobs$num[ind] 222 | denom <- datobs$denom[ind] 223 | obssam <- rbeta(nsam, num + 0.5, denom - num + 0.5) 224 | fitsam <- fitted_long$var[ind] 225 | res$p1[ind] <- mean(obssam < fitsam) 226 | res$p2[ind] <- 2*min(res$p1[ind], 1 - res$p1[ind]) 227 | } 228 | } 229 | } 230 | res 231 | } 232 | -------------------------------------------------------------------------------- /R/inits.R: -------------------------------------------------------------------------------- 1 | ## mdat <- remission, eqage, const_rem 2 | ## min <- cf_init 3 | 4 | init_rates <- function(dat, mdata, idata,...){ 5 | inc_init <- init_rate("inc", dat) 6 | rem_init <- init_rate("rem", dat, agg=mdata$const_rem) 7 | optu <- fit_unsmoothed_opt(dat, inc_init=inc_init, rem_init=rem_init, 8 | mdata=mdata, idata=idata) 9 | optdf <- tidy_disbayes_opt(optu, .disbayes_vars) 10 | cf <- optdf$mode[optdf$var=="cf"] 11 | inc <- optdf$mode[optdf$var=="inc"] 12 | rem <- optdf$mode[optdf$var=="rem"] 13 | eqage <- mdata$eqage 14 | for (i in 1:eqage){ 15 | cf[i] <- cf[eqage+1] 16 | inc[i] <- inc[eqage+1] 17 | rem[i] <- rem[eqage+1] 18 | } 19 | init_eqage_hi <- 90 20 | for (i in init_eqage_hi:dat$nage){ 21 | cf[i] <- cf[init_eqage_hi-1] 22 | inc[i] <- inc[init_eqage_hi-1] 23 | rem[i] <- rem[init_eqage_hi-1] 24 | } 25 | if (mdata$const_rem) rem=rem_init 26 | list(cf=cf, inc=inc, rem=rem, optu=optu) 27 | } 28 | 29 | init_rate <- function(rate, dat, agg=FALSE){ 30 | default <- 0.001 31 | nums <- dat[[sprintf("%s_num",rate)]] 32 | denoms <- dat[[sprintf("%s_denom",rate)]] 33 | if (agg) { nums <- sum(nums); denoms <- sum(denoms) } 34 | rcrude <- nums / denoms 35 | rcrude[is.na(rcrude)] <- default 36 | rcrude[is.nan(rcrude)] <- default 37 | rcrude <- pmax(default, rcrude) 38 | rcrude 39 | } 40 | 41 | fit_unsmoothed_opt <- function(dat, inc_init=NULL, rem_init=NULL, 42 | mdata, idata){ 43 | if (is.null(inc_init)) inc_init <- init_rate("inc", dat) 44 | if (is.null(rem_init)) rem_init <- init_rate("rem", dat, mdata$const_rem) 45 | nage <- dat$nage 46 | Xdummy <- matrix(0, nrow=nage, ncol=2) 47 | datstanu <- c(dat, mdata) 48 | ## quantities in the data that are different for the purpose of this training model 49 | data_fixed <- list(smooth_cf = 0, smooth_inc = 0, smooth_rem = 0, 50 | const_cf = 0, trend = 0, nyr=1, nbias=1, 51 | bias = 1, incdata_ind = 1, prevdata_ind = 1, 52 | increasing_cf=0, K=2, X=Xdummy, 53 | inc_trend = array(1, dim=c(nage,1)), 54 | cf_trend = array(1, dim=c(nage,1)), 55 | scf_isfixed=0, sinc_isfixed=0, srem_isfixed=0, 56 | lambda_cf_fixed=0, lambda_inc_fixed=0, lambda_rem_fixed=0) 57 | for (i in names(data_fixed)) 58 | datstanu[[i]] <- data_fixed[[i]] 59 | initu <- list(cf_par = rep(idata$cf_init,nage), 60 | rem_par = if (mdata$remission) as.array(rem_init) else numeric(), 61 | inc_par = inc_init, 62 | prevzero = if (mdata$prev_zero) as.array(max(dat$prev_num[1],1)/max(dat$prev_denom[1],2)) else numeric()) 63 | opt <- rstan::optimizing(stanmodels$disbayes, data = datstanu, 64 | init = initu, 65 | hessian = FALSE) 66 | class(opt) <- "disopt" 67 | opt 68 | } 69 | 70 | ## Obtains spline basis terms, and initial values for their coefficients given 71 | ## estimates of incidence or CF from unsmoothed model. 72 | 73 | init_smooth <- function(y, eqage, eqagehi, s_opts=NULL){ 74 | x <- NULL # define unbound variables to satisfy R CMD check 75 | nage <- length(y) 76 | age <- agecons <- 1:nage 77 | agecons[1:eqage] <- eqage 78 | if (!is.null(eqagehi) && eqagehi < nage) 79 | agecons[eqagehi:nage] <- eqagehi 80 | sm <- mgcv::smoothCon(s(x), 81 | data=data.frame(x=agecons), 82 | diagonal.penalty=TRUE)[[1]] 83 | X <- sm$X 84 | beta <- coef(lm(y ~ X - 1)) 85 | list(X=X, beta=beta) 86 | } 87 | 88 | 89 | ## Form constant initial value list to supply to Stan 90 | 91 | initlist_const <- function(initrates, cf_smooth, inc_smooth, remission, rem_smooth, 92 | eqage, smooth_inc, smooth_cf, const_cf, 93 | increasing_cf, smooth_rem, const_rem, nbias, 94 | scf_isfixed, sinc_isfixed, srem_isfixed){ 95 | lam_init <- laminc_init <- lamrem_init <- 0.5 96 | beta_init <- cf_smooth$beta 97 | betainc_init <- inc_smooth$beta 98 | betarem_init <- rem_smooth$beta 99 | list(inc_par = if (smooth_inc) numeric() else initrates$inc, 100 | rem_par = if (remission && !smooth_rem) as.array(initrates$rem) else numeric(), 101 | beta = if (smooth_cf && !const_cf) beta_init else numeric(), 102 | lambda_cf = if (smooth_cf && !scf_isfixed) as.array(lam_init) else numeric(), 103 | beta_inc = if (smooth_inc) betainc_init else numeric(), 104 | lambda_inc = if (smooth_inc && !sinc_isfixed) as.array(laminc_init) else numeric(), 105 | beta_rem = if (smooth_rem) betarem_init else numeric(), 106 | lambda_rem = if (smooth_rem && !srem_isfixed) as.array(lamrem_init) else numeric(), 107 | cfbase = if (const_cf | increasing_cf) as.array(initrates$cf[eqage]) else numeric(), 108 | bias_loghr = if (nbias > 1) as.array(rnorm(1)) else numeric() 109 | ) 110 | } 111 | 112 | ## Form initial value list random generating function to supply to Stan 113 | 114 | initlist_random <- function(nage, initrates, cf_smooth, inc_smooth, remission, rem_smooth, 115 | eqage, smooth_inc, smooth_cf, const_cf, increasing_cf, 116 | smooth_rem, const_rem, nbias, scf_isfixed, sinc_isfixed, srem_isfixed){ 117 | lam_init <- laminc_init <- lamrem_init <- 0.5 118 | beta_init <- cf_smooth$beta 119 | betainc_init <- inc_smooth$beta 120 | betarem_init <- rem_smooth$beta 121 | inits <- function(){ 122 | list( 123 | inc_par = rlnorm(nage*(1-smooth_inc), 124 | meanlog=log(initrates$inc), 125 | sdlog=initrates$inc/10), 126 | rem_par = as.array(rlnorm(remission*(1-smooth_rem)*(nage*(1 - const_rem) + 1*const_rem), 127 | meanlog=log(initrates$rem), 128 | sdlog=initrates$rem/10)), 129 | beta = if (smooth_cf) rnorm(length(beta_init)*(1 - const_cf), 130 | mean=beta_init, 131 | sd=abs(beta_init)/10) else numeric(), 132 | lambda_cf = as.array(rlnorm(length(lam_init)*smooth_cf*(1-scf_isfixed), 133 | meanlog=log(lam_init), 134 | sdlog=lam_init/10)), 135 | beta_inc = if (smooth_inc) rnorm(length(betainc_init), 136 | mean=betainc_init, 137 | sd=abs(betainc_init)/10) else numeric(), 138 | lambda_inc = as.array(rlnorm(length(laminc_init)*smooth_inc*(1-sinc_isfixed), 139 | meanlog=log(laminc_init), 140 | sdlog=laminc_init/10)), 141 | beta_rem = if (remission && !const_rem) rnorm(length(betarem_init)*smooth_rem, 142 | mean=betarem_init, sd=abs(betarem_init)/10) else numeric(), 143 | lambda_rem = as.array(rlnorm(length(lamrem_init)*smooth_rem*(1-srem_isfixed), 144 | meanlog=log(lamrem_init), 145 | sdlog=lamrem_init/10)), 146 | cfbase = if (const_cf | increasing_cf) as.array(initrates$cf[eqage]) else numeric(), 147 | bias_loghr = if (nbias > 1) as.array(rnorm(1)) else numeric() 148 | ) 149 | } 150 | inits 151 | } 152 | 153 | fit_unsmoothed <- function(dat, inc_init=NULL, rem_init=NULL, 154 | mdata, idata, 155 | method = "mcmc", 156 | iter = 1000, 157 | stan_control = NULL, ...){ 158 | if (is.null(inc_init)) inc_init <- init_rate("inc", dat) 159 | if (is.null(rem_init)) rem_init <- init_rate("rem", dat) 160 | nage <- dat$nage 161 | Xdummy <- matrix(0, nrow=nage, ncol=2) 162 | datstanu <- c(dat, mdata) 163 | ## quantities in the data that are different for the purpose of the unsmoothed model 164 | ## everything else is passed from dat (observed data) or mdata (model spec) 165 | data_fixed <- list(smooth_cf = 0, smooth_inc = 0, const_cf = 0, trend = 0, nyr=1, nbias=1, 166 | bias = 1, incdata_ind = 1, prevdata_ind = 1, 167 | increasing_cf=0, K=2, X=Xdummy, 168 | inc_trend = array(1, dim=c(nage,1)), 169 | cf_trend = array(1, dim=c(nage,1)), 170 | scf_isfixed=0, sinc_isfixed=0, srem_isfixed=0, 171 | lambda_cf_fixed=0, lambda_inc_fixed=0, lambda_rem_fixed=0) 172 | for (i in names(data_fixed)) 173 | datstanu[[i]] <- data_fixed[[i]] 174 | initu <- function(){ 175 | list(cf_par = rnorm(nage, mean=idata$cf_init, sd=idata$cf_init/10), 176 | rem_par = rnorm(mdata$remission*(1 - mdata$smooth_rem)*(nage*(1 - mdata$const_rem) + 1*mdata$const_rem), 177 | mean=rem_init, sd=rem_init/10), 178 | inc_par = rnorm(nage, mean=inc_init, sd=inc_init/10)) 179 | } 180 | if (method=="mcmc") { 181 | fitu <- rstan::sampling(stanmodels$disbayes, data = datstanu, 182 | init = initu, include = FALSE, pars=c("beta","lambda"), 183 | iter = iter, 184 | control = stan_control, ...) 185 | } else { 186 | fitu <- rstan::vb(stanmodels$disbayes, data = datstanu, 187 | init = initu, include = FALSE, pars=c("beta","lambda")) 188 | } 189 | fitu 190 | } 191 | -------------------------------------------------------------------------------- /R/loo.R: -------------------------------------------------------------------------------- 1 | ##' Leave-one-out cross validation for disbayes models 2 | ##' 3 | ##' @param x A model fitted by \code{\link{disbayes}}. Any of the computation methods 4 | ##' are supported. 5 | ##' 6 | ##' @param outcome Either \code{"overall"}, to assess the fit to all data, or 7 | ##' one of \code{"inc"}, \code{"prev"}, \code{"mort"} or \code{"rem"}, to assess the fit 8 | ##' to the incidence data, prevalence data, mortalidy data or remission data, respectively. 9 | ##' 10 | ##' @param ... Other arguments (currently unused). 11 | ##' 12 | ##' @return An object of class \code{"loo"} as defined by the \pkg{loo} package. 13 | ##' 14 | ##' @seealso \code{\link{loo_indiv}} to return tidied observation-specific contributions 15 | ##' to the overall model fit computed here. 16 | ##' 17 | ##' @export 18 | loo.disbayes <- function(x, outcome="overall", ...){ 19 | if (x$method=="opt"){ 20 | res <- loo_disbayes_opt(x, outcome=outcome) 21 | } else { 22 | res <- loo_disbayes_mcmc(x, outcome=outcome) 23 | } 24 | attr(res, "disbayes_info") <- list(hier = inherits(x, "disbayes_hier")) 25 | res 26 | } 27 | 28 | loo_disbayes_mcmc <- function(x, outcome="overall") { 29 | ll <- loo::extract_log_lik(x$fit, sprintf("ll_%s",outcome), merge_chains=FALSE) 30 | r_eff <- loo::relative_eff(exp(ll)) 31 | res <- loo::loo(ll, r_eff = r_eff) 32 | ## name the rows of the indiv-level contributions to match the outcome probs 33 | ## note in same order as Stan generated_quantities 34 | inames <- list() 35 | for (i in c("mort","inc","prev","rem")){ 36 | supp <- x$dat[[sprintf("%s_supplied",i)]] 37 | if (is.null(supp) || isTRUE(supp)) 38 | inames[[i]] <- grep(sprintf("%s_prob",i), names(x$fit), value=TRUE) 39 | } 40 | rownames(res$pointwise) <- as.vector(unlist(inames)) 41 | res 42 | } 43 | 44 | loo_disbayes_opt <- function(x, outcome="overall") { 45 | log_p <- x$fit$log_p # log density of the posterior. 46 | log_g <- x$fit$log_g # log density of the approximation 47 | draws <- x$fit$theta_tilde 48 | outs <- character() 49 | if (x$dat$inc_supplied) outs <- c(outs, "inc") 50 | if (x$dat$prev_supplied) outs <- c(outs, "prev") 51 | outs <- c(outs, "mort") 52 | if (x$dat$rem_supplied) outs <- c(outs, "rem") 53 | if (outcome=="overall") { 54 | outcome_names <- paste(rep(outs,each=2), rep(c("num","denom"), length(outs)), sep="_") 55 | datlist <- parlist <- vector(length(outs), mode="list") 56 | for (i in seq_along(outs)){ 57 | num <- as.vector(x$stan_data[[sprintf("%s_num",outs[i])]]) 58 | denom <- as.vector(x$stan_data[[sprintf("%s_denom",outs[i])]]) 59 | datlist[[i]] <- data.frame(num, denom) 60 | outcome_regex <- sprintf("^(%s)_prob\\[.+\\]", outs[i]) 61 | prob_names <- grepl(outcome_regex, colnames(draws)) 62 | parlist[[i]] <- t(draws[,prob_names]) # nsam x nobs matrix 63 | } 64 | dat <- do.call("rbind", datlist) 65 | prob_draws <- do.call("rbind", parlist) 66 | } else if (outcome %in% outs) { 67 | num <- as.vector(x$stan_data[[sprintf("%s_num",outcome)]]) 68 | denom <- as.vector(x$stan_data[[sprintf("%s_denom",outcome)]]) 69 | dat <- data.frame(num, denom) 70 | prob_names <- grepl(sprintf("^%s_prob\\[.+\\]", outcome), colnames(draws)) 71 | prob_draws <- t(draws[,prob_names]) # nsam x nobs matrix 72 | } else stop(sprintf("`outcome` should be one of \"overall\", %s"), 73 | paste("\"outs\"", collapse=", ")) 74 | ll_mat <- t(dbinom(x = dat[,"num"], size = dat[,"denom"], prob = prob_draws, log=TRUE)) 75 | loo_ap <- 76 | loo::loo_approximate_posterior( 77 | x = ll_mat, 78 | draws = x$fit$theta_tilde, 79 | data = dat, 80 | log_p = log_p, 81 | log_g = log_g, 82 | cores = 1 83 | ) 84 | loo_ap 85 | } 86 | 87 | ##' Extract observation-specific contributions from a disbayes leave-one-out cross validation 88 | ##' 89 | ##' @param x For \code{loo_indiv}, an object returned by \code{\link{loo.disbayes}}. For \code{looi_disbayes}, an object returned by \code{\link{disbayes}}. 90 | ##' 91 | ##' @param agg If \code{TRUE} then the observation-specific contributions are aggregated over 92 | ##' outcome type, returning a data frame with one row for each of incidence, prevalence, mortality 93 | ##' and remission (if remission is included in the model), and one column for each of \code{"elpd_loo"}, 94 | ##' \code{"p_loo"} and \code{"looic"}. 95 | ##' 96 | ##' @return A data frame with one row per observed age-specific mortality, incidence, prevalence and/or 97 | ##' remission age-specific data-point, containing leave-one-out cross validation statistics representing how 98 | ##' well the model would predict that observation if it were left out of the fit. 99 | ##' 100 | ##' These are computed with the \pkg{loo} package. 101 | ##' 102 | ##' \code{loo_indiv} acts on the objects that are returned by running \code{\link{loo}} on \code{\link{disbayes}} 103 | ##' objects. \code{\link{looi_disbayes}} acts directly on \code{\link{disbayes}} 104 | ##' objects. Both of those functions return a data frame with LOO contributions for each data point. 105 | ##' 106 | ##' @export 107 | loo_indiv <- function(x, agg=FALSE){ 108 | varorig <- outcome <- age <- bias <- NULL 109 | if (attr(x, "disbayes_info")[["hier"]]) { 110 | dat <- loo_indiv_hier(x) 111 | } else { 112 | dat <- as.data.frame(x$pointwise) %>% 113 | tibble::rownames_to_column("varorig") %>% 114 | tidyr::extract(varorig, c("outcome", "age"), 115 | "^(.+)_prob\\[([[:digit:]]+),?[[:digit:]]?\\]$", 116 | convert=TRUE, remove = FALSE) %>% 117 | tidyr::extract(varorig, "bias", 118 | "^.+_prob\\[[[:digit:]]+,([[:digit:]])\\]$", 119 | convert=TRUE) %>% 120 | relocate(outcome, age, bias) 121 | } 122 | if (length(unique(na.omit(dat$bias)))==1) dat$bias <- NULL 123 | if (agg) { 124 | dat <- dat %>% 125 | group_by(outcome) %>% 126 | summarise_at(c("elpd_loo","p_loo","looic"), sum) 127 | } 128 | dat 129 | } 130 | 131 | loo_indiv_hier <- function(x){ 132 | varorig <- outcome <- age <- area <- gender <- NULL 133 | index_re <- paste(rep("([[:digit:]]+)",3),collapse=",") 134 | as.data.frame(x$pointwise) %>% 135 | tibble::rownames_to_column("varorig") %>% 136 | tidyr::extract(varorig, c("outcome", "age", "area", "gender"), 137 | sprintf("^(.+)_prob\\[%s\\]$", index_re), 138 | convert=TRUE, remove = TRUE) 139 | } 140 | 141 | ##' @describeIn loo_indiv Observation-level leave-one-out cross validation statistics for a disbayes model 142 | ##' @export 143 | looi_disbayes <- function(x, agg=FALSE){ 144 | loo_indiv(loo(x), agg=agg) 145 | } 146 | -------------------------------------------------------------------------------- /R/stanmodels.R: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | # names of stan models 4 | stanmodels <- c("disbayes", "disbayes_hier") 5 | 6 | # load each stan module 7 | Rcpp::loadModule("stan_fit4disbayes_mod", what = TRUE) 8 | Rcpp::loadModule("stan_fit4disbayes_hier_mod", what = TRUE) 9 | 10 | # instantiate each stanmodel object 11 | stanmodels <- sapply(stanmodels, function(model_name) { 12 | # create C++ code for stan model 13 | stan_file <- if(dir.exists("stan")) "stan" else file.path("inst", "stan") 14 | stan_file <- file.path(stan_file, paste0(model_name, ".stan")) 15 | stanfit <- rstan::stanc_builder(stan_file, 16 | allow_undefined = TRUE, 17 | obfuscate_model_name = FALSE) 18 | stanfit$model_cpp <- list(model_cppname = stanfit$model_name, 19 | model_cppcode = stanfit$cppcode) 20 | # create stanmodel object 21 | methods::new(Class = "stanmodel", 22 | model_name = stanfit$model_name, 23 | model_code = stanfit$model_code, 24 | model_cpp = stanfit$model_cpp, 25 | mk_cppmodule = function(x) get(paste0("rstantools_model_", model_name))) 26 | }) 27 | -------------------------------------------------------------------------------- /R/state_probs.R: -------------------------------------------------------------------------------- 1 | state_probs_norem <- function(i, f) { 2 | l <- i + f 3 | q <- sqrt(i*i - 2*i*f + f*f) 4 | w <- exp(-(l + q) / 2) 5 | v <- exp(-(l - q) / 2) 6 | P <- array(dim=c(3, 3)) 7 | P[1,1] <- (2*(v-w)*f + v*(q-l) + w*(q+l)) / (2*q) 8 | P[2,1] <- 0 9 | P[3,1] <- 0 10 | 11 | P[1,2] <- i*(v - w)/q 12 | P[2,2] <- -((2*f - l)*(v-w) - q*(v+w)) / (2*q) 13 | P[3,2] <- 0 14 | 15 | P[1,3] <- (-l*(v-w) - q*(v+w))/(2*q) + 1 16 | P[2,3] <- ((v-w)*(2*f - l) - q*(v+w))/(2*q) + 1 17 | P[3,3] <- 1 18 | P 19 | } 20 | 21 | state_probs_rem <- function(i, f, r) { 22 | l <- i + r + f 23 | q <- sqrt(i*i + 2*i*r - 2*i*f + r*r + 2*f*r + f*f) 24 | w <- exp(-(l + q) / 2) 25 | v <- exp(-(l - q) / 2) 26 | P <- array(dim=c(3, 3)) 27 | 28 | P[1,1] <- (2*(v-w)*(f+r) + v*(q-l) + w*(q+l)) / (2*q) 29 | P[2,1] <- (v-w)*r/q 30 | P[3,1] <- 0 31 | 32 | P[1,2] <- i*(v - w)/q 33 | P[2,2] <- -((2*(f+r) - l)*(v-w) - q*(v+w)) / (2*q) 34 | P[3,2] <- 0 35 | 36 | P[1,3] <- (-l*(v-w) - q*(v+w))/(2*q) + 1 37 | P[2,3] <- ((v-w)*(2*f - l) - q*(v+w))/(2*q) + 1 38 | P[3,3] <- 1 39 | P 40 | } 41 | -------------------------------------------------------------------------------- /R/tidy.R: -------------------------------------------------------------------------------- 1 | ##' Form a tidy data frame from the estimates from a disbayes fit 2 | ##' 3 | ##' Simply call this after fitting disbayes, as, e.g. 4 | ##' ``` 5 | ##' res <- disbayes(...) 6 | ##' tidy(res) 7 | ##' ``` 8 | ##' 9 | ##' @importFrom generics tidy 10 | ##' 11 | ##' @param x Object returned by \code{\link{disbayes}} 12 | ##' 13 | ##' @param startyear Only used for models with time trends. Numeric year represented by year 1 in the data. For example, set this to 1918 to convert years 1-100 to years 1918-2017. 14 | ##' 15 | ##' @param ... Other arguments (currently unused) 16 | ##' 17 | ##' @return A data frame with one row per model parameter, giving summary statistics 18 | ##' for the posterior distribution for that parameter. For array parameters, e.g. those 19 | ##' that depend on age or area, then the age and area are returned in separate columns, 20 | ##' to make it easier to summarise and plot the results, e.g. using \pkg{ggplot2}. 21 | ##' 22 | ##' Model parameters might include, depending on the model specification, 23 | ##' 24 | ##' * `cf`, `inc`, `rem`: Case fatality, incidence, remission rates 25 | ##' 26 | ##' * `inc_prob`, `rem_prob`, `mort_prob`, `cf_prob`: Annual incidence, remission, mortality and case fatality risks (probabilities). 27 | ##' 28 | ##' * `prev_prob` Prevalence (probability). 29 | ##' 30 | ##' * `state_probs` State occupancy probabilities. 31 | ##' 32 | ##' * `beta`, `beta_inc` Coefficients of the spline basis for case fatality and incidence respectively. 33 | ##' 34 | ##' * `lambda_cf`, `lambda_inc` Smoothness parameters of the spline functions. 35 | ##' 36 | ##' * `prevzero` Prevalence at age zero 37 | ##' 38 | ##' * `cfbase` Case fatality at the baseline age (only in models where case fatality is increasing). 39 | ##' 40 | ##' * `dcf` Annual increments in case fatality (only in models where case fatality is increasing). 41 | ##' 42 | ##' * `bias_loghr` Log hazard ratio describing bias in case fatality between datasets (only in models where `bias_model` has been set). 43 | ##' 44 | ##' For models with time trends: 45 | ##' 46 | ##' * `cf_yr`, `inc_yr`, `state_probs_yr` Case fatality rates, incidence rates and state occupancy probabilities in years prior to the current year. `cf` and `inc` refer to the rates for the current year, the one represented in the data. 47 | ##' 48 | ##' 49 | ##' Only for hierarchical models: 50 | ##' 51 | ##' * `mean_inter`, `mean_slope`,`sd_inter`,`sd_slope`. Mean and standard deviation for random effects distribution for the intercept and slope of log case fatality. 52 | ##' 53 | ##' * `lambda_cf_male`, `lambda_inc_male`. Smoothness of the additive gender effect on case fatality and incidence. 54 | ##' 55 | ##' * `bareat` Area-level contribution to spline basis coefficients. 56 | ##' 57 | ##' * `barea` Normalised spline basis coefficients. 58 | ##' 59 | ##' @md 60 | ##' @export 61 | tidy.disbayes <- function(x, startyear = 1, ...) { 62 | varlist <- if (x$trend) .disbayes_trend_vars else .disbayes_vars 63 | if (x$method %in% c("mcmc","vb")) 64 | res <- tidy_disbayes_full(x$fit, varlist, x$method) 65 | else if (x$method=="opt") 66 | res <- tidy_disbayes_opt(x$fit, varlist) 67 | if (x$trend) 68 | res$year <- res$year + startyear - 1 69 | res 70 | } 71 | 72 | ##' @describeIn tidy.disbayes Tidy method for hierarchical disbayes models 73 | ##' @export 74 | tidy.disbayes_hier <- function(x, ...) { 75 | levs <- x[c("groups","genders")] 76 | if (x$method %in% c("mcmc","vb")) 77 | tidy_disbayes_full(x$fit, varlist=.disbayes_hier_vars, x$method, levs) 78 | else if (x$method=="opt") 79 | tidy_disbayes_opt(x$fit, varlist=.disbayes_hier_vars, levs) 80 | } 81 | 82 | get_opt_quantiles <- function(opt){ 83 | has_sample <- (!is.null(opt$theta_tilde) && (nrow(opt$theta_tilde)>1)) 84 | if (has_sample){ 85 | quantiles <- as.data.frame( 86 | matrixStats::colQuantiles(opt$theta_tilde, probs=c(0.025, 0.25, 0.5, 0.75, 0.975), na.rm=TRUE) 87 | ) 88 | } 89 | else quantiles <- NULL 90 | } 91 | 92 | tidy_disbayes_opt <- function(opt, varlist, levs=NULL){ 93 | varorig <- NULL 94 | ests <- data.frame(varorig = names(opt$par), mode=opt$par, row.names=NULL) %>% 95 | tidyr::extract(varorig, "var", "(.+)\\[.+\\]", remove=FALSE) 96 | stats <- "mode" 97 | quantiles <- get_opt_quantiles(opt) 98 | if (!is.null(quantiles)){ 99 | ests <- cbind(ests, quantiles) 100 | stats <- c(stats, names(quantiles)) 101 | } 102 | tidy_stansumm(ests, varlist, stats, levs) 103 | } 104 | 105 | tidy_disbayes_full <- function(fit, varlist, method, levs=NULL, ...) { 106 | varorig <- NULL 107 | summ <- rstan::summary(fit)$summary %>% 108 | as.data.frame() %>% 109 | rownames_to_column("varorig") %>% 110 | tidyr::extract(varorig, "var", "(.+)\\[.+\\]", remove=FALSE) 111 | stats_ests <- c("mean", "se_mean", "sd", "2.5%", "25%", "50%", "75%", "97.5%", "n_eff") 112 | stats_diag <- if (method=="mcmc") "Rhat" else "khat" 113 | stats <- c(stats_ests, stats_diag) 114 | tidy_stansumm(summ, varlist, stats, levs) 115 | } 116 | 117 | .disbayes_vars <- list( 118 | age = list(indnames = "age", 119 | varnames = c("cf","inc_par","cf_par","rem_par", 120 | "dcf","rem","rem_prob","mort_prob","cf_prob")), 121 | agebias = list(indnames = c("age", "bias"), 122 | varnames = c("inc", "inc_prob", "prev_prob")), 123 | agebiasstate = list(indnames = c("age", "bias", "state"), 124 | varnames = "state_probs"), 125 | term = list(indnames = "term", 126 | varnames = c("beta", "beta_inc")), 127 | const = c("lambda_cf","lambda_inc","prevzero","cfbase","bias_loghr"), 128 | redundant = c("inc_par","cf_par","rem_par") 129 | ) 130 | attr(.disbayes_vars, "numerics") <- c("age", "bias", "state", "term") 131 | attr(.disbayes_vars, "order") <- c("age", "bias", "state", "term") 132 | 133 | .disbayes_trend_vars <- list( 134 | age = list(indnames="age", 135 | varnames = c("cf", "inc_par", "rem_par", "rem", 136 | "rem_prob", "mort_prob","cf_prob")), 137 | ageyear = list(indnames = c("age", "year"), 138 | varnames = c("cf_yr")), 139 | agebias = list(indnames = c("age", "bias"), 140 | varnames = c("inc","inc_prob","prev_prob")), 141 | ageyearbias = list(indnames = c("age", "year", "bias"), 142 | varnames = c("inc_yr")), 143 | ageyearbiasstate = list(indnames = c("age","year","bias","state"), 144 | varnames = c("state_probs_yr")), 145 | term = list(indnames = "term", 146 | varnames = c("beta", "beta_inc")), 147 | const = c("lambda_cf","lambda_inc","prevzero","cfbase","bias_loghr"), 148 | redundant = c("inc_par","cf_par","rem_par") 149 | ) 150 | attr(.disbayes_trend_vars, "numerics") <- c("age","year","bias", "state", "term") 151 | attr(.disbayes_trend_vars, "order") <- c("age", "year", "bias", "state", "term") 152 | 153 | .disbayes_hier_vars <- list( 154 | ageareagender = list( 155 | indnames = c("age","area","gender"), 156 | varnames = c("inc","cf","dcf","inc_prob","prev_prob", 157 | "mort_prob","cf_prob","rem","rem_prob") 158 | ), 159 | ageareagenderstate = list( 160 | indnames = c("age","area","gender","state"), 161 | varnames = c("state_probs") 162 | ), 163 | agegender = list( 164 | indnames = c("age", "gender"), 165 | varnames = c("rem_par") 166 | ), 167 | termarea = list(indnames = c("term", "area"), 168 | varnames = c("barea","bareat")), 169 | termareagender = list( 170 | indnames = c("term", "area", "gender"), 171 | varnames = c("beta","beta_inc")), 172 | areagender = list( 173 | indnames = c("area", "gender"), 174 | varnames = c("prevzero")), 175 | area = list( 176 | indnames = c("area"), 177 | varnames = c("lcfbase")), 178 | term = list(indnames="term", 179 | varnames = c("bmale", "sd_inter", "mean_slope", "sd_slope", 180 | "lambda_cf","lambda_cf_male","lambda_inc")), 181 | const = c("mean_inter"), 182 | redundant = c("inc_par","cf_par","rem_par") 183 | ) 184 | attr(.disbayes_hier_vars, "numerics") <- c("age", "state", "term") 185 | attr(.disbayes_hier_vars, "factors") <- data.frame(vars = c("area","gender"), 186 | levs = c("groups", "genders"), 187 | stringsAsFactors = FALSE) 188 | attr(.disbayes_hier_vars, "order") <- c("age", "gender", "area", "state", "term") 189 | 190 | 191 | ## Convert Stan summary output to a tidy data frame with indices extracted as different variables 192 | ## I am reinventing the wheel somewhat here 193 | ## tidybayes and ggmcmc have similar functionality, but work on the draws rather than the output of rstan::summary. 194 | ## tidybayes::spread_draws has one col per variable and rows for different indices, iterations and draws 195 | ## gather_draws does the same in long format with a .variable col 196 | ## Then ggdist::median_qi is used to get summary statistics 197 | 198 | tidy_stansumm <- function(summ, varlist, stats, levs=NULL){ 199 | var <- varorig <- NULL 200 | summc <- summ %>% 201 | filter(var %in% varlist$const) %>% 202 | select(-varorig) 203 | 204 | varnc <- varlist[!(names(varlist) %in% c("const","redundant"))] 205 | nvartypes <- length(varnc) 206 | summs <- vector(nvartypes, mode="list") 207 | for (i in seq_along(varnc)){ 208 | indnames <- varnc[[i]]$indnames 209 | ninds <- length(indnames) 210 | pattern <- paste0(".+\\[", paste(rep("([[:digit:]]+)",ninds), collapse=","), "\\]") 211 | summs[[i]] <- summ %>% 212 | filter(var %in% varnc[[i]]$varnames) %>% 213 | tidyr::extract(varorig, varnc[[i]]$indnames, pattern) 214 | } 215 | 216 | summ <- summc 217 | for (i in seq_along(varnc)){ 218 | joinvars <- c("var", stats, 219 | intersect(names(summ), varnc[[i]]$indnames)) 220 | summ <- summ %>% full_join(summs[[i]], by=joinvars) 221 | } 222 | for (i in attr(varlist, "numerics")){ 223 | if (i %in% names(summ)) 224 | summ[[i]] <- as.numeric(summ[[i]]) 225 | } 226 | summ <- summ %>% relocate(all_of(c("var", attr(varlist, "order")))) 227 | facs <- attr(varlist, "factors") 228 | if (!is.null(facs)){ 229 | for (i in 1:nrow(facs)){ 230 | if (!is.null(levs[[facs$levs[i]]])) 231 | summ[[facs$vars[i]]] <- factor(summ[[facs$vars[i]]], labels=levs[[facs$levs[i]]]) 232 | else summ[[facs$vars[i]]] <- NULL 233 | } 234 | } 235 | summ <- summ[!(summ$var %in% varlist$redundant),] 236 | summ$age <- summ$age - 1 237 | summ 238 | } 239 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | disbayes 2 | ====== 3 | 4 | The development repository for the `disbayes` R package for chronic disease epidemiology estimation with incomplete data. 5 | 6 | * `disbayes` can estimate age-specific case fatality for a disease, given: 7 | 8 | - published information on age-specific mortality and at least one of incidence or prevalence 9 | 10 | - some indication of the uncertainty associated with the published estimates, either as a credible interval, or by expressing the estimate as a number of cases with associated denominator. 11 | 12 | * The underlying model is a three-state multi-state model with states given by no disease, disease and death. Remission from the disease is optional. 13 | 14 | * Case fatality, incidence or remission rates can be modelled as smooth functions of age, through a spline model, or estimated independently for each age. Case fatality or remission can also be modelled as age-constant. 15 | 16 | * Two alternative estimation methods can be used, both based on the [Stan](https://mc-stan.org) software. 17 | 18 | - exact point estimation using optimisation to obtain the posterior mode, with credible intervals based on an approximation to the Bayesian posterior. This is generally instant to compute, but the uncertainty quantification is approximate. 19 | 20 | - full Bayesian estimation using Markov Chain Monte Carlo. This gives more accurate uncertainty quantification but is computationally intensive. 21 | 22 | * The following more advanced models are provided, which are all more computationally intensive: 23 | 24 | - hierarchical models for data by age and area, which share information between areas to strengthen estimates from areas with less data 25 | 26 | - hierarchical models for data by age, area and gender, where the effect of gender is assumed to be the same for every area 27 | 28 | - models with assumed trends in disease incidence or case fatality through calendar time, where trends can be age-specific (non-hierarchical models only) 29 | 30 | * It is inspired by the [DisMod II](https://www.epigear.com/index_files/dismod_ii.html) and [DisMod-MR](https://github.com/ihmeuw/dismod_mr) packages used for the Global Burden of Disease studies. It modifies and extends the formal, fully Bayesian framework described in the [book by Flaxman et al.](https://uwapress.uw.edu/book/9780295991849/an-integrative-metaregression-framework-for-descriptive-epidemiology/). 31 | 32 | * The method is fully described in [Jackson et al. (2023)](https://doi.org/10.1093/jrsssa/qnac015). 33 | 34 | * Source code is at the [GitHub repository](https://github.com/chjackson/disbayes) 35 | 36 | ## Installation 37 | 38 | ### CRAN version 39 | 40 | ```r 41 | install.packages("disbayes") 42 | ``` 43 | 44 | 45 | ### Development version 46 | 47 | ```r 48 | install.packages("devtools") # if devtools not already installed 49 | library(devtools) 50 | install_github("chjackson/disbayes") 51 | ``` 52 | 53 | If this fails, make sure that the `rstan` package is set up properly, as [explained here](https://github.com/stan-dev/rstan/wiki/RStan-Getting-Started). If you are on Windows, then follow these instructions for [installing rstan from source on Windows](https://github.com/stan-dev/rstan/wiki/Configuring-C---Toolchain-for-Windows). 54 | 55 | 56 | ## Introduction and worked example 57 | 58 | [Bayesian estimation of chronic disease epidemiology from incomplete data: the disbayes package](https://chjackson.github.io/disbayes/articles/disbayes.html) 59 | 60 | 61 | 62 | 63 | [![R-CMD-check](https://github.com/chjackson/disbayes/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/chjackson/disbayes/actions/workflows/R-CMD-check.yaml) 64 | [![test-coverage](https://github.com/chjackson/disbayes/actions/workflows/test-coverage.yaml/badge.svg)](https://app.codecov.io/gh/chjackson/disbayes) 65 | [![CRAN status](https://www.r-pkg.org/badges/version/disbayes)](https://CRAN.R-project.org/package=disbayes) 66 | 67 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/_pkgdown.yml -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | #! /bin/sh 4 | "${R_HOME}/bin/Rscript" -e "rstantools::rstan_config()" 5 | -------------------------------------------------------------------------------- /configure.win: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | #! /bin/sh 4 | "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "rstantools::rstan_config()" 5 | -------------------------------------------------------------------------------- /data-raw/ihdengland.R: -------------------------------------------------------------------------------- 1 | library(devtools) 2 | library(dplyr) 3 | 4 | ihdengland <- readRDS(file.path("~/work/chronic/gbddb.rds")) %>% 5 | dplyr::filter(disease == "Ischemic heart disease") %>% 6 | select(-disease, -areatype, -rem_num, -rem_denom) 7 | 8 | usethis::use_data(ihdengland, overwrite = TRUE) 9 | -------------------------------------------------------------------------------- /data/ihdengland.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/data/ihdengland.rda -------------------------------------------------------------------------------- /data/ihdtrends.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/data/ihdtrends.rda -------------------------------------------------------------------------------- /disbayes.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | PackageCheckArgs: --no-install --as-cran 19 | PackageRoxygenize: rd,collate,namespace 20 | -------------------------------------------------------------------------------- /inst/include/stan_meta_header.hpp: -------------------------------------------------------------------------------- 1 | // Insert all #include statements here 2 | -------------------------------------------------------------------------------- /inst/stan/disbayes.stan: -------------------------------------------------------------------------------- 1 | #include /include/trans_probs.stan 2 | 3 | data { 4 | int inc_supplied; 5 | int prev_supplied; 6 | int smooth_cf; 7 | int smooth_inc; 8 | int smooth_rem; 9 | int remission; 10 | int trend; 11 | int prev_zero; 12 | int nage; 13 | int eqage; 14 | array[nage] int mort_num; 15 | array[nage] int mort_denom; 16 | array[nage] int prev_num; 17 | array[nage] int prev_denom; 18 | array[nage] int inc_num; 19 | array[nage] int inc_denom; 20 | array[nage] int rem_num; 21 | array[nage] int rem_denom; 22 | int nyr; 23 | 24 | // only in smoothed model 25 | int K; // number of spline basis variables including the intercept 26 | matrix[nage,K] X; 27 | array[3] real sprior; 28 | 29 | // alternative models 30 | int increasing_cf; // requires smooth_cf 31 | int const_cf; // special case of increasing_cf 32 | int const_rem; 33 | 34 | int nbias; // 1 if no incidence bias modelled 35 | // which of the two alternative incidence values generates the incidence data 36 | int incdata_ind; 37 | int prevdata_ind; // .. and the prevalence data 38 | 39 | // Multiplier for incidence in each age and calendar year 40 | // first index is age, second is calendar year 41 | matrix[nage,nyr] inc_trend; 42 | matrix[nage,nyr] cf_trend; 43 | 44 | array[2] real inc_prior; 45 | array[2] real cf_prior; 46 | array[2] real rem_prior; 47 | 48 | // Empirical Bayes method where smoothing parameters are fixed 49 | int scf_isfixed; 50 | int sinc_isfixed; 51 | int srem_isfixed; 52 | real lambda_cf_fixed; 53 | real lambda_inc_fixed; 54 | real lambda_rem_fixed; 55 | } 56 | 57 | parameters { 58 | vector[nage*(1-smooth_inc)] inc_par; 59 | vector[nage*(1-smooth_cf)] cf_par; 60 | vector[remission*(1-smooth_rem)*(nage*(1 - const_rem) + 1*const_rem)] rem_par; 61 | vector[K*smooth_cf*(1-const_cf)] beta; 62 | vector[smooth_cf*(1-scf_isfixed)] lambda_cf; 63 | vector[smooth_inc*(1-sinc_isfixed)] lambda_inc; 64 | vector[K*smooth_inc] beta_inc; 65 | vector[smooth_rem*(1-srem_isfixed)] lambda_rem; 66 | vector[K*smooth_rem] beta_rem; 67 | vector[prev_zero] prevzero; 68 | 69 | // Log HR between alternative incidence values in bias model, assumed common between ages 70 | vector[nbias==2] bias_loghr; 71 | 72 | vector[1*increasing_cf] cfbase; 73 | } 74 | 75 | transformed parameters { 76 | vector[nage] cf; 77 | vector[nage*increasing_cf] dcf; // only in increasing model 78 | matrix[nage,nbias] inc; 79 | matrix[nage,nbias] inc_prob; // don't bound due to occasional numerical fuzz in Hessian 80 | vector[nage] rem; 81 | vector[nage*remission] rem_prob; 82 | vector[nage] cf_prob; 83 | 84 | array[(nage+1)*(1-trend),nbias] row_vector[3] state_probs; 85 | row_vector[3] tmp; 86 | matrix[3,3] P; 87 | matrix[nage,nbias] prev_prob; 88 | array[nage] real mort_prob; 89 | 90 | matrix[nage*trend,nyr*trend] cf_yr; 91 | array[nage*trend,nyr*trend,nbias] real inc_yr; 92 | array[(nage+1)*trend,nyr*trend,nbias] row_vector[3] state_probs_yr; 93 | 94 | real lambda_cf_use; 95 | real lambda_inc_use; 96 | real lambda_rem_use; 97 | if (scf_isfixed || !smooth_cf) lambda_cf_use = lambda_cf_fixed; else lambda_cf_use = lambda_cf[1]; 98 | if (sinc_isfixed || !smooth_inc) lambda_inc_use = lambda_inc_fixed; else lambda_inc_use = lambda_inc[1]; 99 | if (srem_isfixed || !smooth_rem) lambda_rem_use = lambda_rem_fixed; else lambda_rem_use = lambda_rem[1]; 100 | 101 | /// Case fatality as smooth spline function of age 102 | /// Spline basis X passed from R 103 | if (smooth_inc) inc[1:nage,1] = exp(X*beta_inc); else inc[1:nage,1] = inc_par; 104 | if (nbias > 1) { 105 | inc[1:nage,2] = exp(log(inc[1:nage,1]) + bias_loghr[1]); 106 | } 107 | if (remission) { 108 | if (const_rem) { 109 | for (a in 1:nage) 110 | rem[a] = rem_par[1]; 111 | } 112 | else if (smooth_rem) rem = exp(X*beta_rem); 113 | else rem = rem_par; 114 | } else rem = rep_vector(0, nage); 115 | 116 | // Infer age zero prevalence from data if there are any data at age zero, or if we asked it to 117 | for (k in 1:nbias) { 118 | if (prev_denom[1] > 0 && (prev_num[1] > 0 || prev_zero)) 119 | prev_prob[1,k] = prevzero[1]; 120 | else prev_prob[1,k] = 0; 121 | } 122 | 123 | if (increasing_cf) { 124 | // Baseline for eqage (e.g. age 50) is a random effect 125 | for (a in 1:(eqage-1)){ 126 | cf[a] = cfbase[1]; 127 | } 128 | if (!const_cf){ 129 | dcf = exp(X*beta); 130 | } else dcf = rep_vector(0, nage); 131 | for (a in eqage:nage){ 132 | cf[a] = cf[a-1] + dcf[a]; 133 | } 134 | } else { 135 | if (smooth_cf) cf = exp(X*beta); else cf = cf_par; 136 | } 137 | 138 | if (trend) { 139 | // Define year-specific cf, inc, rem as function of year-indep versions 140 | cf = exp(X*beta); 141 | for (b in 1:nyr){ 142 | cf_yr[1:nage, b] = cf .* cf_trend[,b]; 143 | } 144 | for (k in 1:nbias){ 145 | for (b in 1:nyr){ 146 | for (a in 1:nage){ 147 | inc_yr[a, b, k] = inc[a,k] * inc_trend[a,b]; 148 | } 149 | } 150 | // state occupancy at age 0 (a=1) 151 | for (b in 1:nyr) { 152 | state_probs_yr[1,b,k,1] = 1; 153 | state_probs_yr[1,b,k,2] = 0; 154 | state_probs_yr[1,b,k,3] = 0; 155 | // initialise state occupancy at other ages to keep Stan happy that all array elements are initialised 156 | // only the upper diagonal of this (year >= age) is needed 157 | for (a in 2:(nage+1)){ 158 | state_probs_yr[a,b,k,1:3] = rep_row_vector(0, 3); 159 | } 160 | } 161 | } 162 | } else { 163 | for (k in 1:nbias){ 164 | state_probs[1,k,1] = 1; 165 | state_probs[1,k,2] = 0; 166 | state_probs[1,k,3] = 0; 167 | } 168 | } 169 | 170 | for (a in 1:nage){ 171 | if (trend) { 172 | for (k in 1:nbias){ 173 | if (a > 1) { 174 | int y; 175 | for (b in 2:a){ 176 | y = nyr - a + b; // y = nage-a+1 is birth. y = nyr = nage is current year 177 | P = trans_probs(inc_yr[b-1, y-1, k], cf_yr[b-1, y-1], rem[b-1]); 178 | tmp = state_probs_yr[b-1, y-1, k, 1:3] * P; 179 | state_probs_yr[b, y, k, 1:3] = tmp; 180 | } 181 | } 182 | // data are the outcomes at the end of the current year 183 | P = trans_probs(inc_yr[a,nyr,k], cf_yr[a,nyr], rem[a]); 184 | inc_prob[a,k] = bound_prob(P[1,2] + P[1,3]); 185 | prev_prob[a,k] = state_probs_yr[a,nyr,k,2] / 186 | (state_probs_yr[a,nyr,k,1] + state_probs_yr[a,nyr,k,2]); 187 | if (k==1) mort_prob[a] = P[1,3]*(1 - prev_prob[a,1]) + P[2,3]*prev_prob[a,1]; 188 | cf_prob[a] = bound_prob(P[2,3]); 189 | } 190 | } else { 191 | 192 | for (k in 1:nbias){ 193 | P = trans_probs(inc[a,k], cf[a], rem[a]); 194 | inc_prob[a,k] = bound_prob(P[1,2] + P[1,3]); 195 | if (a > 1) 196 | prev_prob[a,k] = state_probs[a,k,2] / (state_probs[a,k,1] + state_probs[a,k,2]); 197 | tmp = state_probs[a,k,1:3] * P; // temp variable to avoid warning 198 | state_probs[a+1,k,1:3] = tmp; 199 | if (k==1) { 200 | mort_prob[a] = P[1,3]*(1 - prev_prob[a,1]) + P[2,3]*prev_prob[a,1]; 201 | cf_prob[a] = bound_prob(P[2,3]); 202 | if (remission) 203 | rem_prob[a] = P[2,1]; 204 | } 205 | } 206 | 207 | } 208 | //// work around floating point fuzz 209 | mort_prob[a] = bound_prob(mort_prob[a]); 210 | } 211 | } 212 | 213 | model { 214 | mort_num ~ binomial(mort_denom, mort_prob); 215 | inc_num ~ binomial(inc_denom, inc_prob[1:nage,incdata_ind]); 216 | prev_num ~ binomial(prev_denom, prev_prob[1:nage,prevdata_ind]); 217 | if (remission) { 218 | rem_num ~ binomial(rem_denom, rem_prob); 219 | } 220 | 221 | if (smooth_cf) { 222 | if (!const_cf) { 223 | for (i in 1:(K-2)) { 224 | beta[i] ~ normal(0, lambda_cf_use); 225 | } 226 | for (i in (K-1):K){ 227 | beta[i] ~ normal(0, 100); 228 | } 229 | } 230 | if (!scf_isfixed) 231 | lambda_cf[1] ~ gamma(2, sprior[2]); 232 | } 233 | else { 234 | for (a in 1:nage){ 235 | cf_par[a] ~ gamma(cf_prior[1], cf_prior[2]); // boundary-avoiding with mode 2 236 | } 237 | } 238 | if (increasing_cf) { 239 | cfbase[1] ~ gamma(cf_prior[1], cf_prior[2]); 240 | } 241 | 242 | if (smooth_inc) { 243 | for (i in 1:(K-2)) { 244 | beta_inc[i] ~ normal(0, lambda_inc_use); 245 | } 246 | for (i in (K-1):K){ 247 | beta_inc[i] ~ normal(0, 100); 248 | } 249 | if (!sinc_isfixed) 250 | lambda_inc[1] ~ gamma(2, sprior[1]); 251 | } 252 | else { 253 | for (a in 1:nage){ 254 | inc_par[a] ~ gamma(inc_prior[1], inc_prior[2]); 255 | } 256 | } 257 | 258 | if (remission) { 259 | if (smooth_rem) { 260 | for (i in 1:(K-2)) { 261 | beta_rem[i] ~ normal(0, lambda_rem_use); 262 | } 263 | for (i in (K-1):K){ 264 | beta_rem[i] ~ normal(0, 100); 265 | } 266 | if (!srem_isfixed) 267 | lambda_rem[1] ~ gamma(2, sprior[3]); 268 | } else if (const_rem) rem_par[1] ~ gamma(rem_prior[1], rem_prior[2]); 269 | else { 270 | for (a in 1:nage){ 271 | rem_par[a] ~ gamma(rem_prior[1], rem_prior[2]); 272 | } 273 | } 274 | } 275 | 276 | if (nbias==2){ 277 | bias_loghr ~ normal(0,1); 278 | } 279 | 280 | if (prev_zero){ 281 | prevzero[1] ~ beta(2,2); // boundary-avoiding 282 | } 283 | 284 | } 285 | 286 | generated quantities { 287 | vector[nage] ll_mort; 288 | vector[nage*inc_supplied] ll_inc; 289 | vector[nage*prev_supplied] ll_prev; 290 | vector[nage*remission] ll_rem; 291 | vector[nage*(1 + inc_supplied + prev_supplied + remission)] ll_overall; 292 | for (a in 1:nage) { 293 | ll_mort[a] = binomial_lpmf(mort_num[a] | mort_denom[a], mort_prob[a]); 294 | if (inc_supplied) 295 | ll_inc[a] = binomial_lpmf(inc_num[a] | inc_denom[a], inc_prob[a]); 296 | if (prev_supplied) 297 | ll_prev[a] = binomial_lpmf(prev_num[a] | prev_denom[a], prev_prob[a]); 298 | if (remission) 299 | ll_rem[a] = binomial_lpmf(rem_num[a] | rem_denom[a], rem_prob[a]); 300 | } 301 | ll_overall = append_row(ll_mort, append_row(ll_inc, append_row(ll_prev, ll_rem))); 302 | } 303 | -------------------------------------------------------------------------------- /inst/stan/disbayes_hier.stan: -------------------------------------------------------------------------------- 1 | #include /include/trans_probs.stan 2 | 3 | // "intercept" model: random intercepts, but identical slopes and deviations from linearity 4 | 5 | data { 6 | int nage; 7 | int narea; 8 | int ng; 9 | int eqage; 10 | int remission; 11 | int prev_zero; 12 | array[nage,narea,ng] int mort_num; 13 | array[nage,narea,ng] int mort_denom; 14 | array[nage,narea,ng] int prev_num; 15 | array[nage,narea,ng] int prev_denom; 16 | array[nage,narea,ng] int inc_num; 17 | array[nage,narea,ng] int inc_denom; 18 | array[nage,narea,ng] int rem_num; 19 | array[nage,narea,ng] int rem_denom; 20 | 21 | int K; // number of spline basis variables including the intercept 22 | matrix[nage,K] X; 23 | array[3] real sprior; 24 | real mipm; 25 | real mips; 26 | real mism; 27 | real miss; 28 | real gpint_a; 29 | real gpint_b; 30 | real gpslope_a; 31 | real gpslope_b; 32 | real gender_int_priorsd; 33 | real gender_slope_priorsd; 34 | 35 | // alternative models 36 | int interceptonly; 37 | int increasing; 38 | int common; 39 | int const_cf; 40 | int const_rem; 41 | int smooth_inc; 42 | int smooth_rem; 43 | 44 | // Empirical Bayes method where random effects hyperparameters are fixed 45 | int sd_int_isfixed; 46 | int sd_slope_isfixed; 47 | real sd_int_fixed; 48 | real sd_slope_fixed; 49 | array[2] real inc_prior; 50 | array[2] real rem_prior; 51 | 52 | // Empirical Bayes method where smoothing parameters are fixed 53 | int scf_isfixed; 54 | int scfmale_isfixed; 55 | int sinc_isfixed; 56 | int srem_isfixed; 57 | real lambda_cf_fixed; 58 | real lambda_cf_male_fixed; 59 | real lambda_inc_fixed; 60 | real lambda_rem_fixed; 61 | } 62 | 63 | parameters { 64 | array[nage*(1 - smooth_inc),narea,ng] real inc_par; 65 | array[remission*(1-smooth_rem)*(nage*(1-const_rem) + 1*const_rem),ng] real rem_par; 66 | 67 | // standard normal terms contributing to area-specific coefficients in non-centered parameterisation. 68 | matrix[(K-2)*(1-const_cf), narea*(1 - common) + 1*(common)] barea; 69 | matrix[(1-interceptonly)*(1 - const_cf), narea*(1 - common) + 1*common] barea_slope; 70 | matrix[1, narea*(1 - common)] barea_inter; 71 | 72 | vector[K*(ng-1)] bmale; // male effect on beta 73 | 74 | // for model with increasing slopes 75 | vector[(narea*(1-common) + 1*common)*increasing] lcfbase; 76 | 77 | array[K*smooth_inc,narea,ng] real beta_inc; 78 | array[K*smooth_rem,narea,ng] real beta_rem; 79 | 80 | real mean_inter; // random effect mean intercept 81 | vector[1-sd_int_isfixed] sd_inter; 82 | vector[1-const_cf] mean_slope; 83 | vector[(1 - const_cf)*(1 - interceptonly)*(1 - increasing)*(1 - sd_slope_isfixed)] sd_slope; // excluded if intercept-only, or increasing, or empirical Bayes 84 | vector[(1-const_cf)*(1-scf_isfixed)] lambda_cf; 85 | vector[(ng-1)*(1-scfmale_isfixed)] lambda_cf_male; 86 | vector[smooth_inc*(1-sinc_isfixed)] lambda_inc; 87 | vector[remission*smooth_rem*(1-srem_isfixed)] lambda_rem; 88 | array[narea*prev_zero,ng] real prevzero; 89 | } 90 | 91 | transformed parameters { 92 | //// range constraints on these cause problems due to floating point fuzz 93 | array[nage,narea,ng] real inc; // independent incidence for each area 94 | array[nage,narea,ng] real cf; 95 | array[nage*increasing,narea,ng] real dcf; // only in increasing model 96 | array[nage,narea,ng] real inc_prob; 97 | array[nage,narea,ng] real prev_prob; 98 | array[nage,narea,ng] real mort_prob; 99 | array[nage,narea,ng] real rem; 100 | array[nage*remission,narea,ng] real rem_prob; 101 | array[nage,narea,ng] real cf_prob; 102 | array[nage+1,narea,ng] row_vector[3] state_probs; 103 | row_vector[3] tmp; 104 | matrix[3,3] P; 105 | real sdint_use; 106 | real sdslope_use; 107 | 108 | matrix[K,narea] bareat; // area-specific coefficients. 109 | array[K,narea,ng] real beta; 110 | real lambda_cf_use; 111 | real lambda_cf_male_use; 112 | real lambda_inc_use; 113 | real lambda_rem_use; 114 | vector[narea*increasing] lcfbase_use; 115 | 116 | if (sd_int_isfixed) sdint_use = sd_int_fixed; else sdint_use = sd_inter[1]; 117 | if (sd_slope_isfixed || const_cf || interceptonly || increasing) sdslope_use = sd_slope_fixed; else sdslope_use = sd_slope[1]; 118 | if (scf_isfixed || const_cf) lambda_cf_use = lambda_cf_fixed; else lambda_cf_use = lambda_cf[1]; 119 | if (scfmale_isfixed || (ng==1)) lambda_cf_male_use = lambda_cf_male_fixed; else lambda_cf_male_use = lambda_cf_male[1]; 120 | if (sinc_isfixed || !smooth_inc) lambda_inc_use = lambda_inc_fixed; else lambda_inc_use = lambda_inc[1]; 121 | if (srem_isfixed || !smooth_rem) lambda_rem_use = lambda_rem_fixed; else lambda_rem_use = lambda_rem[1]; 122 | 123 | for (j in 1:narea){ 124 | if (common) { // no difference between areas. implemented to allow statistical model comparison 125 | if (increasing) { lcfbase_use[j] = lcfbase[1]; } 126 | if (const_cf){ 127 | for (i in 1:(K-1)) { 128 | bareat[i,j] = 0; // constant 129 | } 130 | } else { 131 | for (i in 1:(K-2)){ 132 | bareat[i,j] = barea[i,1] * lambda_cf_use; 133 | } 134 | if (increasing) { // increasing and smooth 135 | bareat[K-1,j] = barea_slope[1,1] * lambda_cf_use; // slope for increments. shrunk. 136 | } else { // unconstrained and smooth 137 | bareat[K-1,j] = mean_slope[1]; 138 | } 139 | } 140 | if (increasing) { 141 | bareat[K,j] = mean_slope[1]; // common slope (ie intercept for increments) 142 | } else { 143 | bareat[K,j] = mean_inter; // area-level random intercept 144 | } 145 | } 146 | 147 | else { // area-specific terms 148 | if (increasing) { lcfbase_use[j] = lcfbase[j]; } 149 | if (const_cf){ 150 | for (i in 1:(K-1)) { 151 | bareat[i,j] = 0; 152 | } 153 | } else { 154 | for (i in 1:(K-2)) { 155 | bareat[i,j] = barea[i,j] * lambda_cf_use; // smoothing terms shared between areas 156 | } 157 | if (interceptonly) { 158 | bareat[K-1,j] = mean_slope[1]; // common slope between areas 159 | } else if (increasing) { 160 | bareat[K-1,j] = barea_slope[1,j] * lambda_cf_use; // slope for increments. shrunk. 161 | } else { // default 162 | bareat[K-1,j] = mean_slope[1] + barea_slope[1,j] * sdslope_use; // area-level random slope 163 | } 164 | } 165 | if (increasing) { 166 | bareat[K,j] = mean_slope[1]; // common slope (ie intercept for increments) 167 | } else{ 168 | bareat[K,j] = mean_inter + barea_inter[1, j] * sdint_use; // area-level random intercept 169 | } 170 | } 171 | 172 | } 173 | 174 | for (g in 1:ng) { 175 | for (j in 1:narea) { 176 | for (a in 1:nage){ 177 | if (smooth_inc) { 178 | inc[a,j,g] = exp(X[a,]*to_vector(beta_inc[,j,g])); 179 | } else { 180 | inc[a,j,g] = inc_par[a,j,g]; 181 | } 182 | } 183 | for (k in 1:K) { 184 | if (ng > 1) { 185 | beta[k,j,g] = bareat[k,j] + bmale[k]*(g-1); // additive gender and area effects 186 | } else { 187 | beta[k,j,g] = bareat[k,j]; 188 | } 189 | } 190 | 191 | // Infer age zero prevalence from data if there are any data at age zero, or if we asked it to 192 | if (prev_denom[1,j,g] > 0 && (prev_num[1,j,g] > 0 || prev_zero)) 193 | prev_prob[1,j,g] = prevzero[j,g]; 194 | else prev_prob[1,j,g] = 0; 195 | state_probs[1,j,g,1] = 1; 196 | state_probs[1,j,g,2] = 0; 197 | state_probs[1,j,g,3] = 0; 198 | 199 | if (increasing){ 200 | /// Annual increments in case fatality as smooth spline function of age 201 | for (a in 1:nage) { 202 | dcf[a,j,g] = exp(X[a,]*to_vector(beta[,j,g])); 203 | } 204 | // Baseline for eqage (e.g. age 50) is a random effect 205 | for (a in 1:(eqage-1)){ 206 | cf[a,j,g] = exp(lcfbase_use[j]); 207 | } 208 | for (a in eqage:nage){ 209 | cf[a,j,g] = cf[a-1,j,g] + dcf[a,j,g]; 210 | } 211 | } 212 | else { 213 | /// Case fatality as smooth spline function of age 214 | /// Spline basis X is 215 | /// nage x K matrix * K colvector = nage vector 216 | for (a in 1:nage){ 217 | cf[a,j,g] = exp(X[a,]*to_vector(beta[,j,g])); 218 | } 219 | } 220 | 221 | if (remission) { 222 | if (smooth_rem) { 223 | for (a in 1:nage){ 224 | rem[a,j,g] = exp(X[a,]*to_vector(beta_rem[,j,g])); 225 | } 226 | } 227 | else if (const_rem) { 228 | for (a in 1:nage) 229 | rem[a,j,g] = rem_par[1,g]; 230 | } else 231 | rem[,j,g] = rem_par[,g]; 232 | } else { for (a in 1:nage) { rem[a,j,g] = 0; } } 233 | for (a in 1:nage){ 234 | P = trans_probs(inc[a,j,g], cf[a,j,g], rem[a,j,g]); 235 | inc_prob[a,j,g] = bound_prob(P[1,2] + P[1,3]); 236 | if (remission) 237 | rem_prob[a,j,g] = P[2,1]; 238 | if (a > 1) 239 | prev_prob[a,j,g] = state_probs[a,j,g,2] / (state_probs[a,j,g,1] + state_probs[a,j,g,2]); 240 | tmp = state_probs[a,j,g,1:3] * P; // temp variable to avoid warning 241 | state_probs[a+1,j,g,1:3] = tmp; 242 | cf_prob[a,j,g] = bound_prob(P[2,3]); 243 | mort_prob[a,j,g] = P[1,3]*(1 - prev_prob[a,j,g]) + P[2,3]*prev_prob[a,j,g]; 244 | //// work around floating point fuzz 245 | mort_prob[a,j,g] = bound_prob(mort_prob[a,j,g]); 246 | mort_prob[a,j,g] = bound_prob(mort_prob[a,j,g]); 247 | } 248 | } 249 | } 250 | } 251 | 252 | model { 253 | mean_inter ~ normal(mipm, mips); 254 | 255 | // These all get transformed in different ways according to the model 256 | if (!const_cf) { 257 | mean_slope ~ normal(mism, miss); 258 | if (common) { 259 | for (i in 1:(K-2)){ 260 | barea[i,1] ~ normal(0, 1); 261 | } 262 | if (!interceptonly && !const_cf){ 263 | barea_slope[1,1] ~ normal(0, 1); 264 | } 265 | } else { 266 | for (j in 1:narea){ 267 | for (i in 1:(K-2)){ 268 | barea[i,j] ~ normal(0, 1); 269 | } 270 | barea_inter[1,j] ~ normal(0, 1); 271 | if (!interceptonly && !const_cf){ 272 | barea_slope[1,j] ~ normal(0, 1); 273 | } 274 | } 275 | } 276 | } 277 | 278 | if (smooth_inc) { 279 | // Random effects model or additive gender effects not used for incidence. 280 | // Just have independent smooth curves for each area 281 | // Common smoothness variance 282 | for (j in 1:narea){ 283 | for (g in 1:ng){ 284 | for (i in 1:(K-2)) { 285 | beta_inc[i,j,g] ~ normal(0, lambda_inc_use); 286 | } 287 | for (i in (K-1):K){ 288 | beta_inc[i,j,g] ~ normal(0, 100); 289 | } 290 | } 291 | } 292 | } 293 | 294 | // Model for the data 295 | if (increasing && common) { 296 | lcfbase[1] ~ normal(0, 100); 297 | } 298 | for (j in 1:narea){ 299 | for (g in 1:ng) { 300 | mort_num[,j,g] ~ binomial(mort_denom[,j,g], mort_prob[,j,g]); 301 | inc_num[,j,g] ~ binomial(inc_denom[,j,g], inc_prob[,j,g]); 302 | prev_num[,j,g] ~ binomial(prev_denom[,j,g], prev_prob[,j,g]); 303 | if (remission) { 304 | rem_num[,j,g] ~ binomial(rem_denom[,j,g], rem_prob[,j,g]); 305 | } 306 | } 307 | if (increasing && !common){ 308 | lcfbase[j] ~ normal(mean_inter, sd_inter); 309 | } 310 | } 311 | if (remission){ 312 | if (smooth_rem) { 313 | for (j in 1:narea){ 314 | for (g in 1:ng){ 315 | for (i in 1:(K-2)) { 316 | beta_rem[i,j,g] ~ normal(0, lambda_rem_use); 317 | } 318 | for (i in (K-1):K){ 319 | beta_rem[i,j,g] ~ normal(0, 100); 320 | } 321 | } 322 | } 323 | } 324 | else if (const_rem) { 325 | for (g in 1:ng) rem_par[1,g] ~ gamma(rem_prior[1], rem_prior[2]); 326 | } else { 327 | for (g in 1:ng) { 328 | for (a in 1:nage) { 329 | rem_par[a,g] ~ gamma(rem_prior[1], rem_prior[2]); 330 | } 331 | } 332 | } 333 | } 334 | 335 | // Degree of smoothness 336 | if (!const_cf && !scf_isfixed){ 337 | lambda_cf ~ gamma(2, sprior[2]); 338 | } 339 | if (smooth_inc && !sinc_isfixed){ 340 | lambda_inc ~ gamma(2, sprior[1]); 341 | } 342 | if (smooth_rem && !srem_isfixed){ 343 | lambda_rem ~ gamma(2, sprior[3]); 344 | } 345 | if ((!interceptonly) && (!increasing) && (!const_cf)){ 346 | // Variation in slopes 347 | sd_slope ~ gamma(gpslope_a, gpslope_b); 348 | } 349 | // Variation in intercepts 350 | sd_inter ~ gamma(gpint_a, gpint_b); 351 | 352 | if (ng > 1) { 353 | if (!const_cf && !scfmale_isfixed){ 354 | lambda_cf_male ~ gamma(2, sprior[2]); 355 | } 356 | // effect of being male, assumed common between areas 357 | //... on spline coefficients governing deviation from linearity 358 | for (i in 1:(K-2)){ 359 | bmale[i] ~ normal(0, lambda_cf_male_use); // smoothness variance par shared 360 | } 361 | // ...on slopes 362 | bmale[K-1] ~ normal(0, gender_slope_priorsd); 363 | // ...on intercepts 364 | bmale[K] ~ normal(0, gender_int_priorsd); 365 | // five fold difference between men and women is log(5)=1.6 on log scale 366 | // want sd such that 95% prob that bmale is between -log(5) and log(5) 367 | // sd = log(5) / qnorm(0.975) = 0.82 368 | } 369 | 370 | if (!smooth_inc){ 371 | for (a in 1:nage){ 372 | for (j in 1:narea){ 373 | for (g in 1:ng){ 374 | inc_par[a,j,g] ~ gamma(inc_prior[1], inc_prior[2]); 375 | } 376 | } 377 | } 378 | } 379 | 380 | if (prev_zero){ 381 | for (j in 1:narea){ 382 | for (g in 1:ng){ 383 | prevzero[j,g] ~ beta(2,2); // boundary-avoiding 384 | } 385 | } 386 | } 387 | } 388 | 389 | generated quantities { 390 | vector[nage*narea*ng] ll_mort; 391 | vector[nage*narea*ng] ll_inc; 392 | vector[nage*narea*ng] ll_prev; 393 | vector[nage*narea*ng*remission] ll_rem; 394 | vector[nage*narea*ng*(3 + remission)] ll_overall; 395 | int i = 1; 396 | for (a in 1:nage) { 397 | for (j in 1:narea) { 398 | for (g in 1:ng) { 399 | ll_mort[i] = binomial_lpmf(mort_num[a,j,g] | mort_denom[a,j,g], mort_prob[a,j,g]); 400 | ll_inc[i] = binomial_lpmf(inc_num[a,j,g] | inc_denom[a,j,g], inc_prob[a,j,g]); 401 | ll_prev[i] = binomial_lpmf(prev_num[a,j,g] | prev_denom[a,j,g], prev_prob[a,j,g]); 402 | if (remission) 403 | ll_rem[i] = binomial_lpmf(rem_num[a,j,g] | rem_denom[a,j,g], rem_prob[a,j,g]); 404 | i = i + 1; 405 | } 406 | } 407 | } 408 | ll_overall = append_row(ll_mort, append_row(ll_inc, append_row(ll_prev, ll_rem))); 409 | } 410 | -------------------------------------------------------------------------------- /inst/stan/include/license.stan: -------------------------------------------------------------------------------- 1 | /* 2 | disbayes is free software: you can redistribute it and/or modify 3 | it under the terms of the GNU General Public License as published by 4 | the Free Software Foundation, either version 3 of the License, or 5 | (at your option) any later version. 6 | 7 | disbayes is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 10 | GNU General Public License for more details. 11 | 12 | You should have received a copy of the GNU General Public License 13 | along with disbayes. If not, see . 14 | */ 15 | -------------------------------------------------------------------------------- /inst/stan/include/trans_probs.stan: -------------------------------------------------------------------------------- 1 | functions { 2 | 3 | // Annual transition probabilities between states 4 | // in terms of intensities that are constant over transition interval [ e.g. year of age ] 5 | // From solution to the Kolmogorov forward equation given in DISMOD2 paper 6 | // 1: healthy; 2: disease; 3: dead from disease 7 | // i: incidence, f: case fatality, r: remission 8 | 9 | matrix trans_probs_rem(real i, real f, real r) { 10 | real l = i + r + f; 11 | real q = sqrt(i*i + 2*i*r - 2*i*f + r*r + 2*f*r + f*f); 12 | real w = exp(-(l + q) / 2); 13 | real v = exp(-(l - q) / 2); 14 | matrix[3,3] P; 15 | P[1,1] = (2*(v-w)*(f+r) + v*(q-l) + w*(q+l)) / (2*q); 16 | P[2,1] = (v-w)*r/q; 17 | P[3,1] = 0; 18 | 19 | P[1,2] = i*(v - w)/q; 20 | P[2,2] = -((2*(f+r) - l)*(v-w) - q*(v+w)) / (2*q); 21 | P[3,2] = 0; 22 | 23 | P[1,3] = (-l*(v-w) - q*(v+w))/(2*q) + 1; 24 | P[2,3] = ((v-w)*(2*f - l) - q*(v+w))/(2*q) + 1; 25 | P[3,3] = 1; 26 | return P; 27 | } 28 | 29 | matrix trans_probs_norem_if(real i, real f) { 30 | real l = i + f; 31 | real q = sqrt(i*i - 2*i*f + f*f); 32 | real w = exp(-(l + q) / 2); 33 | real v = exp(-(l - q) / 2); 34 | matrix[3,3] P; 35 | P[1,1] = (2*(v-w)*f + v*(q-l) + w*(q+l)) / (2*q); 36 | P[2,1] = 0; 37 | P[3,1] = 0; 38 | 39 | P[1,2] = i*(v - w)/q; 40 | P[2,2] = -((2*f - l)*(v-w) - q*(v+w)) / (2*q); 41 | P[3,2] = 0; 42 | 43 | P[1,3] = (-l*(v-w) - q*(v+w))/(2*q) + 1; 44 | P[2,3] = ((v-w)*(2*f - l) - q*(v+w))/(2*q) + 1; 45 | P[3,3] = 1; 46 | return P; 47 | } 48 | 49 | matrix trans_probs_norem_i(real i) { 50 | matrix[3,3] P; 51 | P[1,1] = exp(-i); 52 | P[1,2] = i*exp(-i); 53 | P[1,3] = -exp(-i) + 1 - i*exp(-i); 54 | 55 | P[2,1] = 0; 56 | P[2,2] = exp(-i); 57 | P[2,3] = 1- exp(-i); 58 | 59 | P[3,1] = 0; 60 | P[3,2] = 0; 61 | P[3,3] = 1; 62 | return P; 63 | } 64 | 65 | matrix defuzz_P(matrix P){ 66 | matrix[3,3] Pr; 67 | for (r in 1:3) { 68 | for (s in 1:3) { 69 | Pr[r,s] = P[r,s]; 70 | if (P[r,s] < 0) Pr[r,s] = 0; 71 | if (P[r,s] > 1) Pr[r,s] = 1; 72 | } 73 | } 74 | return Pr; 75 | } 76 | 77 | matrix trans_probs(real i, real f, real r) { 78 | matrix[3,3] P; 79 | if (r != 0) 80 | P = trans_probs_rem(i, f, r); 81 | else { 82 | if (i == f) 83 | P = trans_probs_norem_i(i); 84 | else 85 | P = trans_probs_norem_if(i, f); 86 | } 87 | return defuzz_P(P); 88 | } 89 | 90 | real bound_prob(real x){ 91 | real ret; 92 | if (x >= 1) { 93 | ret = 1 - machine_precision(); 94 | } else if (x <= 0) { 95 | ret = machine_precision(); 96 | } else { ret = x; } 97 | return x; 98 | } 99 | 100 | } 101 | -------------------------------------------------------------------------------- /man/ci2num.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ci2num.R 3 | \name{ci2num} 4 | \alias{ci2num} 5 | \title{Convert a proportion and credible interval to a numerator and denominator} 6 | \usage{ 7 | ci2num(est, lower, upper, epsilon = 0.5, denom0 = 1000) 8 | } 9 | \arguments{ 10 | \item{est}{Point estimate} 11 | 12 | \item{lower}{Lower 95\% credible limit} 13 | 14 | \item{upper}{Upper 95\% credible limit} 15 | 16 | \item{epsilon}{If any of \code{lower} are zero, then they are replaced by the minimum of \code{epsilon} and \code{est/2}. Similarly values of 1 for \code{upper} are replaced by the maximum of \code{1-epsilon} and \code{(1+est)/2}.} 17 | 18 | \item{denom0}{Denominator to use as a default when the point estimate is exactly 0 or 1 (which is not compatible with the beta distribution). Should correspond to a guess of the population size used to produce the estimate, 19 | which should be no greater than the actual population of the area, and usually less. Should be either a scalar, or a vector of the same length as \code{est} (though note if it is a vector, then only the elements where \code{est} is 1 or 0 get used).} 20 | } 21 | \value{ 22 | A data frame with elements \code{num} and \code{denom} corresponding to the supplied estimate and limits. 23 | } 24 | \description{ 25 | Estimate the number of events and denominator that contain roughly equivalent information to an estimate and uncertainty interval for a proportion, by interpreting the estimate and interval as a Beta posterior arising from a vague Beta(0.5,0.5) prior updated with the data consisting of that number and denominator. 26 | } 27 | \details{ 28 | Based on fitting a Beta distribution by least squares, using the method provided by the \pkg{SHELF} package. 29 | 30 | Requires that the estimate and upper and lower limits are all distinct (except that \code{est=0} is allowed and handled specially for convenience, see \code{denom0}). Vectors of estimates and limits may be supplied. 31 | } 32 | \examples{ 33 | est <- 3.00 / 100 34 | upper <- 3.52 / 100 35 | lower <- 2.60 / 100 36 | ci2num(est, lower, upper) 37 | 38 | } 39 | \references{ 40 | Oakley (2020). SHELF: Tools to Support the Sheffield Elicitation Framework. R package version 1.7.0. \url{https://CRAN.R-project.org/package=SHELF} 41 | } 42 | -------------------------------------------------------------------------------- /man/conflict_disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fit.R 3 | \name{conflict_disbayes} 4 | \alias{conflict_disbayes} 5 | \title{Conflict p-values} 6 | \usage{ 7 | conflict_disbayes(x, varname) 8 | } 9 | \arguments{ 10 | \item{x}{A fitted \code{\link{disbayes}} model.} 11 | 12 | \item{varname}{Either \code{inc}, \code{prev}, \code{mort} or \code{rem}.} 13 | } 14 | \value{ 15 | A data frame with columns indicating age, gender and area. 16 | 17 | \code{p1} is a "one-sided" p-value for the null hypothesis that \eqn{r_{obs}=r_{fit}} against 18 | the alternative that \eqn{r_{obs} > r_{fit}}, 19 | 20 | \code{p2} is the two-sided p-value for the null hypothesis that \eqn{r_{obs}=r_{fit}} against 21 | the alternative that \eqn{r_{obs}} is not equal to \eqn{r_{fit}}, 22 | 23 | where \eqn{r_{obs}} is the rate informed only by direct data, and \eqn{r_{fit}} is the rate 24 | informed by evidence synthesis. Therefore if the evidence synthesis excludes the 25 | direct data, then these are interpreted as "conflict" p-values (see Presanis et al. 2013). 26 | 27 | In each case, a small p-value favours the alternative hypothesis. 28 | } 29 | \description{ 30 | A test of the hypothesis that the direct data on a disease outcome give the same 31 | information about that outcome as an indirect evidence synthesis obtained from a fitted \code{\link{disbayes}} 32 | model. The outcome may be annual incidence, mortality, remission probabilities, 33 | or prevalence. 34 | } 35 | \details{ 36 | Hierarchical models are not currently supported in this function. 37 | } 38 | \references{ 39 | Presanis, A. M., Ohlssen, D., Spiegelhalter, D. J. and De Angelis, D. (2013) 40 | Conflict diagnostics in directed acyclic graphs, with applications in Bayesian evidence 41 | synthesis. Statistical Science, 28, 376-397. 42 | } 43 | -------------------------------------------------------------------------------- /man/disbayes-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes-package.R 3 | \docType{package} 4 | \name{disbayes-package} 5 | \alias{disbayes-package} 6 | \title{The 'disbayes' package.} 7 | \description{ 8 | Bayesian evidence synthesis for chronic disease epidemiology 9 | } 10 | \references{ 11 | Stan Development Team (2019). RStan: the R interface to Stan. R package version 2.19.2. https://mc-stan.org 12 | } 13 | -------------------------------------------------------------------------------- /man/ihdengland.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes-package.R 3 | \docType{data} 4 | \name{ihdengland} 5 | \alias{ihdengland} 6 | \title{Ischemic heart disease in England} 7 | \format{ 8 | A data frame with columns: 9 | 10 | \code{sex}: \code{"male"} or \code{"female"}. 11 | 12 | \code{ageyr}. Year of age. 13 | 14 | \code{location}. Name of the location, which is either a city region or region in England. 15 | 16 | \code{num_mort}. Numerator behind the estimate of mortality 17 | 18 | \code{num_inc}. Numerator behind the estimate of incidence 19 | 20 | \code{num_prev}. Numerator behind the estimate of prevalence 21 | 22 | \code{denom_mort}. Denominator behind the estimate of mortality 23 | 24 | \code{denom_inc}. Denominator behind the estimate of incidence 25 | 26 | \code{denom_prev}. Denominator behind the estimate of prevalence 27 | } 28 | \source{ 29 | Global Burden of Disease, 2017 30 | } 31 | \usage{ 32 | ihdengland 33 | } 34 | \description{ 35 | Ischemic heart disease in England 36 | } 37 | \details{ 38 | The data were processed to 39 | 40 | * change the geography to refer to England city regions and the remaining English regions, 41 | 42 | * change counts by 5-year age groups to estimated 1-year counts, 43 | 44 | * obtain estimated numerators and denominators from the published point estimates and uncertainty intervals. 45 | A point estimate of the risk is equivalent to the numerator divided by the denominator. The denominator is 46 | related to the extent of uncertainty around this estimate, and obtained using the Bayesian method 47 | implemented in \code{\link{ci2num}}. 48 | 49 | The script given in \url{https://github.com/chjackson/disbayes/blob/master/data-raw/gbd_process.Rmd} shows 50 | these steps. 51 | } 52 | \references{ 53 | Jackson C, Zapata-Diomedi B, Woodcock J. "Bayesian multistate modelling of incomplete chronic disease burden data" \url{https://arxiv.org/abs/2111.14100}. 54 | } 55 | \keyword{datasets} 56 | -------------------------------------------------------------------------------- /man/ihdtrends.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes-package.R 3 | \docType{data} 4 | \name{ihdtrends} 5 | \alias{ihdtrends} 6 | \title{Trends in ischemic heart disease in England} 7 | \format{ 8 | A data frame with columns: 9 | 10 | \code{gender}: \code{"male"} or \code{"female"}. 11 | 12 | \code{age}: Year of age. 13 | 14 | \code{year}: Calendar year. 15 | 16 | \code{p2017}: Estimated ratio between the outcome in the calendar 17 | year and the outcome in 2017. 18 | 19 | \code{outcome}: Outcome referred to (incidence or case fatality). 20 | } 21 | \source{ 22 | Scarborough, P., Wickramasinghe, K., Bhatnagar, P. and Rayner, M. (2011) Trends in coronary heart disease, 1961-2001. British Heart Foundation. 23 | 24 | Smolina, K., Wright, F. L., Rayner, M. and Goldacre, M. J. (2012) Determinants of the decline in mortality from acute myocardial infarction in England between 2002 and 2010: linked national database study. BMJ, 344. 25 | 26 | British Heart Foundation (2020) Heart and Circulatory Disease Statistics 2020. British Heart Foundation. 27 | } 28 | \usage{ 29 | ihdtrends 30 | } 31 | \description{ 32 | Trends in ischemic heart disease in England 33 | } 34 | \details{ 35 | The data were interpolated and smoothed to produce a matrix by year of age and 36 | calendar year, using the script at \url{https://github.com/chjackson/disbayes/blob/master/data-raw/trends.r}. 37 | } 38 | \keyword{datasets} 39 | -------------------------------------------------------------------------------- /man/loo.disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/loo.R 3 | \name{loo.disbayes} 4 | \alias{loo.disbayes} 5 | \title{Leave-one-out cross validation for disbayes models} 6 | \usage{ 7 | \method{loo}{disbayes}(x, outcome = "overall", ...) 8 | } 9 | \arguments{ 10 | \item{x}{A model fitted by \code{\link{disbayes}}. Any of the computation methods 11 | are supported.} 12 | 13 | \item{outcome}{Either \code{"overall"}, to assess the fit to all data, or 14 | one of \code{"inc"}, \code{"prev"}, \code{"mort"} or \code{"rem"}, to assess the fit 15 | to the incidence data, prevalence data, mortalidy data or remission data, respectively.} 16 | 17 | \item{...}{Other arguments (currently unused).} 18 | } 19 | \value{ 20 | An object of class \code{"loo"} as defined by the \pkg{loo} package. 21 | } 22 | \description{ 23 | Leave-one-out cross validation for disbayes models 24 | } 25 | \seealso{ 26 | \code{\link{loo_indiv}} to return tidied observation-specific contributions 27 | to the overall model fit computed here. 28 | } 29 | -------------------------------------------------------------------------------- /man/loo_indiv.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/loo.R 3 | \name{loo_indiv} 4 | \alias{loo_indiv} 5 | \alias{looi_disbayes} 6 | \title{Extract observation-specific contributions from a disbayes leave-one-out cross validation} 7 | \usage{ 8 | loo_indiv(x, agg = FALSE) 9 | 10 | looi_disbayes(x, agg = FALSE) 11 | } 12 | \arguments{ 13 | \item{x}{For \code{loo_indiv}, an object returned by \code{\link{loo.disbayes}}. For \code{looi_disbayes}, an object returned by \code{\link{disbayes}}.} 14 | 15 | \item{agg}{If \code{TRUE} then the observation-specific contributions are aggregated over 16 | outcome type, returning a data frame with one row for each of incidence, prevalence, mortality 17 | and remission (if remission is included in the model), and one column for each of \code{"elpd_loo"}, 18 | \code{"p_loo"} and \code{"looic"}.} 19 | } 20 | \value{ 21 | A data frame with one row per observed age-specific mortality, incidence, prevalence and/or 22 | remission age-specific data-point, containing leave-one-out cross validation statistics representing how 23 | well the model would predict that observation if it were left out of the fit. 24 | 25 | These are computed with the \pkg{loo} package. 26 | 27 | \code{loo_indiv} acts on the objects that are returned by running \code{\link{loo}} on \code{\link{disbayes}} 28 | objects. \code{\link{looi_disbayes}} acts directly on \code{\link{disbayes}} 29 | objects. Both of those functions return a data frame with LOO contributions for each data point. 30 | } 31 | \description{ 32 | Extract observation-specific contributions from a disbayes leave-one-out cross validation 33 | } 34 | \section{Functions}{ 35 | \itemize{ 36 | \item \code{looi_disbayes()}: Observation-level leave-one-out cross validation statistics for a disbayes model 37 | 38 | }} 39 | -------------------------------------------------------------------------------- /man/plot.disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes.R 3 | \name{plot.disbayes} 4 | \alias{plot.disbayes} 5 | \title{Quick and dirty plot of estimates from disbayes models against age} 6 | \usage{ 7 | \method{plot}{disbayes}(x, variable = "cf", ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object returned by \code{\link{disbayes}}} 11 | 12 | \item{variable}{Name of the variable of interest to plot against age, by default case fatality rates.} 13 | 14 | \item{...}{Other arguments. Currently unused} 15 | } 16 | \value{ 17 | A \code{ggplot2} object that can be printed to show the plot, or customised by adding \code{geom}s. 18 | 19 | Better plots can be drawn by \code{tidy}ing the object returned by \code{disbayes}, and using \code{ggplot2} directly on the tidy data frame that this produces. See the vignette for examples. 20 | } 21 | \description{ 22 | Posterior medians and 95% credible intervals for a quantity of interest are plotted against year of age. 23 | } 24 | -------------------------------------------------------------------------------- /man/plot.disbayes_hier.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes_hier.R 3 | \name{plot.disbayes_hier} 4 | \alias{plot.disbayes_hier} 5 | \title{Quick plot of estimates from hierarchical disbayes models against age} 6 | \usage{ 7 | \method{plot}{disbayes_hier}(x, variable = "cf", ci = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{x}{Object returned by \code{\link{disbayes_hier}}} 11 | 12 | \item{variable}{Name of the variable of interest to plot against age, by default case fatality rates.} 13 | 14 | \item{ci}{Show 95\% credible intervals with ribbons.} 15 | 16 | \item{...}{Other arguments. Currently unused} 17 | } 18 | \value{ 19 | A \code{ggplot2} object that can be printed to show the plot, or 20 | customised by adding \code{geom}s. 21 | 22 | Better plots can be drawn by \code{tidy}ing the object returned by \code{disbayes}, and using \code{ggplot2} directly on the tidy data frame that this produces. See the vignette for examples. 23 | } 24 | \description{ 25 | Posterior medians and 95\% credible intervals for a quantity of interest are plotted against year of age. 26 | } 27 | -------------------------------------------------------------------------------- /man/plotfit_data_disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fit.R 3 | \name{plotfit_data_disbayes} 4 | \alias{plotfit_data_disbayes} 5 | \title{Create tidy data for a check of observed against fitted outcome probability estimates 6 | from disbayes} 7 | \usage{ 8 | plotfit_data_disbayes(x) 9 | } 10 | \arguments{ 11 | \item{x}{Fitted model from \code{\link{disbayes}}} 12 | } 13 | \value{ 14 | A data frame containing observed data in the form of outcome probabilities, as extracted by \code{\link{tidy_obsdat}}, and estimates of the corresponding probability parameters from the fitted model. 15 | } 16 | \description{ 17 | Create tidy data for a check of observed against fitted outcome probability estimates 18 | from disbayes 19 | } 20 | -------------------------------------------------------------------------------- /man/plotfit_disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fit.R 3 | \name{plotfit_disbayes} 4 | \alias{plotfit_disbayes} 5 | \title{Graphical check of observed against fitted outcome probabilities from disbayes} 6 | \usage{ 7 | plotfit_disbayes(x, agemin = 50) 8 | } 9 | \arguments{ 10 | \item{x}{Fitted model from \code{\link{disbayes}}} 11 | 12 | \item{agemin}{Minimum age to show on the horizontal axis.} 13 | } 14 | \value{ 15 | A \code{ggplot2} object containing the plot. 16 | } 17 | \description{ 18 | The data behind the plot can be produced using \code{\link{plotfit_data_disbayes}}, 19 | to enable customised plots to be produced by hand with \code{ggplot2}. 20 | } 21 | -------------------------------------------------------------------------------- /man/reexports.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/disbayes-package.R 3 | \docType{import} 4 | \name{reexports} 5 | \alias{reexports} 6 | \alias{tidy} 7 | \alias{loo} 8 | \title{Objects exported from other packages} 9 | \keyword{internal} 10 | \description{ 11 | These objects are imported from other packages. Follow the links 12 | below to see their documentation. 13 | 14 | \describe{ 15 | \item{generics}{\code{\link[generics]{tidy}}} 16 | 17 | \item{loo}{\code{\link[loo]{loo}}} 18 | }} 19 | 20 | -------------------------------------------------------------------------------- /man/tidy.disbayes.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/tidy.R 3 | \name{tidy.disbayes} 4 | \alias{tidy.disbayes} 5 | \alias{tidy.disbayes_hier} 6 | \title{Form a tidy data frame from the estimates from a disbayes fit} 7 | \usage{ 8 | \method{tidy}{disbayes}(x, startyear = 1, ...) 9 | 10 | \method{tidy}{disbayes_hier}(x, ...) 11 | } 12 | \arguments{ 13 | \item{x}{Object returned by \code{\link{disbayes}}} 14 | 15 | \item{startyear}{Only used for models with time trends. Numeric year represented by year 1 in the data. For example, set this to 1918 to convert years 1-100 to years 1918-2017.} 16 | 17 | \item{...}{Other arguments (currently unused)} 18 | } 19 | \value{ 20 | A data frame with one row per model parameter, giving summary statistics 21 | for the posterior distribution for that parameter. For array parameters, e.g. those 22 | that depend on age or area, then the age and area are returned in separate columns, 23 | to make it easier to summarise and plot the results, e.g. using \pkg{ggplot2}. 24 | 25 | Model parameters might include, depending on the model specification, 26 | \itemize{ 27 | \item \code{cf}, \code{inc}, \code{rem}: Case fatality, incidence, remission rates 28 | \item \code{inc_prob}, \code{rem_prob}, \code{mort_prob}, \code{cf_prob}: Annual incidence, remission, mortality and case fatality risks (probabilities). 29 | \item \code{prev_prob} Prevalence (probability). 30 | \item \code{state_probs} State occupancy probabilities. 31 | \item \code{beta}, \code{beta_inc} Coefficients of the spline basis for case fatality and incidence respectively. 32 | \item \code{lambda_cf}, \code{lambda_inc} Smoothness parameters of the spline functions. 33 | \item \code{prevzero} Prevalence at age zero 34 | \item \code{cfbase} Case fatality at the baseline age (only in models where case fatality is increasing). 35 | \item \code{dcf} Annual increments in case fatality (only in models where case fatality is increasing). 36 | \item \code{bias_loghr} Log hazard ratio describing bias in case fatality between datasets (only in models where \code{bias_model} has been set). 37 | } 38 | 39 | For models with time trends: 40 | \itemize{ 41 | \item \code{cf_yr}, \code{inc_yr}, \code{state_probs_yr} Case fatality rates, incidence rates and state occupancy probabilities in years prior to the current year. \code{cf} and \code{inc} refer to the rates for the current year, the one represented in the data. 42 | } 43 | 44 | Only for hierarchical models: 45 | \itemize{ 46 | \item \code{mean_inter}, \code{mean_slope},\code{sd_inter},\code{sd_slope}. Mean and standard deviation for random effects distribution for the intercept and slope of log case fatality. 47 | \item \code{lambda_cf_male}, \code{lambda_inc_male}. Smoothness of the additive gender effect on case fatality and incidence. 48 | \item \code{bareat} Area-level contribution to spline basis coefficients. 49 | \item \code{barea} Normalised spline basis coefficients. 50 | } 51 | } 52 | \description{ 53 | Simply call this after fitting disbayes, as, e.g. 54 | 55 | \if{html}{\out{
}}\preformatted{res <- disbayes(...) 56 | tidy(res) 57 | }\if{html}{\out{
}} 58 | } 59 | \section{Functions}{ 60 | \itemize{ 61 | \item \code{tidy(disbayes_hier)}: Tidy method for hierarchical disbayes models 62 | 63 | }} 64 | -------------------------------------------------------------------------------- /man/tidy_obsdat.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/fit.R 3 | \name{tidy_obsdat} 4 | \alias{tidy_obsdat} 5 | \title{Extract observed data from a disbayes model fit} 6 | \usage{ 7 | tidy_obsdat(x) 8 | } 9 | \arguments{ 10 | \item{x}{Fitted \code{\link{disbayes}} model} 11 | } 12 | \value{ 13 | A data frame with columns \code{num} and \code{denom} giving the incidence, prevalence and mortality (and remission if used) numerators and denominators used in the model fit. The column \code{var} indicates which of incidence, prevalence etc. the numbers refer to. The column \code{prob} is derived as \code{num} divided by \code{denom}. Columns \code{lower} and \code{upper} define credible intervals for the "data-based" point estimate \code{prob}, obtained from the Beta posterior assuming a Beta(0.5, 0.5) prior. 14 | 15 | This "data-based" point estimate can be compared with estimates from the model using the functions \code{\link{plotfit_data_disbayes}} and \code{\link{plotfit_disbayes}}. 16 | } 17 | \description{ 18 | Extract observed data from a disbayes model fit 19 | } 20 | -------------------------------------------------------------------------------- /metahit/.gitignore: -------------------------------------------------------------------------------- 1 | hpc_results_hier/ 2 | hpc_results_hier_gender/ 3 | results_hier/ 4 | results_nonhier/ 5 | results_hier_gender/ 6 | results_hier_noinc/ 7 | results_nonhier_noinc/ 8 | results_trend/ 9 | gbddb*.rds 10 | resall.rda 11 | metahit-hpc-log.txt 12 | resopt* 13 | res_trend* 14 | res_checkfit* 15 | hpc.sh 16 | DataPrepDisbayesEngland.Rmd 17 | -------------------------------------------------------------------------------- /metahit/README.md: -------------------------------------------------------------------------------- 1 | # Analysis scripts for the paper "Bayesian multistate modelling of incomplete chronic disease burden data" 2 | 3 | 4 | ## Data preparation scripts 5 | 6 | * `gbd_process_2019.Rmd`: Processes data downloaded from the Global Burden of Disease, and produces a data frame that is saved in the object `gbddb.rds`. This is the dataset used in the analyses in the paper. This refers to outcomes for multiple diseases, for different areas (city regions and regions) in England. The dataset `ihdengland` in the `disbayes` package is the subset of this data corresponding to outcomes for ischemic heart disease. 7 | 8 | * `trends2019.r`: Processes published data on past trends through time in incidence and case fatality for myocardial infarction in England. Produces the dataset `ihdtrends`, available in the file `ihdtrends2019.rda`. 9 | 10 | 11 | ## Model fitting scripts 12 | 13 | R scripts to fit Bayesian multi-state models using `disbayes` to the Global Burden of Disease data. 14 | 15 | * `paper_analyses_header.r` : Constants and definitions that apply to all analysis scripts 16 | 17 | These scripts are used to estimate models by full MCMC sampling. Models for different cases (e.g. diseases, areas) are fitted in parallel on a compute cluster, using the SLURM scheduler. 18 | 19 | * `paper_analyses_nonhier.r` : Models with areas (and genders) treated independently, i.e. non-hierarchical models. 20 | 21 | * `paper_analyses_national.r`: Models for less common diseases, fitted to data on the whole of England combined. 22 | 23 | * `paper_analyses_hier.r` : Models with case fatality for different areas related through a hierarchical model, but with men and women treated separately. 24 | 25 | * `paper_analyses_gender.r`: Models with case fatality for different areas related through a hierarchical model, and with a common effect of gender across areas. 26 | 27 | * `paper_analyses_pointests.r`: Analyses based on optimisation rather than MCMC estimation. Includes models with time trends, and models including/excluding incidence data. Also includes code to generate graphs for these models. 28 | 29 | * `slurm_bsu.sh` Example of a SLURM shell script used to call one of the `paper_analyses_` R scripts in SLURM array mode. The analyses are defined in data frames in `paper_analyses_header.r`, e.g. `rundf` for the non-hierarchical, independent areas model. Each row of the data frame corresponds to the same model fitted to a different dataset. The SLURM script iterates over this data frame, performing each model fit on a different compute node. 30 | 31 | * `read_model_results.r`: Reads results from the `paper_analyses` scripts above, and collates them into a tidy data frame, called `resall.rds`. 32 | 33 | 34 | ## Plots of data and plots and summaries of analysis results 35 | 36 | Includes code to generate figures for the paper, for all models fitted by MCMC. 37 | 38 | * `paper_analyses.Rmd` 39 | -------------------------------------------------------------------------------- /metahit/ihdtrends2019.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/metahit/ihdtrends2019.rda -------------------------------------------------------------------------------- /metahit/ihdtrends2019.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/metahit/ihdtrends2019.rds -------------------------------------------------------------------------------- /metahit/metahit.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 4 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackagePath: ~/OneDrive - University of Cambridge/work/chronic/disbayes 18 | PackageInstallArgs: --no-multiarch --with-keep.source 19 | PackageRoxygenize: rd,collate,namespace 20 | -------------------------------------------------------------------------------- /metahit/paper_analyses_gender.r: -------------------------------------------------------------------------------- 1 | 2 | source("paper_analyses_header.r") 3 | nchains <- 2 4 | options(mc.cores = nchains) 5 | 6 | task_id <- as.numeric(Sys.getenv("SLURM_ARRAY_TASK_ID")) 7 | runs_todo <- 1:nrow(hierrungdf) 8 | i <- runs_todo[task_id] 9 | 10 | if (0){ 11 | setwd("metahit") 12 | source("paper_analyses_header.r") 13 | i <- 1 14 | nchains <- 1 15 | foo <- tidy(db) 16 | db$modes 17 | foo %>% filter(grepl("lam",var)) 18 | } 19 | 20 | mhi <- gbd %>% 21 | filter(disease==hierrungdf$disease[i]) %>% 22 | droplevels 23 | hpfixed <- if (hierrungdf$model[i]=="const") NULL else list(scf=2.5, sinc=5, scfmale=1) 24 | ## mode of scfmale is 1.3, so 1 ensures no less smooth 25 | 26 | db <- disbayes_hier(data=mhi, 27 | group = "area", 28 | gender = "gender", 29 | inc_num = "inc_num", inc_denom = "inc_denom", 30 | mort_num = "mort_num", mort_denom = "mort_denom", 31 | prev_num = "prev_num", prev_denom = "prev_denom", 32 | rem_num = if (hierrungdf$remission[i]) "rem_num" else NULL, 33 | rem_denom = if (hierrungdf$remission[i]) "rem_denom" else NULL, 34 | cf_model = hierrungdf$model[i], 35 | inc_model = "smooth", 36 | rem_model = if (hierrundf$remission[i]) "smooth" else NULL, 37 | hp_fixed = hpfixed, 38 | eqage = hierrungdf$eqage[i], 39 | nfold_int_guess = 5, nfold_int_upper = 50, 40 | nfold_slope_guess = 2, nfold_slope_upper = 20, 41 | #method="opt", hessian=TRUE, draws=1000, iter=10000, verbose=TRUE 42 | method="mcmc", refresh = 1, chains=nchains, iter=1000, 43 | #stan_control=list(max_treedepth=15) 44 | ) 45 | 46 | 47 | if (0){ 48 | ds <- sqrt(diag(-db$fit$hessian)) 49 | sort(ds)[1:10] 50 | evals <- eigen(-db$fit$hessian)$values 51 | names(ds)[evals < 0] 52 | sqrt(diag(solve(-db$fit$hessian))) 53 | 54 | library(bayesplot) 55 | mcmc_trace(db$fit,pars=c("sd_inter"), 56 | np = nuts_params(db$fit)) 57 | pairs(db$fit, pars=c("sd_inter","sd_slope[1]")) 58 | color_scheme_set("darkgray") 59 | mcmc_parcoord(db$fit, np = nuts_params(db$fit), pars=c("sd_inter","sd_slope[1]")) 60 | } 61 | 62 | res <- tidy(db) %>% 63 | mutate(disease=hierrungdf$disease[i]) 64 | 65 | loo <- looi_disbayes(db) %>% 66 | mutate(disease=hierrungdf$disease[i]) 67 | 68 | saveRDS(list(res=res,loo=loo), file= paste0("results_hier_gender/res", i, ".rds")) 69 | cat(sprintf("Completed case %s\n", i), file="metahit-hpc-log.txt", append=TRUE) 70 | -------------------------------------------------------------------------------- /metahit/paper_analyses_header.r: -------------------------------------------------------------------------------- 1 | library(tidyverse) 2 | library(broom) 3 | library(rstan) 4 | library("disbayes") 5 | 6 | ## Processed version of GBD data, produced as the final output of dataprep.Rmd 7 | gbd <- readRDS("~/work/chronic/disbayes/metahit/gbddb.rds") 8 | 9 | nage <- 100 10 | areas <- unique(as.character(gbd$area)) 11 | cityregions <- unique(as.character(gbd$area)[gbd$areatype=="cityregion"]) 12 | genders <- unique(as.character(gbd$gender)) 13 | diseases_male <- c("Ischemic heart disease", "Stroke", "Tracheal, bronchus, and lung cancer", 14 | "Colon and rectum cancer","Alzheimer's disease and other dementias", 15 | "Chronic obstructive pulmonary disease", 16 | "Diabetes mellitus type 2", 17 | "Parkinson's disease", 18 | "Stomach cancer", 19 | "Liver cancer", 20 | "Cardiomyopathy and myocarditis", 21 | "Non-rheumatic valvular heart disease", 22 | "Multiple myeloma") 23 | 24 | ## Restricting to diseases with more than 1000 deaths in England 25 | ## Excludes rheumatic heart disease and head and neck cancer 26 | 27 | diseases_female <- c(diseases_male, "Breast cancer","Uterine cancer") 28 | diseases <- unique(c(diseases_male, diseases_female)) 29 | cancers <- c("Tracheal, bronchus, and lung cancer", "Colon and rectum cancer", "Stomach cancer", 30 | "Breast cancer", "Uterine cancer","Multiple myeloma", "Liver cancer") 31 | 32 | #dcodes <- data.frame(disease=diseases, 33 | # dcode = c("ihd","stroke","tbalc","carc","adaod","copd","stmc","brc","utrc")) 34 | # greatest cause-specific mortality 35 | # six with the greatest cause-specific mortality (ihd, str, lc ,copd, carc, bc) 36 | # plus dementia and 37 | # pd,, nrv, dm have greater mortality 38 | 39 | gbdeng <- gbd %>% select(-areatype) %>% 40 | group_by(age, gender, disease) %>% # should contain all English city regions and mutually exclusive regions 41 | summarise(mort_num=sum(mort_num), inc_num=sum(inc_num), 42 | prev_num=sum(prev_num), rem_num=sum(rem_num), 43 | mort_denom=sum(mort_denom), inc_denom=sum(inc_denom), 44 | prev_denom=sum(prev_denom), rem_denom=sum(rem_denom), 45 | .groups = "drop") 46 | 47 | disease_order <- c("Ischemic heart disease", "Stroke", "Dementia", 48 | "COPD", "Breast cancer", "Lung cancer", 49 | "Colon and rectum cancer","Stomach cancer", 50 | "Uterine cancer") 51 | disease_order <- c("Ischemic heart disease", "Stroke", "Dementia", 52 | "Cardiomyopathy and myocarditis", 53 | "Non-rheumatic valvular heart disease", 54 | "COPD", 55 | "Type 2 diabetes", 56 | "Parkinson's disease", 57 | "Breast cancer", "Lung cancer", 58 | "Colon and rectum cancer","Stomach cancer", 59 | "Uterine cancer", "Liver cancer", "Multiple myeloma", 60 | "Head and neck cancer", "Rheumatic heart disease" 61 | ) 62 | 63 | disease_shorten <- c("Dementia" = "Alzheimer's disease and other dementias", 64 | "Lung cancer" = "Tracheal, bronchus, and lung cancer", 65 | "COPD" = "Chronic obstructive pulmonary disease", 66 | "Type 2 diabetes" = "Diabetes mellitus type 2" 67 | ) 68 | 69 | diseases_paper <- c("Ischemic heart disease", "Stroke", "Alzheimer's disease and other dementias", 70 | "Chronic obstructive pulmonary disease", "Breast cancer", 71 | "Tracheal, bronchus, and lung cancer", 72 | "Colon and rectum cancer", "Stomach cancer", "Uterine cancer") 73 | diseases_paper_short <- c("Ischemic heart disease", "Stroke", "Dementia", 74 | "COPD", "Breast cancer", 75 | "Lung cancer", 76 | "Colon and rectum cancer", "Stomach cancer", "Uterine cancer") 77 | 78 | gbdplot <- gbd %>% 79 | filter(disease %in% diseases, 80 | area %in% cityregions) %>% 81 | mutate(mort_prob = mort_num/mort_denom, 82 | mort_lower = qbeta(0.025, mort_num+0.5, mort_denom-mort_num+0.5), 83 | mort_upper = qbeta(0.975, mort_num+0.5, mort_denom-mort_num+0.5), 84 | prev_prob = prev_num/prev_denom, 85 | prev_lower = qbeta(0.025, prev_num+0.5, prev_denom-prev_num+0.5), 86 | prev_upper = qbeta(0.975, prev_num+0.5, prev_denom-prev_num+0.5), 87 | inc_prob = inc_num/inc_denom, 88 | inc_lower = qbeta(0.025, inc_num+0.5, inc_denom-inc_num+0.5), 89 | inc_upper = qbeta(0.975, inc_num+0.5, inc_denom-inc_num+0.5), 90 | area = fct_recode(area, 91 | "North East"="North East (city region)", 92 | "West Midlands"="West Midlands (city region)"), 93 | disease = fct_recode(disease, 94 | "Dementia" = "Alzheimer's disease and other dementias", 95 | "Type 2 diabetes" = "Diabetes mellitus type 2", 96 | "Lung cancer" = "Tracheal, bronchus, and lung cancer", 97 | "COPD" = "Chronic obstructive pulmonary disease"), 98 | disease = factor(disease, levels = disease_order)) 99 | 100 | rundf <- data.frame( 101 | gender = rep(rep(c("Male","Female"),c(length(diseases_male),length(diseases_female))),length(areas)), 102 | disease = rep(c(diseases_male, diseases_female), length(areas)), 103 | area = rep(areas, each=length(diseases_male)+length(diseases_female)) 104 | ) %>% 105 | mutate(remission = disease %in% cancers, 106 | runid = 1:n(), 107 | # dcode = dcodes$dcode[match(disease, dcodes$disease)], 108 | increasing = ifelse(disease %in% c("Alzheimer's disease and other dementias", 109 | "Parkinson's disease", 110 | "Cardiomyopathy and myocarditis", 111 | "Multiple myeloma", 112 | "Liver cancer", 113 | "Non-rheumatic valvular heart disease", 114 | "Diabetes mellitus type 2", 115 | "Stomach cancer", 116 | "Tracheal, bronchus, and lung cancer", 117 | "Uterine cancer"), 118 | TRUE, FALSE), 119 | eqage = case_when(disease == "Ischemic heart disease" ~ 30, 120 | disease == "Stroke" ~ 30, 121 | disease == "Alzheimer's disease and other dementias" ~ 70, 122 | disease == "Uterine cancer" ~ 70, 123 | disease == "Stomach cancer" ~ 70, 124 | TRUE ~ 50)) 125 | rundf$scf_fixed <- rundf$sinc_fixed <- NA 126 | rundf$scf_fixed[rundf$gender=="Female" & rundf$disease=="Ischemic heart disease" & rundf$area=="London"] <- 1 127 | rundf$scf_fixed[rundf$gender=="Female" & rundf$disease=="Stroke" & rundf$area=="London"] <- TRUE 128 | rundf$sinc_fixed[rundf$gender=="Female" & rundf$disease=="Ischemic heart disease" & rundf$area=="London"] <- 1 129 | rundf$sinc_fixed[rundf$gender=="Female" & rundf$disease=="Stroke" & rundf$area=="London"] <- TRUE 130 | 131 | #nhrundf <- rundf %>% filter(!disease %in% c("Stomach cancer", "Uterine cancer")) 132 | rundf$rem_model <- ifelse(rundf$disease %in% cancers, "smooth", NA) 133 | rundf$rem_model[rundf$disease %in% c("Liver cancer","Uterine cancer")] <- "const" 134 | 135 | 136 | ## For 2019 run, remove utrc, stmc 137 | diseases_male_hier <- c("Ischemic heart disease", "Stroke", "Tracheal, bronchus, and lung cancer", 138 | "Colon and rectum cancer","Alzheimer's disease and other dementias", 139 | "Chronic obstructive pulmonary disease", "Diabetes mellitus type 2", 140 | "Parkinson's disease", 141 | "Non-rheumatic valvular heart disease") 142 | diseases_female_hier <- c(diseases_male_hier, "Breast cancer") 143 | 144 | hierrundf <- data.frame(gender = rep(c("Male","Female"), c(length(diseases_male_hier), 145 | length(diseases_female_hier))), 146 | disease = c(diseases_male_hier, diseases_female_hier), 147 | stringsAsFactors = FALSE) %>% 148 | mutate(model = case_when(disease %in% c("Alzheimer's disease and other dementias", 149 | "Tracheal, bronchus, and lung cancer", 150 | "Stomach cancer") ~ "increasing", 151 | disease %in% "Uterine cancer" ~ "const", 152 | TRUE ~ "interceptonly"), 153 | remission = disease %in% cancers, 154 | eqage = case_when(disease == "Ischemic heart disease" ~ 30, 155 | disease == "Stroke" ~ 30, 156 | disease == "Alzheimer's disease and other dementias" ~ 70, 157 | disease == "Uterine cancer" ~ 70, 158 | disease == "Stomach cancer" ~ 70, 159 | TRUE ~ 50) 160 | ) 161 | 162 | hierrungdf <- data.frame(disease = diseases_male_hier) %>% 163 | mutate(model = case_when(disease %in% c(#"Alzheimer's disease and other dementias", 164 | #"Tracheal, bronchus, and lung cancer", 165 | "Stomach cancer", 166 | "Uterine cancer") ~ "increasing", 167 | TRUE ~ "interceptonly"), 168 | remission = disease %in% cancers, 169 | eqage = case_when(disease == "Ischemic heart disease" ~ 30, 170 | disease == "Stroke" ~ 30, 171 | disease == "Alzheimer's disease and other dementias" ~ 70, 172 | disease == "Uterine cancer" ~ 70, 173 | disease == "Stomach cancer" ~ 70, 174 | TRUE ~ 50)) 175 | 176 | trendrundf <- rundf %>% 177 | filter(disease=="Ischemic heart disease") %>% 178 | mutate(runid = row_number()) 179 | 180 | natrundf <- rundf %>% 181 | filter(disease %in% c("Uterine cancer","Stomach cancer","Liver cancer","Head and neck cancer", 182 | "Multiple myeloma","Cardiomyopathy and myocarditis","Rheumatic heart disease")) %>% 183 | select(gender, disease, remission, increasing, rem_model, eqage) %>% 184 | distinct() %>% 185 | mutate(const = FALSE) %>% 186 | add_row(disease = "Head and neck cancer", gender="Male", remission = TRUE, increasing=FALSE, const=TRUE, rem_model="const", eqage=70) %>% 187 | add_row(disease = "Head and neck cancer", gender="Female", remission = TRUE, increasing=FALSE, const=TRUE, rem_model="const", eqage=70) %>% 188 | add_row(disease = "Rheumatic heart disease", gender="Male", remission = FALSE, increasing=FALSE, const=TRUE, rem_model=NA, eqage=70) %>% 189 | add_row(disease = "Rheumatic heart disease", gender="Female", remission = FALSE, increasing=FALSE, const=TRUE, rem_model=NA, eqage=70) %>% 190 | mutate(area="England") 191 | 192 | dcodes <- data.frame(name = unique(gbd$disease), 193 | code = tolower(abbreviate(unique(gbd$disease)))) 194 | dcodes$code <- gsub("\\\'","", dcodes$code) 195 | natrundf$runlabel <- tolower(paste(dcodes$code[match(natrundf$disease, dcodes$name)] 196 | , natrundf$gender, sep="_")) 197 | natrundf$sprior <- 1 198 | natrundf$sprior[natrundf$runlabel=="utrc_female"] <- 100 199 | -------------------------------------------------------------------------------- /metahit/paper_analyses_hier.r: -------------------------------------------------------------------------------- 1 | source("paper_analyses_header.r") 2 | nchains <- 2 3 | options(mc.cores = nchains) 4 | 5 | task_id <- as.numeric(Sys.getenv("SLURM_ARRAY_TASK_ID")) 6 | runs_todo <- 1:nrow(hierrundf) 7 | i <- runs_todo[task_id] 8 | 9 | mhi <- gbd %>% 10 | filter(gender==hierrundf$gender[i], disease==hierrundf$disease[i]) %>% 11 | droplevels 12 | hpfixed <- if (hierrundf$model[i]=="const") list(sd_int=TRUE,sinc=1) else list(scf=2.5,sinc=5) 13 | if (hierrundf$disease[i]=="Diabetes mellitus type 2" && hierrundf$gender[i]=="Female") hpfixed$sd_int <- TRUE 14 | if (hierrundf$disease[i]=="Non-rheumatic valvular heart disease" && hierrundf$gender[i]=="Female") hpfixed$sd_int <- TRUE 15 | 16 | db <- disbayes_hier(data=mhi, 17 | group = "area", 18 | inc_num = "inc_num", inc_denom = "inc_denom", 19 | mort_num = "mort_num", mort_denom = "mort_denom", 20 | prev_num = "prev_num", prev_denom = "prev_denom", 21 | rem_num = if (hierrundf$remission[i]) "rem_num" else NULL, 22 | rem_denom = if (hierrundf$remission[i]) "rem_denom" else NULL, 23 | cf_model = hierrundf$model[i], 24 | inc_model = "smooth", 25 | rem_model = if (hierrundf$remission[i]) "smooth" else NULL, 26 | eqage = hierrundf$eqage[i], 27 | hp_fixed = hpfixed, 28 | nfold_int_guess = 5, nfold_int_upper = 50, 29 | # method="opt", hessian=TRUE, draws=1000, verbose = TRUE 30 | method="mcmc", refresh = 1, chains=nchains, iter=1000, 31 | stan_control=list(max_treedepth=15) 32 | ) 33 | 34 | if (0){ 35 | library(bayesplot) 36 | mcmc_trace(db$fit,pars=c("sd_inter[1]"), 37 | np = nuts_params(db$fit)) 38 | pairs(db$fit, pars=c("sd_inter","sd_slope[1]")) 39 | color_scheme_set("darkgray") 40 | mcmc_parcoord(db$fit, np = nuts_params(db$fit), pars=c("sd_inter","sd_slope[1]")) 41 | saveRDS(db, file= paste0("results_hier/db", i, ".rds")) 42 | db <- readRDS(file= paste0("results_hier/db", i, ".rds")) 43 | } 44 | 45 | res <- tidy(db) %>% 46 | mutate(gender=hierrundf$gender[i], disease=hierrundf$disease[i]) 47 | 48 | loo <- looi_disbayes(db) %>% 49 | mutate(gender=hierrundf$gender[i], disease=hierrundf$disease[i]) 50 | 51 | saveRDS(list(res=res,loo=loo), file= paste0("results_hier/res", i, ".rds")) 52 | cat(sprintf("Fitted model for case %s\n", i), file="metahit-hpc-log.txt", append=TRUE) 53 | -------------------------------------------------------------------------------- /metahit/paper_analyses_national.r: -------------------------------------------------------------------------------- 1 | source("paper_analyses_header.r") 2 | nchains <- 2 3 | options(mc.cores = nchains) 4 | 5 | task_id <- as.numeric(Sys.getenv("SLURM_ARRAY_TASK_ID")) 6 | runs_todo <- 1:nrow(natrundf) 7 | i <- runs_todo[task_id] 8 | 9 | db <- disbayes(data = gbdeng %>% filter(disease==natrundf$disease[i], 10 | gender==natrundf$gender[i]), 11 | inc_num = "inc_num", inc_denom = "inc_denom", 12 | mort_num = "mort_num", mort_denom = "mort_denom", 13 | prev_num = "prev_num", prev_denom = "prev_denom", 14 | rem_num = if (natrundf$remission[i]) "rem_num" else NULL, 15 | rem_denom = if (natrundf$remission[i]) "rem_denom" else NULL, 16 | eqage = natrundf$eqage[i], 17 | cf_model = if (natrundf$increasing[i]) "increasing" else if (natrundf$const[i]) "const" else "smooth", 18 | rem_model = if (natrundf$remission[i]) natrundf$rem_model[i] else NULL, 19 | method="mcmc", chains=nchains, iter=2000, 20 | stan_control=list(max_treedepth=15) 21 | ) 22 | 23 | res <- tidy(db) %>% 24 | mutate(gender=natrundf$gender[i], disease=natrundf$disease[i], area=natrundf$area[i]) 25 | ## area should all be "England" 26 | 27 | loo <- looi_disbayes(db) %>% 28 | mutate(gender=natrundf$gender[i], disease=natrundf$disease[i], area=natrundf$area[i]) 29 | 30 | saveRDS(list(res=res,loo=loo), file=sprintf("results_nonhier/res_eng_%s.rds",natrundf$runlabel[i])) 31 | -------------------------------------------------------------------------------- /metahit/paper_analyses_nonhier.r: -------------------------------------------------------------------------------- 1 | if (0) { 2 | setwd("metahit") 3 | i <- 3 4 | } 5 | source("paper_analyses_header.r") 6 | nchains <- 2 7 | options(mc.cores = nchains) 8 | 9 | task_id <- as.numeric(Sys.getenv("SLURM_ARRAY_TASK_ID")) 10 | runs_todo <- 1:nrow(rundf) 11 | i <- runs_todo[task_id] 12 | 13 | mhi <- gbd %>% 14 | filter(gender==rundf$gender[i], disease==rundf$disease[i], area==rundf$area[i]) 15 | hpfixed <- list(scf=NULL, sinc=NULL) 16 | if (!is.na(rundf$scf_fixed[i])) hpfixed$scf <- rundf$scf_fixed[i] 17 | if (!is.na(rundf$sinc_fixed[i])) hpfixed$sinc <- rundf$sinc_fixed[i] 18 | 19 | db <- disbayes(data=mhi, 20 | inc_num = "inc_num", inc_denom = "inc_denom", 21 | mort_num = "mort_num", mort_denom = "mort_denom", 22 | prev_num = "prev_num", prev_denom = "prev_denom", 23 | rem_num = if (rundf$remission[i]) "rem_num" else NULL, 24 | rem_denom = if (rundf$remission[i]) "rem_denom" else NULL, 25 | eqage = rundf$eqage[i], 26 | cf_model = if (rundf$increasing[i]) "increasing" else "smooth", 27 | rem_model = if (rundf$remission[i]) rundf$rem_model[i] else NULL, 28 | hp_fixed = hpfixed, 29 | method = "mcmc", chains=nchains, iter=1000, refresh=10, 30 | stan_control=list(max_treedepth=15) 31 | ) 32 | 33 | 34 | res <- tidy(db) %>% 35 | mutate(gender=rundf$gender[i], disease=rundf$disease[i], area=rundf$area[i]) 36 | loo <- looi_disbayes(db) %>% 37 | mutate(gender=rundf$gender[i], disease=rundf$disease[i], area=rundf$area[i]) 38 | saveRDS(list(res=res, loo=loo), file= paste0("results_nonhier/res", i, ".rds")) 39 | 40 | if (0){ 41 | res %>% filter(var=="cf") %>% select(age, Rhat) 42 | library(bayesplot) 43 | mcmc_trace(db$fit, pars=paste0("cf[",70:74,"]")) 44 | 45 | conflict_disbayes(db, var="inc") 46 | conflict_disbayes(db, var="prev") 47 | conflict_disbayes(db, var="mort") 48 | } 49 | -------------------------------------------------------------------------------- /metahit/paper_analyses_pointests.r: -------------------------------------------------------------------------------- 1 | ### Analyses for the paper which use optimisation to produce posterior modes 2 | ### with credible intervals based on a normal approximation 3 | 4 | setwd("metahit") 5 | source("paper_analyses_header.r") 6 | 7 | ### Non-hierarchical model 8 | ### Results not used. Just for exploratory analysis and comparison of algorithms 9 | ### Empirical Bayes for smoothness pars for simplicity 10 | 11 | resopt_nonhier <- vector(nrow(rundf), mode="list") 12 | brkid <- c(191, 219, 222, 231, 235, 298) # fix the smooth pars for these 13 | brkid2 <- c(191, 219, 235) # ignore these 14 | 15 | # 232:nrow(rundf) 16 | for (i in brkid){ 17 | mhi <- gbd %>% 18 | filter(gender==rundf$gender[i], disease==rundf$disease[i], area==rundf$area[i]) 19 | if (i %in% brkid) { 20 | hpfixed <- list(scf=0.1, sinc=0.1, srem=0.1) 21 | } else { 22 | hpfixed <- list(scf=TRUE, sinc=TRUE, srem=TRUE) 23 | } 24 | try(db <- disbayes(data=mhi, 25 | #inc_num = "inc_num", inc_denom = "inc_denom", 26 | mort_num = "mort_num", mort_denom = "mort_denom", 27 | prev_num = "prev_num", prev_denom = "prev_denom", 28 | rem_num = if (rundf$remission[i]) "rem_num" else NULL, 29 | rem_denom = if (rundf$remission[i]) "rem_denom" else NULL, 30 | cf_model = if (rundf$increasing[i]) "increasing" else "smooth", 31 | rem_model = if (rundf$remission[i]) rundf$rem_model[i] else NULL, 32 | hp_fixed = hpfixed, 33 | eqage=rundf$eqage[i], 34 | sprior = c(1,10,10), 35 | hessian=TRUE, draws=1000, 36 | seed = i)) 37 | summ <- tidy(db) %>% 38 | mutate(gender=rundf$gender[i], disease=rundf$disease[i], area=rundf$area[i]) 39 | resopt_nonhier[[i]] <- summ 40 | cat(sprintf("Completed case %s out of %s\n",i,nrow(rundf))) 41 | } 42 | 43 | 44 | if (0){ 45 | diag(-db$fit$hessian) 46 | sqrt(diag(solve(-db$fit$hessian))) 47 | } 48 | 49 | resopt_nonhier <- do.call("rbind", resopt_nonhier[-brkid2]) 50 | saveRDS(resopt_nonhier, file="resopt_nonhier.rds") 51 | resopt_nonhier <- readRDS(file="resopt_nonhier.rds") 52 | 53 | 54 | 55 | ### National estimates (for rarer diseases) 56 | 57 | resopt_nat <- vector(nrow(natrundf), mode="list") 58 | 59 | for (i in 1:nrow(natrundf)) { 60 | db <- disbayes(data = gbdeng %>% filter(disease== natrundf$disease[i], 61 | gender== natrundf$gender[i]), 62 | inc_num = "inc_num", inc_denom = "inc_denom", 63 | mort_num = "mort_num", mort_denom = "mort_denom", 64 | prev_num = "prev_num", prev_denom = "prev_denom", 65 | rem_num = if (natrundf$remission[i]) "rem_num" else NULL, 66 | rem_denom = if (natrundf$remission[i]) "rem_denom" else NULL, 67 | cf_model = if (natrundf$increasing[i]) "increasing" else "smooth", 68 | rem_model = if (natrundf$remission[i]) natrundf$rem_model[i] else NULL, 69 | eqage= natrundf$eqage[i], 70 | seed = i, 71 | hp_fixed = list(scf = TRUE), 72 | sprior = c(inc=10, cf=natrundf$sprior[i]), 73 | hessian=TRUE 74 | ) 75 | resopt_nat[[i]] <- tidy(db) %>% 76 | mutate(gender=natrundf$gender[i], disease=natrundf$disease[i], area=natrundf$area[i]) 77 | cat(sprintf("Completed case %s out of %s\n",i,nrow(natrundf))) 78 | } 79 | 80 | resopt_nat <- do.call("rbind", resopt_nat) 81 | saveRDS(resopt_nat, file="resopt_nat.rds") 82 | resopt_nat <- readRDS(file="resopt_nat.rds") 83 | 84 | 85 | 86 | ### TIME TREND AND BIAS ANALYSIS - USING ONE CASE, IHD, LEEDS, MALE 87 | 88 | i <- 9 89 | mhi <- gbd %>% filter(disease== "Ischemic heart disease", 90 | area==trendrundf$area[i], 91 | gender==trendrundf$gender[i]) 92 | ihdtrends2019 <- readRDS("ihdtrends2019.rds") 93 | trends <- ihdtrends2019 %>% 94 | filter(outcome=="Incidence", gender==trendrundf$gender[i]) %>% 95 | arrange(age, year) %>% 96 | pivot_wider(names_from="year", values_from="p2019") %>% 97 | select(-age, -gender, -outcome) %>% 98 | as.matrix() 99 | 100 | cftrends <- ihdtrends2019 %>% 101 | filter(outcome=="Case fatality", gender==trendrundf$gender[i]) %>% 102 | arrange(age, year) %>% 103 | pivot_wider(names_from="year", values_from="p2019") %>% 104 | select(-age, -gender, -outcome) %>% 105 | as.matrix() 106 | 107 | 108 | ### Model with time trends, including all data 109 | 110 | dbt <- disbayes(data = mhi, 111 | inc_num = "inc_num", inc_denom = "inc_denom", 112 | prev_num = "prev_num", prev_denom = "prev_denom", 113 | mort_num = "mort_num", mort_denom = "mort_denom", 114 | rem_num = if (trendrundf$remission[i]) "rem_num" else NULL, 115 | rem_denom = if (trendrundf$remission[i]) "rem_denom" else NULL, 116 | cf_model = if (trendrundf$increasing[i]) "increasing" else "smooth", 117 | inc_trend = trends, 118 | cf_trend = cftrends, 119 | eqage= trendrundf$eqage[i], 120 | method = "opt", iter = 10000, verbose = TRUE, draws=1000 121 | ) 122 | 123 | rest <- tidy(dbt, startyear=1920) %>% 124 | mutate(model="Time trends, all data") 125 | 126 | ### Trend model omitting incidence 127 | 128 | dbt_noinc <- disbayes(data = mhi, 129 | prev_num = "prev_num", prev_denom = "prev_denom", 130 | mort_num = "mort_num", mort_denom = "mort_denom", 131 | rem_num = if (trendrundf$remission[i]) "rem_num" else NULL, 132 | rem_denom = if (trendrundf$remission[i]) "rem_denom" else NULL, 133 | cf_model = if (trendrundf$increasing[i]) "increasing" else "smooth", 134 | inc_trend = trends, 135 | cf_trend = cftrends, 136 | eqage= trendrundf$eqage[i], 137 | method = "opt", iter = 10000, verbose = TRUE, draws=1000 138 | ) 139 | 140 | rest_noinc <- tidy(dbt_noinc, startyear=1920) %>% 141 | mutate(model="Time trends, no incidence data") 142 | 143 | ## Compare with non-trend model 144 | ## Including incidence data 145 | mhi <- gbd %>% 146 | filter(disease=="Ischemic heart disease", gender=="Male", area=="Leeds") 147 | db <- disbayes(data=mhi, 148 | inc_num = "inc_num", inc_denom = "inc_denom", 149 | mort_num = "mort_num", mort_denom = "mort_denom", 150 | prev_num = "prev_num", prev_denom = "prev_denom", 151 | eqage=30, seed = 1, 152 | method = "opt", hessian=TRUE, draws=1000) 153 | rnh <- tidy(db) %>% 154 | mutate(disease="Ischemic heart disease", gender="Male", area="Leeds", 155 | model="No trends") 156 | conflict_disbayes(db, var="inc") 157 | conflict_disbayes(db, var="prev") 158 | conflict_disbayes(db, var="mort") 159 | 160 | ## Excluding incidence data 161 | mhi <- gbd %>% 162 | filter(disease=="Ischemic heart disease", gender=="Male", area=="Leeds") 163 | db <- disbayes(data=mhi, 164 | mort_num = "mort_num", mort_denom = "mort_denom", 165 | prev_num = "prev_num", prev_denom = "prev_denom", 166 | eqage=30, seed = 1, 167 | method = "opt", hessian=TRUE, draws=1000) 168 | rnh_noinc <- tidy(db) %>% 169 | mutate(model="No trends, no incidence data") 170 | 171 | rest_all <- rbind(rest, rest_noinc) %>% 172 | full_join(rnh) %>% full_join(rnh_noinc) %>% 173 | filter(var %in% c("inc_prob","cf_prob","prev_prob","mort_prob")) 174 | 175 | obsdat <- tidy_obsdat(dbt) %>% 176 | mutate(model="Observed data") %>% 177 | rename(est = prob) %>% 178 | mutate(var = fct_recode(var, "inc_prob"="inc", "prev_prob"="prev", 179 | "mort_prob"="mort")) 180 | 181 | res_checkfit <- rest_all %>% 182 | rename(est=mode, lower=`2.5%`, upper=`97.5%`) %>% 183 | full_join(obsdat %>% 184 | mutate(lower=NULL, upper=NULL)) %>% 185 | mutate(var = fct_recode(var, "Case fatality"="cf_prob", "Incidence"="inc_prob", 186 | "Mortality"="mort_prob","Prevalence"="prev_prob")) %>% 187 | mutate(model = relevel(factor(model), "Observed data")) %>% 188 | mutate(trend = ifelse(grepl("Time trends", model), "Time trends", "No trends"), 189 | incidence = ifelse(grepl("no incidence", model), 190 | "Incidence data excluded", 191 | "Incidence data included")) 192 | 193 | saveRDS(res_checkfit, file="res_checkfit.rds") 194 | res_checkfit <- readRDS(file="res_checkfit.rds") 195 | 196 | pdf("~/work/chronic/write/checkfit.pdf", width=6, height=3) 197 | 198 | hcols <- scales::hue_pal()(2) 199 | rcplot <- res_checkfit %>% 200 | filter(age>50) %>% 201 | filter(!(var=="cf_prob" & age > 90)) 202 | ggplot(rcplot %>% filter(model!="Observed data", 203 | !(var=="Case fatality" & est>0.1) 204 | ), 205 | aes(x=age, y=est, col=trend, lty=incidence)) + 206 | # geom_ribbon(aes(ymin=lower, ymax=upper, 207 | # fill=trend, col=NA), alpha=0.01) + 208 | geom_line(lwd = 1.0, alpha=0.8) + 209 | scale_colour_manual(values = c("black", hcols[1], hcols[2]), 210 | breaks = c("Observed data", "No trends", "Time trends")) + 211 | geom_line(data=rcplot %>% 212 | filter(model=="Observed data"), 213 | aes(col=model), lty=1, lwd = 1.0) + 214 | facet_wrap(~var, nrow=2, ncol=2, scales="free_y") + 215 | scale_y_continuous(limits=c(0,NA)) + 216 | ylab("Probability") + xlab("Age (years)") + 217 | labs(col="", lty="Data sources") + 218 | guides(fill="none", 219 | lty = guide_legend(order = 2, override.aes = list(col=hcols[1], fill=NA)), 220 | col = guide_legend(order = 1, override.aes = list(fill=NA))) 221 | 222 | dev.off() 223 | 224 | ## Animated plot for Armitage 225 | 226 | hcols <- scales::hue_pal()(2) 227 | res_fit_arm <- res_checkfit %>% 228 | filter(model!="Observed data" & !(var=="Case fatality" & est>0.1) 229 | ) %>% 230 | mutate(var = fct_relevel(var, "Case fatality", after = Inf)) 231 | gobs <- geom_line(data=res_checkfit %>% 232 | filter(model=="Observed data"), 233 | aes(col=model), lty=1, lwd = 1.2, alpha=0.6) 234 | pobs <- ggplot(res_fit_arm, 235 | aes(x=age, y=est, col=trend, lty=incidence)) + 236 | scale_colour_manual(values = c("black", hcols[1], hcols[2]), 237 | breaks = c("Observed data", "No trends", "Time trends")) + 238 | facet_wrap(~var, nrow=2, ncol=3, scales="free_y") + 239 | scale_y_continuous(limits=c(0,NA)) + 240 | ylab("Annual case fatality risk") + xlab("Age (years)") + 241 | labs(col="", lty="Data sources") + 242 | guides(fill="none", 243 | lty = guide_legend(order = 2, override.aes = list(col=hcols[1])), 244 | col = guide_legend(order = 1)) + 245 | gobs 246 | 247 | pobsfit <- pobs + geom_line(lwd=1.2) + gobs 248 | 249 | pdf("~/work/uncertainty/pres/armitage/checkfit_obs.pdf", width=8, height=3); pobs; dev.off() 250 | pdf("~/work/uncertainty/pres/armitage/checkfit_fit.pdf", width=8, height=3); pobsfit; dev.off() 251 | 252 | 253 | ### Sensitivity analysis to the shape of the time trend 254 | ## Form the sensitivity trends by a simple transformation 255 | # 1918:2010 trends the same, 2011:2017 trends shallower, final value 1 256 | # where c is chosen so that 2010/2017 value is a fraction of the original value 257 | # optimistic case: c=2 258 | # What about 0.0001, ie no trend at all after 2010. plausible lower bound on truth 259 | 260 | cftrends_sens <- cftrends_sensbig <- cftrends 261 | for (j in 1:100) { 262 | rold <- cftrends[j,"2010"] 263 | rnew <- 1 + 0.0001*(cftrends[j,"2010"] - 1) 264 | mult <- rnew/rold 265 | rnewbig <- 1 + 2*(cftrends[j,"2010"] - 1) 266 | multbig <- rnewbig/rold 267 | n1 <- length(1920:2009) 268 | n2 <- length(2010:2019) 269 | cftrends_sens[j,] <- cftrends[j,] * c(rep(mult, n1), seq(mult, 1, length.out = n2)) 270 | cftrends_sensbig[j,] <- cftrends[j,] * c(rep(multbig, n1), seq(multbig, 1, length.out = n2)) 271 | } 272 | 273 | dbt_sens <- disbayes(data = mhi, 274 | inc_num = "inc_num", inc_denom = "inc_denom", 275 | prev_num = "prev_num", prev_denom = "prev_denom", 276 | mort_num = "mort_num", mort_denom = "mort_denom", 277 | rem_num = NULL, rem_denom = NULL, 278 | cf_model = "smooth", 279 | inc_trend = trends, cf_trend = cftrends_sens, 280 | eqage= 30, 281 | method = "opt", iter = 10000, verbose = TRUE , hessian=TRUE, draws=1000 282 | ) 283 | 284 | rest_sens <- tidy(dbt_sens, startyear=1920) %>% 285 | mutate(model="Constant after 2010") 286 | 287 | dbt_sensbig <- disbayes(data = mhi, 288 | inc_num = "inc_num", inc_denom = "inc_denom", 289 | prev_num = "prev_num", prev_denom = "prev_denom", 290 | mort_num = "mort_num", mort_denom = "mort_denom", 291 | rem_num = NULL, rem_denom = NULL, 292 | cf_model = "smooth", 293 | inc_trend = trends, cf_trend = cftrends_sensbig, 294 | eqage= 30, 295 | method = "opt", iter = 10000, verbose = TRUE, hessian=TRUE, draws=1000 296 | ) 297 | 298 | rest_sensbig <- tidy(dbt_sensbig, startyear=1920) %>% 299 | mutate(model="2003-2010 trend accelerates") 300 | 301 | rest_sens_all <- rbind(rest %>% mutate(model="2003-2010 trend continues"), 302 | rest_sens, 303 | rest_sensbig) %>% 304 | full_join(rnh) %>% 305 | rename(est=mode, lower=`2.5%`, upper=`97.5%`) 306 | saveRDS(rest_sens_all, file="res_trend_sens.rds") 307 | 308 | rest_sens_all <- readRDS(file="res_trend_sens.rds") 309 | 310 | hcols <- c(scales::hue_pal()(2),"black") 311 | p <- 312 | rest_sens_all %>% 313 | filter(var %in% c("inc_prob","cf_prob","prev_prob")) %>% 314 | filter(age > 60 & age<90 & !(var=="cf_prob" & est>0.1)) %>% 315 | mutate(model=relevel(factor(model), "2003-2010 trend continues")) %>% 316 | mutate(var=fct_recode(var, 317 | "Incidence (annual risk)"="inc_prob", 318 | "Case fatality (annual risk)"="cf_prob", 319 | "Prevalence"="prev_prob")) %>% 320 | filter(model != "2003-2010 trend accelerates") %>% 321 | ggplot(aes(x=age, y=est, col=model)) + 322 | geom_line(lwd=1.2) + 323 | facet_wrap(~var, nrow=1, scales="free_y", labeller = label_wrap_gen(15)) + 324 | theme(strip.text = element_text(size=8), 325 | legend.title = element_text(size=10), 326 | legend.text = element_text(size=8) 327 | ) + 328 | scale_colour_manual(values=hcols[c(2,3,1)]) + 329 | scale_y_continuous(limits=c(0,NA)) + 330 | ylab("") + xlab("Age (years)") + 331 | labs(col="Assumption about\ncase fatality after 2010") 332 | 333 | 334 | pdf("~/work/chronic/write/trend_sens.pdf", width = 6, height = 2.5) 335 | p 336 | dev.off() 337 | 338 | 339 | res_checkfit %>% filter(var=="Case fatality", 340 | model %in% c("No trends", 341 | "Time trends, all data"), 342 | age == 70) 343 | rest_sens_all %>% filter(var=="cf", 344 | model %in% c("No trends", "2003-2010 trend continues"), 345 | age == 70) 346 | -------------------------------------------------------------------------------- /metahit/read_model_results.r: -------------------------------------------------------------------------------- 1 | ### Read, tidy and combine all results obtained from running MCMC simulations (parallelised for different cases) on a HPC cluster 2 | 3 | loo_names <- c("outcome", "elpd_loo", "mcse_elpd_loo", "p_loo", "looic", "influence_pareto_k", 4 | "age", "gender", "disease", "area") 5 | 6 | ## Non-hierarchical models with areas fitted independently 7 | 8 | reslist <- loolist <- vector(nrow(rundf), mode="list") 9 | for (i in 1:nrow(rundf)){ 10 | fname <- sprintf("results_nonhier/res%s.rds",i) 11 | if (file.exists(fname)) { 12 | resi <- readRDS(fname) 13 | reslist[[i]] <- resi$res 14 | loolist[[i]] <- resi$loo 15 | names(loolist[[i]])[names(loolist[[i]])=="var"] <- "outcome" # this changed in between runs 16 | loolist[[i]] <- loolist[[i]][,loo_names] 17 | } 18 | } 19 | dput(as.numeric(which(sapply(reslist, is.null)))) # check if any runs failed 20 | 21 | resnh <- do.call("rbind", reslist) %>% 22 | mutate(model="Independent areas") 23 | loonh <- do.call("rbind", loolist) %>% 24 | mutate(model="Independent areas") 25 | 26 | 27 | ## National estimates 28 | reslist <- loolist <- vector(nrow(natrundf), mode="list") 29 | for (i in 1:nrow(natrundf)){ 30 | fname <- sprintf("results_nonhier/res_eng_%s.rds",natrundf$runlabel[i]) 31 | if (file.exists(fname)) { 32 | resi <- readRDS(fname) 33 | reslist[[i]] <- resi$res 34 | loolist[[i]] <- resi$loo 35 | } 36 | } 37 | resnat <- do.call("rbind", reslist) %>% 38 | mutate(model="National") %>% droplevels 39 | loonat <- do.call("rbind", loolist) %>% 40 | mutate(model="National") %>% droplevels 41 | 42 | diseases_nat <- as.character(unique(resnat$disease)) 43 | 44 | resnh <- resnh %>% 45 | dplyr::filter(!(disease %in% diseases_nat)) %>% 46 | full_join(resnat) 47 | 48 | loonh <- loonh %>% 49 | dplyr::filter(!(disease %in% diseases_nat)) %>% 50 | full_join(loonat) 51 | 52 | 53 | ## Hierarchical models with genders fitted independently 54 | 55 | reslist <- loolist <- vector(nrow(hierrundf), mode="list") 56 | for (i in setdiff(1:nrow(hierrundf), c())){ 57 | fname <- sprintf("results_hier/res%s.rds",i) 58 | if (file.exists(fname)) { 59 | resi <- readRDS(fname) 60 | reslist[[i]] <- resi[[1]] 61 | loolist[[i]] <- resi[[2]] 62 | } 63 | } 64 | 65 | resh <- do.call("rbind", reslist) 66 | resh$model <- "Hierarchical" 67 | looh <- do.call("rbind", loolist) %>% 68 | mutate(area = factor(area, labels=areas), 69 | model = "Hierarchical") 70 | 71 | ## Hierarchical models with additive gender effects 72 | 73 | reslist <- loolist <- vector(nrow(hierrungdf), mode="list") 74 | for (i in setdiff(1:nrow(hierrungdf), c())){ # previously excluded stomach cancer 75 | resi <- readRDS(sprintf("results_hier_gender/res%s.rds",i)) 76 | reslist[[i]] <- resi[[1]] 77 | loolist[[i]] <- resi[[2]] 78 | } 79 | resg <- do.call("rbind", reslist) %>% 80 | mutate(model = "Hierarchical joint gender") 81 | loog <- do.call("rbind", loolist) %>% 82 | mutate(area = factor(area, labels=areas), 83 | model = "Hierarchical joint gender", 84 | gender = factor(gender, labels=genders)) 85 | 86 | 87 | ### Runs omitting incidence 88 | 89 | reslist <- loolist <- vector(nrow(rundf), mode="list") 90 | for (i in 1:nrow(rundf)){ 91 | fname <- sprintf("results_nonhier_noinc/res%s.rds",i) 92 | if (file.exists(fname)) { 93 | resi <- readRDS(fname) 94 | reslist[[i]] <- resi$res 95 | loolist[[i]] <- resi$loo 96 | } 97 | } 98 | dput(as.numeric(which(sapply(reslist, is.null)))) # check if any runs failed 99 | 100 | resnhi <- do.call("rbind", reslist) %>% 101 | mutate(model="Independent areas, no incidence data") 102 | loonhi <- do.call("rbind", loolist) %>% 103 | mutate(model="Independent areas, no incidence data") %>% 104 | filter(outcome!="inc") 105 | 106 | ### Collate all results 107 | 108 | resall <- full_join(resnh, resh) %>% 109 | full_join(resg) %>% 110 | full_join(resnhi) %>% 111 | mutate(disease = fct_recode(disease, !!!disease_shorten), 112 | disease = factor(disease, levels = disease_order)) %>% 113 | filter(!(var %in% c("rem_par", "inc_par", "cf_par", "state_probs"))) %>% 114 | ## these variable names changed in disbayes after the run 115 | ## state_probs wasn't recorded by area in hier model, and _par variables weren't excluded 116 | mutate(var = as.character(fct_recode(factor(var), 117 | "mort_prob" = "mort", 118 | "prev_prob" = "prev" 119 | ))) %>% 120 | ## This was an off-by-one bug in disbayes that has now been fixed 121 | mutate(age = ifelse(model=="Independent areas, no incidence data", age, age-1)) 122 | 123 | looall <- full_join(loonh, looh) %>% 124 | full_join(loog) %>% 125 | full_join(loonhi) %>% 126 | mutate(disease = fct_recode(disease, !!!disease_shorten), 127 | disease = factor(disease, levels = disease_order)) %>% 128 | filter(outcome != "rem") 129 | 130 | ## Identify selected model for each disease 131 | selected_model <- enframe( 132 | c("Dementia" = "Independent areas", 133 | "Breast cancer" = "Hierarchical", 134 | "Cardiomyopathy and myocarditis" = "National", 135 | "COPD" = "Hierarchical joint gender", 136 | "Colon and rectum cancer" = "Independent areas", 137 | "Type 2 diabetes" = "Independent areas", 138 | "Ischemic heart disease" = "Hierarchical", 139 | "Liver cancer" = "National", 140 | "Multiple myeloma" = "National", 141 | "Non-rheumatic valvular heart disease" = "Independent areas", 142 | "Parkinson's disease" = "Independent areas", 143 | "Rheumatic heart disease" = "National", 144 | "Stomach cancer" = "National", 145 | "Stroke" = "Independent areas", 146 | "Lung cancer" = "Independent areas", 147 | "Uterine cancer" = "National", 148 | "Head and neck cancer" = "National"), 149 | name="disease", value="selected_model" 150 | ) 151 | #Extent of uncertainty for CM differs between MCMC and opt. Others match 152 | #Diabetes, NV hier models didn't converge, PD hier gender didn't converge 153 | 154 | resall_selected <- resall %>% 155 | left_join(selected_model, by="disease") %>% 156 | filter(model == selected_model) %>% 157 | select(-selected_model) 158 | 159 | saveRDS(resall, "resall.rds") 160 | saveRDS(resall_selected, "resall_selected.rds") 161 | 162 | rs <- resall %>% filter(var=="cf", area=="Bristol", disease=="Dementia", age %in% 0:2) 163 | rs <- resall %>% filter(var=="cf", area=="Bristol", disease=="Dementia", age %in% 98:101) 164 | table(rs$age, rs$disease) 165 | -------------------------------------------------------------------------------- /metahit/resall.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/metahit/resall.rds -------------------------------------------------------------------------------- /metahit/resall_selected.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/metahit/resall_selected.rds -------------------------------------------------------------------------------- /metahit/slurm_bsu.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | #SBATCH -J metahit 3 | #SBATCH --time=24:00:00 4 | #SBATCH --cpus-per-task=2 5 | #SBATCH --array=[1-13]%8 6 | 7 | module purge 8 | module load default-login 9 | 10 | Rscript paper_analyses_national.r 11 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | STANHEADERS_SRC = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "message()" -e "cat(system.file('include', 'src', package = 'StanHeaders', mustWork = TRUE))" -e "message()" | grep "StanHeaders") 4 | 5 | STANC_FLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "cat(ifelse(utils::packageVersion('rstan') >= 2.26, '-DUSE_STANC3',''))") 6 | PKG_CPPFLAGS = -I"../inst/include" -I"$(STANHEADERS_SRC)" -DBOOST_DISABLE_ASSERTS -DEIGEN_NO_DEBUG -DBOOST_MATH_OVERFLOW_ERROR_POLICY=errno_on_error $(STANC_FLAGS) 7 | PKG_CXXFLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::CxxFlags()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::CxxFlags()") 8 | PKG_LIBS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::RcppParallelLibs()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::LdFlags()") 9 | 10 | CXX_STD = CXX14 11 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | STANHEADERS_SRC = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "message()" -e "cat(system.file('include', 'src', package = 'StanHeaders', mustWork = TRUE))" -e "message()" | grep "StanHeaders") 4 | 5 | STANC_FLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "cat(ifelse(utils::packageVersion('rstan') >= '2.26', '-DUSE_STANC3',''))") 6 | PKG_CPPFLAGS = -I"../inst/include" -I"$(STANHEADERS_SRC)" -DBOOST_DISABLE_ASSERTS -DEIGEN_NO_DEBUG -DRCPP_PARALLEL_USE_TBB=1 $(STANC_FLAGS) -D_HAS_AUTO_PTR_ETC=0 7 | PKG_CXXFLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::CxxFlags()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::CxxFlags()") 8 | PKG_LIBS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::RcppParallelLibs()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::LdFlags()") 9 | 10 | CXX_STD = CXX17 11 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | 15 | RcppExport SEXP _rcpp_module_boot_stan_fit4disbayes_mod(); 16 | RcppExport SEXP _rcpp_module_boot_stan_fit4disbayes_hier_mod(); 17 | 18 | static const R_CallMethodDef CallEntries[] = { 19 | {"_rcpp_module_boot_stan_fit4disbayes_mod", (DL_FUNC) &_rcpp_module_boot_stan_fit4disbayes_mod, 0}, 20 | {"_rcpp_module_boot_stan_fit4disbayes_hier_mod", (DL_FUNC) &_rcpp_module_boot_stan_fit4disbayes_hier_mod, 0}, 21 | {NULL, NULL, 0} 22 | }; 23 | 24 | RcppExport void R_init_disbayes(DllInfo *dll) { 25 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 26 | R_useDynamicSymbols(dll, FALSE); 27 | } 28 | -------------------------------------------------------------------------------- /src/stanExports_disbayes.cc: -------------------------------------------------------------------------------- 1 | // Generated by rstantools. Do not edit by hand. 2 | 3 | #include 4 | using namespace Rcpp ; 5 | #include "stanExports_disbayes.h" 6 | 7 | RCPP_MODULE(stan_fit4disbayes_mod) { 8 | 9 | 10 | class_ >("rstantools_model_disbayes") 11 | 12 | .constructor() 13 | 14 | 15 | .method("call_sampler", &rstan::stan_fit ::call_sampler) 16 | .method("param_names", &rstan::stan_fit ::param_names) 17 | .method("param_names_oi", &rstan::stan_fit ::param_names_oi) 18 | .method("param_fnames_oi", &rstan::stan_fit ::param_fnames_oi) 19 | .method("param_dims", &rstan::stan_fit ::param_dims) 20 | .method("param_dims_oi", &rstan::stan_fit ::param_dims_oi) 21 | .method("update_param_oi", &rstan::stan_fit ::update_param_oi) 22 | .method("param_oi_tidx", &rstan::stan_fit ::param_oi_tidx) 23 | .method("grad_log_prob", &rstan::stan_fit ::grad_log_prob) 24 | .method("log_prob", &rstan::stan_fit ::log_prob) 25 | .method("unconstrain_pars", &rstan::stan_fit ::unconstrain_pars) 26 | .method("constrain_pars", &rstan::stan_fit ::constrain_pars) 27 | .method("num_pars_unconstrained", &rstan::stan_fit ::num_pars_unconstrained) 28 | .method("unconstrained_param_names", &rstan::stan_fit ::unconstrained_param_names) 29 | .method("constrained_param_names", &rstan::stan_fit ::constrained_param_names) 30 | .method("standalone_gqs", &rstan::stan_fit ::standalone_gqs) 31 | ; 32 | } 33 | -------------------------------------------------------------------------------- /src/stanExports_disbayes_hier.cc: -------------------------------------------------------------------------------- 1 | // Generated by rstantools. Do not edit by hand. 2 | 3 | #include 4 | using namespace Rcpp ; 5 | #include "stanExports_disbayes_hier.h" 6 | 7 | RCPP_MODULE(stan_fit4disbayes_hier_mod) { 8 | 9 | 10 | class_ >("rstantools_model_disbayes_hier") 11 | 12 | .constructor() 13 | 14 | 15 | .method("call_sampler", &rstan::stan_fit ::call_sampler) 16 | .method("param_names", &rstan::stan_fit ::param_names) 17 | .method("param_names_oi", &rstan::stan_fit ::param_names_oi) 18 | .method("param_fnames_oi", &rstan::stan_fit ::param_fnames_oi) 19 | .method("param_dims", &rstan::stan_fit ::param_dims) 20 | .method("param_dims_oi", &rstan::stan_fit ::param_dims_oi) 21 | .method("update_param_oi", &rstan::stan_fit ::update_param_oi) 22 | .method("param_oi_tidx", &rstan::stan_fit ::param_oi_tidx) 23 | .method("grad_log_prob", &rstan::stan_fit ::grad_log_prob) 24 | .method("log_prob", &rstan::stan_fit ::log_prob) 25 | .method("unconstrain_pars", &rstan::stan_fit ::unconstrain_pars) 26 | .method("constrain_pars", &rstan::stan_fit ::constrain_pars) 27 | .method("num_pars_unconstrained", &rstan::stan_fit ::num_pars_unconstrained) 28 | .method("unconstrained_param_names", &rstan::stan_fit ::unconstrained_param_names) 29 | .method("constrained_param_names", &rstan::stan_fit ::constrained_param_names) 30 | .method("standalone_gqs", &rstan::stan_fit ::standalone_gqs) 31 | ; 32 | } 33 | -------------------------------------------------------------------------------- /tests/extra/test_vb.R: -------------------------------------------------------------------------------- 1 | source("data.r") 2 | 3 | test_that("standard disbayes model, variational Bayes",{ 4 | dbres <- disbayes(dat = ihdbristol, 5 | inc_num = "inc_num", inc_denom = "inc_denom", 6 | prev_num = "prev_num", prev_denom = "prev_denom", 7 | mort_num = "mort_num", mort_denom = "mort_denom", 8 | eqage = 40, loo=FALSE, method="vb", algorithm="meanfield") 9 | expect_s3_class(dbres, "disbayes") 10 | ## Needs more experience to interpret diagnostic values, e.g. khat 11 | }) 12 | -------------------------------------------------------------------------------- /tests/slow/test.R: -------------------------------------------------------------------------------- 1 | ihdbristol <- ihdengland %>% filter(location=="Bristol", sex=="Male") 2 | 3 | ## Smooth incidence. Noticeably slower than model with just smooth CF 4 | 5 | dbres <- disbayes(dat = ihdbristol, 6 | inc_num = "inc_num", inc_denom = "inc_denom", 7 | prev_num = "prev_num", prev_denom = "prev_denom", 8 | mort_num = "mort_num", mort_denom = "mort_denom", 9 | eqage = 40, 10 | smooth_inc = TRUE, 11 | chains = 1, iter_train = 400, iter=1000, loo=FALSE) 12 | 13 | 14 | ## Prevalence not supplied 15 | 16 | dbres <- disbayes(dat = ihdbristol, 17 | inc_num = "inc_num", inc_denom = "inc_denom", 18 | mort_num = "mort_num", mort_denom = "mort_denom", 19 | eqage = 40, smooth_inc = FALSE, 20 | chains = 1, iter_train = 400, iter=1000, loo=FALSE) 21 | 22 | ## Prevalence supplied, but not incidence. smooth incidence 23 | dbres2 <- disbayes(dat = ihdbristol, 24 | prev_num = "prev_num", prev_denom = "prev_denom", 25 | mort_num = "mort_num", mort_denom = "mort_denom", 26 | eqage = 40, smooth_inc = TRUE, 27 | chains = 1, iter_train = 400, iter=1000, loo=FALSE) 28 | 29 | # Unsmoothed model doesn't actually do too bad 30 | dbres <- disbayes(dat = ihdbristol, 31 | prev_num = "prev_num", prev_denom = "prev_denom", 32 | mort_num = "mort_num", mort_denom = "mort_denom", 33 | eqage = 40, smooth_inc = FALSE, 34 | chains = 1, iter_train = 400, iter=1000, loo=FALSE) 35 | 36 | summ <- tidy(dbres) 37 | summ <- tidy(dbres2) 38 | summ %>% filter(var=="inc") %>% 39 | ggplot(aes(x=age,y=`50%`,col=model,group=model)) + 40 | geom_line() + geom_point() + 41 | ylim(0,0.1) + 42 | geom_ribbon(aes(ymin=`2.5%`,ymax=`97.5%`), alpha=0.5) 43 | 44 | summ %>% filter(var=="cf") %>% 45 | ggplot(aes(x=age,y=`50%`,col=model,group=model)) + 46 | geom_line() + geom_point() + 47 | geom_ribbon(aes(ymin=`2.5%`,ymax=`97.5%`), alpha=0.5) 48 | 49 | -------------------------------------------------------------------------------- /tests/slow/test_hier.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | test_that("common case fatality to all areas", { 4 | db <- disbayes_hier(ihdmale, age="age", group="area", 5 | inc_num = "inc_num", inc_denom = "inc_denom", 6 | prev_num = "prev_num", prev_denom = "prev_denom", 7 | mort_num = "mort_num", mort_denom = "mort_denom", 8 | cf_model = "increasing_common", 9 | hp_fixed = list(scf = 1), 10 | method = "opt") 11 | plot(db) 12 | foo <- tidy(db) 13 | foo %>% filter(age==60, var=="cf") 14 | 15 | }) 16 | -------------------------------------------------------------------------------- /tests/slow/test_loo.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | ## disbayes by MCMC 4 | 5 | test_that("loo, MCMC", { 6 | db1 <- disbayes(dat = ihdbristol, 7 | inc_num = "inc_num", inc_denom = "inc_denom", 8 | prev_num = "prev_num", prev_denom = "prev_denom", 9 | mort_num = "mort_num", mort_denom = "mort_denom", 10 | cf_model = "smooth", 11 | eqage = 30, method="mcmc", chains=1, iter=100) 12 | 13 | db2 <- disbayes(dat = ihdbristol, 14 | inc_num = "inc_num", inc_denom = "inc_denom", 15 | prev_num = "prev_num", prev_denom = "prev_denom", 16 | mort_num = "mort_num", mort_denom = "mort_denom", 17 | cf_model = "const", 18 | eqage = 30, method="mcmc", chains=1, iter=100) 19 | 20 | loo1 <- loo(db1) 21 | loo2 <- loo(db2) 22 | lc <- loo::loo_compare(loo1,loo2) 23 | expect_true(lc["model1","elpd_diff"] > lc["model2","elpd_diff"]) 24 | 25 | ## Individual contributions 26 | li <- loo_indiv(loo1) 27 | expect_s3_class(li, "data.frame") 28 | expect_equal(sum(li$elpd_loo), 29 | loo1$estimates["elpd_loo","Estimate"]) 30 | 31 | ## Aggregated over outcome type 32 | liagg <- loo_indiv(loo1, agg=TRUE) 33 | expect_equal(sum(liagg$elpd_loo), 34 | loo1$estimates["elpd_loo","Estimate"]) 35 | }) 36 | 37 | ## Hierarchical models 38 | 39 | test_that("loo, hierarchical",{ 40 | db1 <- disbayes_hier(ihdmale, age="age", group="area", 41 | inc_num = "inc_num", inc_denom = "inc_denom", 42 | prev_num = "prev_num", prev_denom = "prev_denom", 43 | mort_num = "mort_num", mort_denom = "mort_denom", 44 | hp_fixed = list(sd_int=1, sd_slope=1, scf=1, sinc=1), 45 | method="opt", verbose=TRUE) 46 | 47 | db2 <- disbayes_hier(ihdmale, age="age", group="area", 48 | inc_num = "inc_num", inc_denom = "inc_denom", 49 | prev_num = "prev_num", prev_denom = "prev_denom", 50 | mort_num = "mort_num", mort_denom = "mort_denom", 51 | cf_model = "const", 52 | hp_fixed = list(sd_int=1, sinc=1), 53 | method="opt", verbose=TRUE) 54 | 55 | loo1 <- loo(db1) 56 | loo2 <- loo(db2) 57 | lc <- loo::loo_compare(loo1,loo2) 58 | expect_true(lc["model1","elpd_diff"] > lc["model2","elpd_diff"]) 59 | 60 | li <- loo_indiv(loo1) 61 | expect_equal(table(li$var)[[1]], 1700) 62 | }) 63 | -------------------------------------------------------------------------------- /tests/slow/test_opt.R: -------------------------------------------------------------------------------- 1 | test_that("remission supplied, rem_model settings",{ 2 | set.seed(1) 3 | db <- disbayes(dat = ihdbristol, 4 | inc_num = "inc_num", inc_denom = "inc_denom", 5 | prev_num = "prev_num", prev_denom = "prev_denom", 6 | mort_num = "mort_num", mort_denom = "mort_denom", 7 | rem_num = "rem_num", rem_denom = "rem_denom", 8 | eqage = 40) 9 | res <- tidy(db) 10 | rem <- res %>% filter(var=="rem") %>% slice(1) %>% pull(mode) 11 | expect_equal(rem, 0.1, tol=1e-01) 12 | db <- disbayes(dat = ihdbristol, 13 | inc_num = "inc_num", inc_denom = "inc_denom", 14 | prev_num = "prev_num", prev_denom = "prev_denom", 15 | mort_num = "mort_num", mort_denom = "mort_denom", 16 | rem_num = "rem_num", rem_denom = "rem_denom", 17 | rem_model = "smooth", 18 | eqage = 40) 19 | res <- tidy(db) 20 | rem <- res %>% filter(var=="rem") %>% slice(10) %>% pull(mode) 21 | expect_equal(rem, 0.1, tol=1e-01) 22 | db <- disbayes(dat = ihdbristol, 23 | inc_num = "inc_num", inc_denom = "inc_denom", 24 | prev_num = "prev_num", prev_denom = "prev_denom", 25 | mort_num = "mort_num", mort_denom = "mort_denom", 26 | rem_num = "rem_num", rem_denom = "rem_denom", 27 | rem_model = "indep", 28 | eqage = 40) 29 | res <- tidy(db) 30 | rem <- res %>% filter(var=="rem") %>% head(100) %>% pull(mode) 31 | expect_equal(mean(rem), 0.1, tol=1e-01) 32 | }) 33 | 34 | test_that("prevalence at age zero",{ 35 | db <- disbayes(dat = ihdbristol, 36 | inc_num = "inc_num", inc_denom = "inc_denom", 37 | prev_num = "prev_num", prev_denom = "prev_denom", 38 | mort_num = "mort_num", mort_denom = "mort_denom", 39 | prev_zero = FALSE, 40 | eqage = 40) 41 | res <- tidy(db) 42 | prevzero <- res %>% filter(age==0, var=="prev") 43 | expect_equal(prevzero$mode, 0) 44 | db <- disbayes(dat = ihdbristol, 45 | inc_num = "inc_num", inc_denom = "inc_denom", 46 | prev_num = "prev_num", prev_denom = "prev_denom", 47 | mort_num = "mort_num", mort_denom = "mort_denom", 48 | prev_zero = TRUE, 49 | eqage = 40) 50 | res <- tidy(db) 51 | prevzero <- res %>% filter(age==0, var=="prev") 52 | expect_false(prevzero$mode == 0) 53 | }) 54 | 55 | 56 | test_that("priors on rates",{ 57 | db1 <- disbayes(dat = ihdbristol, 58 | inc_num = "inc_num", inc_denom = "inc_denom", 59 | prev_num = "prev_num", prev_denom = "prev_denom", 60 | mort_num = "mort_num", mort_denom = "mort_denom", 61 | cf_model = "const", cf_prior = c(1, 2), 62 | eqage = 40) 63 | db2 <- disbayes(dat = ihdbristol, 64 | inc_num = "inc_num", inc_denom = "inc_denom", 65 | prev_num = "prev_num", prev_denom = "prev_denom", 66 | mort_num = "mort_num", mort_denom = "mort_denom", 67 | cf_model = "const", cf_prior = c(10, 2), 68 | eqage = 40) 69 | cf1 <- tidy(db1) %>% filter(var=="cf", age==60) %>% pull(mode) 70 | cf2 <- tidy(db2) %>% filter(var=="cf", age==60) %>% pull(mode) 71 | expect_true(cf2 > cf1) 72 | 73 | 74 | db1 <- disbayes(dat = ihdbristol, 75 | inc_num = "inc_num", inc_denom = "inc_denom", 76 | prev_num = "prev_num", prev_denom = "prev_denom", 77 | mort_num = "mort_num", mort_denom = "mort_denom", 78 | rem_num = "rem_num", rem_denom = "rem_denom", 79 | rem_model = "const", rem_prior = c(1, 2), 80 | eqage = 40) 81 | db2 <- disbayes(dat = ihdbristol, 82 | inc_num = "inc_num", inc_denom = "inc_denom", 83 | prev_num = "prev_num", prev_denom = "prev_denom", 84 | mort_num = "mort_num", mort_denom = "mort_denom", 85 | rem_num = "rem_num", rem_denom = "rem_denom", 86 | rem_model = "const", rem_prior = c(10, 2), 87 | eqage = 40) 88 | rem1 <- tidy(db1) %>% filter(var=="rem", age==60) %>% pull(mode) 89 | rem2 <- tidy(db2) %>% filter(var=="rem", age==60) %>% pull(mode) 90 | expect_true(rem2 > rem1) 91 | 92 | set.seed(1) 93 | ## Zero incidence causes fuzz problems for inc_prob, so add 1 94 | inc_dat <- ihdbristol 95 | inc_dat$inc_num <- inc_dat$inc_num + 1 96 | db1 <- disbayes(dat = inc_dat, 97 | inc_num = "inc_num", inc_denom = "inc_denom", 98 | prev_num = "prev_num", prev_denom = "prev_denom", 99 | mort_num = "mort_num", mort_denom = "mort_denom", 100 | inc_model = "indep", inc_prior = c(1, 1.1), 101 | eqage = 40) 102 | db2 <- disbayes(dat = inc_dat, 103 | inc_num = "inc_num", inc_denom = "inc_denom", 104 | prev_num = "prev_num", prev_denom = "prev_denom", 105 | mort_num = "mort_num", mort_denom = "mort_denom", 106 | inc_model = "indep", inc_prior = c(10, 1.1), 107 | eqage = 40) 108 | inc1 <- tidy(db1) %>% filter(var=="inc", age==60) %>% pull(mode) 109 | inc2 <- tidy(db2) %>% filter(var=="inc", age==60) %>% pull(mode) 110 | expect_true(inc2 > inc1) 111 | }) -------------------------------------------------------------------------------- /tests/test_base.R: -------------------------------------------------------------------------------- 1 | if (require("testthat")){ 2 | test_check("disbayes") 3 | } 4 | -------------------------------------------------------------------------------- /tests/testthat/data.r: -------------------------------------------------------------------------------- 1 | library(dplyr) 2 | library(tidyr) 3 | 4 | ihdbristol <- ihdengland %>% 5 | dplyr::filter(area=="Bristol", gender=="Male") %>% 6 | mutate( 7 | mort_prob = qbeta(0.5, mort_num+0.5, mort_denom-mort_num+0.5), 8 | mort_lower = qbeta(0.025, mort_num+0.5, mort_denom-mort_num+0.5), 9 | mort_upper = qbeta(0.975, mort_num+0.5, mort_denom-mort_num+0.5), 10 | inc_prob = qbeta(0.5, inc_num+0.5, inc_denom-inc_num+0.5), 11 | inc_lower = qbeta(0.025, inc_num+0.5, inc_denom-inc_num+0.5), 12 | inc_upper = qbeta(0.975, inc_num+0.5, inc_denom-inc_num+0.5), 13 | prev_prob = qbeta(0.5, prev_num+0.5, prev_denom-prev_num+0.5), 14 | prev_lower = qbeta(0.025, prev_num+0.5, prev_denom-prev_num+0.5), 15 | prev_upper = qbeta(0.975, prev_num+0.5, prev_denom-prev_num+0.5), 16 | rem_num = 10, 17 | rem_denom = 100) 18 | 19 | ihdmale <- ihdengland %>% 20 | dplyr::filter(gender=="Male") 21 | -------------------------------------------------------------------------------- /tests/testthat/test.R: -------------------------------------------------------------------------------- 1 | source("data.r") 2 | 3 | test_that("standard disbayes model, MCMC",{ 4 | dbres <- disbayes(dat = ihdbristol, 5 | inc_num = "inc_num", inc_denom = "inc_denom", 6 | prev_num = "prev_num", prev_denom = "prev_denom", 7 | mort_num = "mort_num", mort_denom = "mort_denom", 8 | eqage = 40, method="mcmc", algorithm="Fixed_param", 9 | chains=1, iter=100) 10 | expect_s3_class(dbres, "disbayes") 11 | }) 12 | 13 | test_that("data supplied as estimate and denominator",{ 14 | dbres <- disbayes(dat = ihdbristol, 15 | inc_num = "inc_num", inc_denom = "inc_denom", 16 | prev_num = "prev_num", prev_denom = "prev_denom", 17 | mort_prob = "mort_prob", mort_denom = "mort_denom", 18 | eqage = 40, method="mcmc", algorithm="Fixed_param", 19 | chains=1, iter=100) 20 | expect_s3_class(dbres, "disbayes") 21 | }) 22 | 23 | test_that("data supplied as estimate and credible limits",{ 24 | dbres <- disbayes(dat = ihdbristol, 25 | inc_num = "inc_num", inc_denom = "inc_denom", 26 | prev_num = "prev_num", prev_denom = "prev_denom", 27 | mort_prob = "mort_prob", mort_lower = "mort_lower", mort_upper="mort_upper", 28 | eqage = 40, method="mcmc", algorithm="Fixed_param", chains=1, iter=100) 29 | expect_s3_class(dbres, "disbayes") 30 | }) 31 | 32 | test_that("errors when insufficient data supplied",{ 33 | expect_error( 34 | disbayes(dat = ihdbristol, 35 | inc_num = "inc_num", inc_denom = "inc_denom", 36 | prev_num = "prev_num", prev_denom = "prev_denom", 37 | mort_prob = "mort_prob", 38 | eqage = 40, algorithm="Fixed_param"), 39 | "Not enough information" 40 | ) 41 | expect_error(disbayes(dat = ihdbristol, 42 | inc_num = "inc_num", inc_denom = "inc_denom", 43 | prev_num = "prev_num", prev_denom = "prev_denom", 44 | eqage = 40, algorithm="Fixed_param"), 45 | "Not enough information") 46 | }) 47 | 48 | test_that("increasing case fatality",{ 49 | dbres <- disbayes(dat = ihdbristol, 50 | inc_num = "inc_num", inc_denom = "inc_denom", 51 | prev_num = "prev_num", prev_denom = "prev_denom", 52 | mort_num = "mort_num", mort_denom = "mort_denom", 53 | cf_model = "increasing", 54 | eqage = 40, 55 | chains = 1, iter=100, 56 | method="mcmc", algorithm="Fixed_param") 57 | expect_s3_class(dbres, "disbayes") 58 | }) 59 | 60 | test_that("constant case fatality",{ 61 | dbres <- disbayes(dat = ihdbristol, 62 | inc_num = "inc_num", inc_denom = "inc_denom", 63 | prev_num = "prev_num", prev_denom = "prev_denom", 64 | mort_num = "mort_num", mort_denom = "mort_denom", 65 | cf_model = "const", 66 | eqage = 40, 67 | chains = 1, iter=100, 68 | method="mcmc", algorithm="Fixed_param") 69 | expect_s3_class(dbres, "disbayes") 70 | }) 71 | 72 | test_that("unsmooth incidence", { 73 | dbres <- disbayes(dat = ihdbristol, 74 | inc_num = "inc_num", inc_denom = "inc_denom", 75 | prev_num = "prev_num", prev_denom = "prev_denom", 76 | mort_num = "mort_num", mort_denom = "mort_denom", 77 | inc_model = "indep", 78 | chains = 1, iter=100, 79 | method="mcmc", algorithm="Fixed_param") 80 | expect_s3_class(dbres, "disbayes") 81 | }) 82 | 83 | #test_that("remission", { 84 | ## data not supplied 85 | ### data supplied 86 | #}) 87 | 88 | test_that("errors in age structure", { 89 | ihdbristol$badage <- ihdbristol$age 90 | ihdbristol$badage[20:30] <- 92 91 | expect_error(disbayes(dat = ihdbristol, age = "nonexistent", 92 | inc_num = "inc_num", inc_denom = "inc_denom", 93 | prev_num = "prev_num", prev_denom = "prev_denom", 94 | mort_num = "mort_num", mort_denom = "mort_denom", 95 | ), 96 | "age variable `nonexistent` not found") 97 | expect_error(disbayes(dat = ihdbristol, age = "badage", 98 | inc_num = "inc_num", inc_denom = "inc_denom", 99 | prev_num = "prev_num", prev_denom = "prev_denom", 100 | mort_num = "mort_num", mort_denom = "mort_denom" 101 | ), 102 | "one row per distinct year of age") 103 | ihdbristol$badage <- ihdbristol$age 104 | ihdbristol$badage[20:21] <- 20:19 105 | expect_error(disbayes(dat = ihdbristol, age = "badage", 106 | inc_num = "inc_num", inc_denom = "inc_denom", 107 | prev_num = "prev_num", prev_denom = "prev_denom", 108 | mort_num = "mort_num", mort_denom = "mort_denom" 109 | ), 110 | "ordered with one value per year of age") 111 | }) 112 | 113 | 114 | trends_inc <- ihdtrends %>% 115 | filter(outcome=="Incidence", gender=="Female") %>% 116 | pivot_wider(names_from="year", values_from="p2017") %>% 117 | select(-age, -gender, -outcome) %>% 118 | as.matrix() 119 | 120 | 121 | trends_cf <- ihdtrends %>% 122 | filter(outcome=="Case fatality", gender=="Female") %>% 123 | pivot_wider(names_from="year", values_from="p2017") %>% 124 | select(-age, -gender, -outcome) %>% 125 | as.matrix() 126 | 127 | 128 | ## Could move this to tests/slow if causes a problem. takes about 10 sec 129 | 130 | test_that("disbayes model with trends",{ 131 | dbres <- disbayes(dat = ihdbristol, 132 | inc_num = "inc_num", inc_denom = "inc_denom", 133 | prev_num = "prev_num", prev_denom = "prev_denom", 134 | mort_num = "mort_num", mort_denom = "mort_denom", 135 | eqage = 40, method="mcmc", algorithm="Fixed_param", 136 | inc_trend = trends_inc, 137 | cf_trend = trends_cf, 138 | chains=1, iter=10) 139 | expect_s3_class(dbres, "disbayes") 140 | }) 141 | 142 | 143 | test_that("errors in trend data", { 144 | trendsbad <- trends_inc[,1:2] 145 | expect_error( 146 | disbayes(data = ihdbristol, 147 | inc_num = "inc_num", inc_denom = "inc_denom", 148 | prev_num = "prev_num", prev_denom = "prev_denom", 149 | mort_num = "mort_num", mort_denom = "mort_denom", 150 | inc_trend = trendsbad), 151 | "trend matrix of dimension") 152 | 153 | expect_error( 154 | disbayes(data = ihdbristol, 155 | inc_num = "inc_num", inc_denom = "inc_denom", 156 | prev_num = "prev_num", prev_denom = "prev_denom", 157 | mort_num = "mort_num", mort_denom = "mort_denom", 158 | inc_trend = "wibble"), 159 | "trends data should be") 160 | 161 | }) 162 | 163 | 164 | test_that("errors when data are invalid",{ 165 | baddat <- ihdbristol 166 | baddat$inc_num <- baddat$inc_denom + 1 167 | expect_error( 168 | disbayes(dat = baddat, 169 | inc_num = "inc_num", inc_denom = "inc_denom", 170 | prev_num = "prev_num", prev_denom = "prev_denom", 171 | mort_prob = "mort_prob", 172 | eqage = 40), 173 | "should be <=" 174 | ) 175 | baddat <- ihdbristol 176 | baddat$inc_num[40] <- baddat$inc_denom[40] - 0.001 177 | expect_error( 178 | disbayes(dat = baddat, 179 | inc_num = "inc_num", inc_denom = "inc_denom", 180 | prev_num = "prev_num", prev_denom = "prev_denom", 181 | mort_num = "mort_num", mort_denom = "mort_denom", 182 | eqage = 40) 183 | , 184 | "should be integer" 185 | ) 186 | baddat <- ihdbristol 187 | baddat$mort_lower[80] <- 0.01 188 | baddat$mort_prob[80] <- 0.001 189 | expect_error( 190 | disbayes(dat = baddat, 191 | inc_num = "inc_num", inc_denom = "inc_denom", 192 | prev_num = "prev_num", prev_denom = "prev_denom", 193 | mort_prob = "mort_prob", mort_lower = "mort_lower", mort_upper = "mort_upper", 194 | eqage = 40) 195 | , 196 | "should be inside the credible interval" 197 | ) 198 | baddat <- ihdbristol 199 | baddat$mort_lower[40] <- 0.1 200 | baddat$mort_upper[40] <- 0.001 201 | expect_error( 202 | disbayes(dat = baddat, 203 | inc_num = "inc_num", inc_denom = "inc_denom", 204 | prev_num = "prev_num", prev_denom = "prev_denom", 205 | mort_prob = "mort_prob", mort_lower = "mort_lower", mort_upper = "mort_upper", 206 | eqage = 40) 207 | , 208 | "should be < mort_upper" 209 | ) 210 | }) 211 | 212 | test_that("sprior",{ 213 | expect_error(disbayes(dat = ihdbristol, 214 | inc_num = "inc_num", inc_denom = "inc_denom", 215 | prev_num = "prev_num", prev_denom = "prev_denom", 216 | mort_num = "mort_num", mort_denom = "mort_denom", 217 | sprior = c(1,1)), "should be a vector of 3") 218 | db <- disbayes(dat = ihdbristol, 219 | inc_num = "inc_num", inc_denom = "inc_denom", 220 | prev_num = "prev_num", prev_denom = "prev_denom", 221 | mort_num = "mort_num", mort_denom = "mort_denom", 222 | sprior = c(cf=1, inc=1000)) 223 | tidy(db) %>% filter(grepl("lambda", var)) 224 | plot(db, var="inc") 225 | }) 226 | 227 | 228 | test_that("errors and warnings in model specification",{ 229 | expect_warning( 230 | disbayes(dat = ihdbristol, 231 | inc_num = "inc_num", inc_denom = "inc_denom", 232 | prev_num = "prev_num", prev_denom = "prev_denom", 233 | mort_num = "mort_num", mort_denom = "mort_denom", 234 | inc_prior = c(2,2)), "Ignoring `inc_prior`") 235 | expect_warning( 236 | disbayes(dat = ihdbristol, 237 | inc_num = "inc_num", inc_denom = "inc_denom", 238 | prev_num = "prev_num", prev_denom = "prev_denom", 239 | mort_num = "mort_num", mort_denom = "mort_denom", 240 | cf_model = "smooth", 241 | cf_prior = c(2,2)), "Ignoring `cf_prior`") 242 | expect_error( 243 | disbayes(dat = ihdbristol, 244 | inc_num = "inc_num", inc_denom = "inc_denom", 245 | prev_num = "prev_num", prev_denom = "prev_denom", 246 | mort_num = "mort_num", mort_denom = "mort_denom", 247 | inc_model = "indep", 248 | inc_prior = c(2,2,3)), "`inc_prior` should be a numeric vector of 2 elements") 249 | expect_warning( 250 | disbayes(dat = ihdbristol, 251 | inc_num = "inc_num", inc_denom = "inc_denom", 252 | prev_num = "prev_num", prev_denom = "prev_denom", 253 | mort_num = "mort_num", mort_denom = "mort_denom", 254 | rem_model = "const", 255 | hp_fixed = list(srem = 1)), "Ignoring hp_fixed") 256 | expect_error( 257 | disbayes(dat = ihdbristol, 258 | inc_num = "inc_num", inc_denom = "inc_denom", 259 | prev_num = "prev_num", prev_denom = "prev_denom", 260 | mort_num = "mort_num", mort_denom = "mort_denom", 261 | rem_model = "const", 262 | hp_fixed = list(sinc = "one")), 263 | 'should be TRUE, FALSE or a single number') 264 | expect_error( 265 | disbayes(dat = ihdbristol, 266 | inc_num = "inc_num", inc_denom = "inc_denom", 267 | prev_num = "prev_num", prev_denom = "prev_denom", 268 | mort_num = "mort_num", mort_denom = "mort_denom", 269 | rem_model = "const", 270 | hp_fixed = list(sinc = c(1,1))), 271 | 'should be TRUE, FALSE or a single number') 272 | expect_error( 273 | disbayes(dat = ihdbristol, 274 | inc_num = "inc_num", inc_denom = "inc_denom", 275 | prev_num = "prev_num", prev_denom = "prev_denom", 276 | mort_num = "mort_num", mort_denom = "mort_denom", 277 | rem_model = "const", 278 | eqage = 101), 279 | 'eqage.+ should be') 280 | expect_error( 281 | disbayes(dat = ihdbristol, 282 | inc_num = "inc_num", inc_denom = "inc_denom", 283 | prev_num = "prev_num", prev_denom = "prev_denom", 284 | mort_num = "mort_num", mort_denom = "mort_denom", 285 | rem_model = "const", 286 | eqagehi = 101), 287 | 'eqagehi.+ should be') 288 | expect_error( 289 | disbayes(dat = ihdbristol, 290 | inc_num = "inc_num", inc_denom = "inc_denom", 291 | prev_num = "prev_num", prev_denom = "prev_denom", 292 | mort_num = "mort_num", mort_denom = "mort_denom", 293 | rem_model = "const", 294 | eqage = 50 , eqagehi=40), 295 | 'should have eqage% 30 | dplyr::filter(gender=="Female"), 31 | age="age", group="area", gender="gender", 32 | inc_num = "inc_num", inc_denom = "inc_denom", 33 | prev_num = "prev_num", prev_denom = "prev_denom", 34 | mort_num = "mort_num", mort_denom = "mort_denom"), 35 | "Only one gender found in data") 36 | 37 | ## call nonhier model by mistake 38 | expect_error( 39 | disbayes(ihdengland, age="age", 40 | inc_num = "inc_num", inc_denom = "inc_denom", 41 | prev_num = "prev_num", prev_denom = "prev_denom", 42 | mort_num = "mort_num", mort_denom = "mort_denom"), 43 | "rows in data") 44 | ihdengland$badage <- ihdengland$age 45 | ihdengland$badage[20:30] <- 92 46 | 47 | expect_error(disbayes_hier(ihdengland, age="nonexistent", group="area", gender="gender", 48 | inc_num = "inc_num", inc_denom = "inc_denom", 49 | prev_num = "prev_num", prev_denom = "prev_denom", 50 | mort_num = "mort_num", mort_denom = "mort_denom"), 51 | "age variable") 52 | 53 | expect_error(disbayes_hier(ihdengland, age = "badage", gender="gender", 54 | inc_num = "inc_num", inc_denom = "inc_denom", 55 | prev_num = "prev_num", prev_denom = "prev_denom", 56 | mort_num = "mort_num", mort_denom = "mort_denom" 57 | ), 58 | "`group` variable not supplied") 59 | 60 | expect_error(disbayes_hier(ihdengland, age = "badage", group="area", gender="gender", 61 | inc_num = "inc_num", inc_denom = "inc_denom", 62 | prev_num = "prev_num", prev_denom = "prev_denom", 63 | mort_num = "mort_num", mort_denom = "mort_denom" 64 | ), 65 | "value per year of age") 66 | 67 | ihdengland$badage <- ihdengland$age 68 | ihdengland$badage[20:21] <- 20:19 69 | expect_error(disbayes_hier(data = ihdengland, age = "badage", group="area", gender="gender", 70 | inc_num = "inc_num", inc_denom = "inc_denom", 71 | prev_num = "prev_num", prev_denom = "prev_denom", 72 | mort_num = "mort_num", mort_denom = "mort_denom" 73 | ), 74 | "one value per year of age") 75 | }) 76 | 77 | -------------------------------------------------------------------------------- /tests/testthat/test_loo.R: -------------------------------------------------------------------------------- 1 | source("data.r") 2 | 3 | ## Basic LOO - doesn't work so well for this kind of model 4 | ## See k diagnostics 5 | 6 | test_that("loo, standard ", { 7 | db1 <- disbayes(dat = ihdbristol, 8 | inc_num = "inc_num", inc_denom = "inc_denom", 9 | prev_num = "prev_num", prev_denom = "prev_denom", 10 | mort_num = "mort_num", mort_denom = "mort_denom", 11 | cf_model = "smooth", 12 | eqage = 30) 13 | 14 | db2 <- disbayes(dat = ihdbristol, 15 | inc_num = "inc_num", inc_denom = "inc_denom", 16 | prev_num = "prev_num", prev_denom = "prev_denom", 17 | mort_num = "mort_num", mort_denom = "mort_denom", 18 | cf_model = "const", 19 | eqage = 30) 20 | 21 | suppressWarnings(loo1 <- loo(db1)) 22 | suppressWarnings(loo2 <- loo(db2)) 23 | lc <- loo::loo_compare(loo1,loo2) 24 | expect_true(lc["model1","elpd_diff"] > lc["model2","elpd_diff"]) 25 | 26 | ## Individual contributions 27 | li <- loo_indiv(loo1) 28 | expect_s3_class(li, "data.frame") 29 | expect_equal(sum(li$elpd_loo), 30 | loo1$estimates["elpd_loo","Estimate"]) 31 | suppressWarnings(lid <- looi_disbayes(db1)) 32 | expect_equivalent(lid, li) 33 | 34 | ## Aggregated over outcome type 35 | liagg <- loo_indiv(loo1, agg=TRUE) 36 | expect_equal(sum(liagg$elpd_loo), 37 | loo1$estimates["elpd_loo","Estimate"]) 38 | }) 39 | -------------------------------------------------------------------------------- /tests/testthat/test_opt.R: -------------------------------------------------------------------------------- 1 | source("data.r") 2 | 3 | test_that("standard disbayes model, optimisation",{ 4 | set.seed(1) 5 | db <- disbayes(dat = ihdbristol, 6 | inc_num = "inc_num", inc_denom = "inc_denom", 7 | prev_num = "prev_num", prev_denom = "prev_denom", 8 | mort_num = "mort_num", mort_denom = "mort_denom", 9 | eqage = 40, seed=1) 10 | res <- tidy(db) %>% filter(var=="cf") 11 | expect_equal(res$mode[60], 0.0172128687091707, tol=1e-03) 12 | expect_equal(res$`50%`[60], 0.0173084702459764, tol=1e-03) 13 | 14 | od <- tidy_obsdat(db) 15 | expect_equal(od$denom[1], ihdbristol$inc_denom[1]) 16 | if (interactive()){ 17 | plotfit_data_disbayes(db) 18 | plotfit_disbayes(db) 19 | } 20 | 21 | cd <- conflict_disbayes(db, varname="inc") 22 | expect_lte(cd$p1[1], 1) 23 | expect_gte(cd$p1[1], 0) 24 | }) 25 | -------------------------------------------------------------------------------- /vignettes/disbayes.bib: -------------------------------------------------------------------------------- 1 | @article{dismod2, 2 | title={{A generic model for the assessment of disease epidemiology: the computational basis of DisMod II}}, 3 | author={Barendregt, J. J. and Van Oortmarssen, G. J. and Vos, T. and Murray, C. J. L.}, 4 | journal={Population Health Metrics}, 5 | volume={1}, 6 | number={1}, 7 | pages={4}, 8 | year={2003}, 9 | publisher={BioMed Central} 10 | } 11 | 12 | @article{gbd2019, 13 | title={{Global burden of 369 diseases and injuries in 204 countries and territories, 1990--2019: a systematic analysis for the Global Burden of Disease Study 2019}}, 14 | author={{GBD 2019 Diseases and Injuries Collaborators}}, 15 | journal={The Lancet}, 16 | volume={396}, 17 | number={10258}, 18 | pages={1204--1222}, 19 | year={2020}, 20 | publisher={Elsevier} 21 | } 22 | 23 | @article{blakely2020proportional, 24 | title={Proportional multistate lifetable modelling of preventive interventions: concepts, code and worked examples}, 25 | author={Blakely, T. and Moss, R. and Collins, J. and Mizdrak, A. and Singh, A. and Carvalho, N. and Wilson, N. and Geard, N. and Flaxman, A.}, 26 | journal={International Journal of Epidemiology}, 27 | volume={49}, 28 | number={5}, 29 | pages={1624--1636}, 30 | year={2020}, 31 | publisher={Oxford University Press} 32 | } 33 | 34 | @article{de2017health, 35 | title={{Health impact modelling of different travel patterns on physical activity, air pollution and road injuries for S{\~a}o Paulo, Brazil}}, 36 | author={{de S{\'a}}, T. H. and Tainio, M. and Goodman, A. and Edwards, P. and Haines, A. and Gouveia, N. and Monteiro, C. and Woodcock, J.}, 37 | journal={Environment International}, 38 | volume={108}, 39 | pages={22--31}, 40 | year={2017}, 41 | publisher={Elsevier} 42 | } 43 | 44 | @article{woodcock2014health, 45 | title={{Health effects of the London bicycle sharing system: health impact modelling study}}, 46 | author={Woodcock, J. and Tainio, M. and Cheshire, J. and O’Brien, O. and Goodman, A.}, 47 | journal={BMJ}, 48 | volume={348}, 49 | year={2014}, 50 | publisher={British Medical Journal Publishing Group} 51 | } 52 | 53 | @article{jaller2020active, 54 | title={{Active transportation and community health impacts of automated vehicle scenarios: an integration of the San Francisco Bay Area activity based travel demand model and the Integrated Transport and Health Impacts Model (ITHIM)}}, 55 | author={Jaller, M. and Pourrahmani, E. and Rodier, C. and Maizlish, N. and Zhang, M.}, 56 | journal={Cornell University CTECH Final Reports}, 57 | url={https://hdl.handle.net/1813/70173}, 58 | year={2020} 59 | } 60 | 61 | @article{cecchini2010tackling, 62 | title={Tackling of unhealthy diets, physical inactivity, and obesity: health effects and cost-effectiveness}, 63 | author={Cecchini, M. and Sassi, F. and Lauer, J. A. and Lee, Y. Y. and Guajardo-Barron, V. and Chisholm, D.}, 64 | journal={The Lancet}, 65 | volume={376}, 66 | number={9754}, 67 | pages={1775--1784}, 68 | year={2010}, 69 | publisher={Elsevier} 70 | } 71 | 72 | @article{kypridemos2016cardiovascular, 73 | title={Cardiovascular screening to reduce the burden from cardiovascular disease: microsimulation study to quantify policy options}, 74 | author={Kypridemos, C. and Allen, K. and Hickey, G. L. and Guzman-Castillo, M. and Bandosz, P. and Buchan, I. and Capewell, A. and O’Flaherty, M.}, 75 | journal={bmj}, 76 | volume={353}, 77 | year={2016}, 78 | publisher={British Medical Journal Publishing Group} 79 | } 80 | 81 | @article{rehm2009global, 82 | title={Global burden of disease and injury and economic cost attributable to alcohol use and alcohol-use disorders}, 83 | author={Rehm, J. and Mathers, C. and Popova, S. and Thavorncharoensap, M. and Teerawattananon, Y. and Patra, J.}, 84 | journal={The Lancet}, 85 | volume={373}, 86 | number={9682}, 87 | pages={2223--2233}, 88 | year={2009}, 89 | publisher={Elsevier} 90 | } 91 | 92 | @article{mytton2018current, 93 | title={{The current and potential health benefits of the National Health Service Health Check cardiovascular disease prevention programme in England: a microsimulation study}}, 94 | author={Mytton, O. T. and Jackson, C. and Steinacher, A. and Goodman, A. and Langenberg, C. and Griffin, S. and Wareham, N. and Woodcock, J.}, 95 | journal={PLoS Medicine}, 96 | volume={15}, 97 | number={3}, 98 | pages={e1002517}, 99 | year={2018}, 100 | publisher={Public Library of Science San Francisco, CA USA} 101 | } 102 | 103 | @article{scarborough2016assessing, 104 | title={{Assessing the external validity of model-based estimates of the incidence of heart attack in England: a modelling study}}, 105 | author={Scarborough, P. and Smolina, K. and Mizdrak, A. and Cobiac, L. and Briggs, A.}, 106 | journal={{BMC Public Health}}, 107 | volume={16}, 108 | number={1}, 109 | pages={1--8}, 110 | year={2016}, 111 | publisher={Springer} 112 | } 113 | 114 | @article{keiding1991age, 115 | title={Age-specific incidence and prevalence: a statistical perspective}, 116 | author={Keiding, N.}, 117 | journal={Journal of the Royal Statistical Society: Series A (Statistics in Society)}, 118 | volume={154}, 119 | number={3}, 120 | pages={371--396}, 121 | year={1991}, 122 | publisher={Wiley Online Library} 123 | } 124 | 125 | @article{barendregt:pmslt, 126 | title={Coping with multiple morbidity in a life table}, 127 | author={Barendregt, J. J. and {Van Oortmarssen}, G. J. and Van Hout, B. A. and {Van Den Bosch}, J. M. and Bonneux, L.}, 128 | journal={Mathematical Population Studies}, 129 | volume={7}, 130 | number={1}, 131 | pages={29--49}, 132 | year={1998}, 133 | publisher={Taylor \& Francis} 134 | } 135 | 136 | @article{briggs2016choosing, 137 | title={Choosing an epidemiological model structure for the economic evaluation of non-communicable disease public health interventions}, 138 | author={Briggs, A. D. M. and Wolstenholme, J. and Blakely, T. and Scarborough, P.}, 139 | journal={Population Health Metrics}, 140 | volume={14}, 141 | number={1}, 142 | pages={1--12}, 143 | year={2016}, 144 | publisher={BioMed Central} 145 | } 146 | 147 | @book{flaxman2015, 148 | title={An integrative metaregression framework for descriptive epidemiology}, 149 | author={Flaxman, A. D. and Vos, T. and Murray, C. J. L.}, 150 | year={2015}, 151 | publisher={University of Washington Press} 152 | } 153 | 154 | @article{peterson2013meta, 155 | title={{Meta-regression with DisMod-MR: how robust is the model?}}, 156 | author={Peterson, H. M. and Flaxman, A. D.}, 157 | journal={The Lancet}, 158 | volume={381}, 159 | pages={S110}, 160 | year={2013}, 161 | publisher={Elsevier} 162 | } 163 | 164 | @book{wood2017generalized, 165 | title={Generalized Additive Models: an Introduction with R}, 166 | author={Wood, S. N.}, 167 | year={2017}, 168 | edition={2nd}, 169 | publisher={CRC} 170 | } 171 | 172 | @Manual{dismod:mr, 173 | author = {Flaxman, A. D.}, 174 | title = {{dismod-mr 1.1.1: Integrative Meta-Regression Framework for Descriptive Epidemiology. Python package}}, 175 | url = {URL: \url{https://pypi.org/project/dismod-mr/}}, 176 | year = {2019} 177 | } 178 | 179 | @article{jagam, 180 | title={{Just Another Gibbs Additive Modeller: interfacing JAGS and mgcv}}, 181 | author={Wood, S. N.}, 182 | journal={Journal of Statistical Software}, 183 | volume={75}, 184 | number={7}, 185 | year={2016} 186 | } 187 | 188 | @Misc{ons:cancer:survival, 189 | OPTkey = {}, 190 | author = {{Office for National Statistics}}, 191 | title = {{Cancer survival in England: national estimates for patients followed up to 2017}}, 192 | howpublished = {URL: \url{https://www.ons.gov.uk/peoplepopulationandcommunity/healthandsocialcare/conditionsanddiseases/bulletins/cancersurvivalinengland/nationalestimatesforpatientsfollowedupto2017}}, 193 | OPTmonth = {}, 194 | OPTyear = {}, 195 | OPTnote = {}, 196 | OPTannote = {} 197 | } 198 | 199 | @article{threlfall2015appraisal, 200 | title={The appraisal of public health interventions: the use of theory}, 201 | author={Threlfall, A. G. and Meah, S. and Fischer, A. J. and Cookson, R. and Rutter, H. and Kelly, M. P.}, 202 | journal={Journal of Public Health}, 203 | volume={37}, 204 | number={1}, 205 | pages={166--171}, 206 | year={2015}, 207 | publisher={Oxford University Press} 208 | } 209 | 210 | 211 | @book{ohagan:elic, 212 | title={{Uncertain Judgements: Eliciting Experts' Probabilities}}, 213 | author={O'Hagan, A. and Buck, C. E. and Daneshkhah, A. and Eiser, J. R. and Garthwaite, P. H. and Jenkinson, D. J. and Oakley, J. E and Rakow, T.}, 214 | year={2006}, 215 | publisher={John Wiley \& Sons} 216 | } 217 | 218 | @article{smolina2012determinants, 219 | title={Determinants of the decline in mortality from acute myocardial infarction in England between 2002 and 2010: linked national database study}, 220 | author={Smolina, K. and Wright, F. L. and Rayner, M. and Goldacre, M. J.}, 221 | journal={{BMJ}}, 222 | volume={344}, 223 | year={2012}, 224 | publisher={British Medical Journal Publishing Group} 225 | } 226 | 227 | @Book{bhftrends2011, 228 | author = {Scarborough, P. and Wickramasinghe, K. and Bhatnagar, P. and Rayner, M.}, 229 | title = {Trends in coronary heart disease, 1961-2001}, 230 | publisher = {British Heart Foundation}, 231 | year = {2011} 232 | } 233 | 234 | @Book{bhf2020, 235 | author = {{British Heart Foundation}}, 236 | title = {{Heart and Circulatory Disease Statistics 2020}}, 237 | publisher = {British Heart Foundation}, 238 | year = {2020} 239 | } 240 | 241 | @Misc{rstan, 242 | title = {{RStan}: the {R} interface to {Stan}}, 243 | author = {{Stan Development Team}}, 244 | note = {R package version 2.21.2}, 245 | year = {2020}, 246 | url = {https://mc-stan.org/} 247 | } 248 | 249 | @Article{loocv, 250 | title = {Practical Bayesian model evaluation using leave-one-out cross-validation and WAIC}, 251 | author = {Vehtari, A. and Gelman, A. and Gabry, J.}, 252 | year = {2017}, 253 | journal = {Statistics and Computing}, 254 | volume = {27}, 255 | issue = {5}, 256 | pages = {1413--1432}, 257 | doi = {10.1007/s11222-016-9696-4}, 258 | } 259 | 260 | @Misc{loor, 261 | title = {loo: Efficient leave-one-out cross-validation and WAIC for Bayesian models}, 262 | author = {Vehtari, A. and Gabry, J. and Magnusson, M. and Yao, Y. and Bürkner, P.-C. and Paananen, T. and Gelman, A.}, 263 | year = {2020}, 264 | note = {R package version 2.4.1}, 265 | url = {https://mc-stan.org/loo/}, 266 | } 267 | 268 | @article{RJ-2013-028, 269 | author = {Sax, C. and Steiner, P.}, 270 | title = {{Temporal disaggregation of time series}}, 271 | year = {2013}, 272 | journal = {{The R Journal}}, 273 | doi = {10.32614/RJ-2013-028}, 274 | url = {https://doi.org/10.32614/RJ-2013-028}, 275 | pages = {80--87}, 276 | volume = {5}, 277 | number = {2} 278 | } 279 | 280 | @Article{disbayes_jrssa, 281 | author = {Jackson, C. H. and Zapata-Diomedi, B. and Woodcock, J.}, 282 | title = {{Bayesian multistate modelling of incomplete chronic disease burden data}}, 283 | journal = {Journal of the Royal Statistical Society Series A: Statistics in Society}, 284 | year = {2023}, 285 | doi = {10.1093/jrsssa/qnac015}, 286 | volume = {186}, 287 | number = {1}, 288 | pages = {1-19}, 289 | OPTmonth = {}, 290 | OPTnote = {}, 291 | OPTannote = {} 292 | } 293 | -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/__packages: -------------------------------------------------------------------------------- 1 | base 2 | disbayes 3 | dplyr 4 | -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.RData -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdb -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-4_1682f518ebe8613bed3c60bb08b6e750.rdx -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.RData -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdb -------------------------------------------------------------------------------- /vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_cache/html/unnamed-chunk-5_7730a69af6fd403d67251cc3ffbe6c1f.rdx -------------------------------------------------------------------------------- /vignettes/disbayes_files/figure-html/unnamed-chunk-10-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_files/figure-html/unnamed-chunk-10-1.png -------------------------------------------------------------------------------- /vignettes/disbayes_files/figure-html/unnamed-chunk-11-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_files/figure-html/unnamed-chunk-11-1.png -------------------------------------------------------------------------------- /vignettes/disbayes_files/figure-html/unnamed-chunk-9-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chjackson/disbayes/99c880c5adc14be30a6219b5c1f95c5f714b66a6/vignettes/disbayes_files/figure-html/unnamed-chunk-9-1.png --------------------------------------------------------------------------------